diff options
Diffstat (limited to 'src/Rahm/Desktop/Layout/Draw.hs')
| -rw-r--r-- | src/Rahm/Desktop/Layout/Draw.hs | 135 |
1 files changed, 72 insertions, 63 deletions
diff --git a/src/Rahm/Desktop/Layout/Draw.hs b/src/Rahm/Desktop/Layout/Draw.hs index ff90b9e..49921b0 100644 --- a/src/Rahm/Desktop/Layout/Draw.hs +++ b/src/Rahm/Desktop/Layout/Draw.hs @@ -1,33 +1,35 @@ -{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} module Rahm.Desktop.Layout.Draw (drawLayout) where -import Control.Monad - import Control.Arrow (second) import Control.Concurrent (threadDelay) import Control.Exception (handle) +import Control.Monad import Control.Monad.Writer (execWriter, tell) import Data.Foldable (find) import Data.Maybe (fromMaybe) import Rahm.Desktop.Hash (quickHash) import Rahm.Desktop.Layout.Pop (setPop) +import qualified Rahm.Desktop.StackSet as S import System.Directory (createDirectoryIfMissing, doesFileExist) import System.FilePath ((</>)) import Text.Printf (printf) -import XMonad.Layout.Spacing (SpacingModifier(..), Border(..)) -import XMonad.Layout.MosaicAlt (expandWindowAlt, shrinkWindowAlt) - -import XMonad (X, - Rectangle(..), - Dimension, - LayoutClass, - Message, - Window, - SomeMessage(..)) - +import XMonad + ( Dimension, + LayoutClass, + Message, + Rectangle (..), + SomeMessage (..), + Window, + X, + ) import qualified XMonad as X -import qualified Rahm.Desktop.StackSet as S +import XMonad.Layout.MosaicAlt (expandWindowAlt, shrinkWindowAlt) +import XMonad.Layout.Spacing (Border (..), SpacingModifier (..)) -- Draws and returns an XPM for the current layout. -- @@ -43,23 +45,24 @@ import qualified Rahm.Desktop.StackSet as S -- impure. While in-practice most layouts are pure, it should be kept in mind. drawLayout :: X (Bool, String, String) drawLayout = do - winset <- X.gets X.windowset - let layout = S.layout $ S.workspace $ S.current winset - - -- Gotta reset the layout to a consistent state. - layout' <- foldM (flip ($)) layout $ [ - handleMessage' $ ModifyWindowBorder $ const $ Border 0 0 0 0, - handleMessage' $ setPop $ const False + winset <- X.gets X.windowset + let layout = S.layout $ S.workspace $ S.current winset + + -- Gotta reset the layout to a consistent state. + layout' <- + foldM (flip ($)) layout $ + [ handleMessage' $ ModifyWindowBorder $ const $ Border 0 0 0 0, + handleMessage' $ setPop $ const False ] - -- Add some changes for the Mosaic layout to handle so it get's a - -- unique looking icon. (The default state is pretty boring). - ++ replicate 10 (handleMessage' (expandWindowAlt 1)) - ++ replicate 5 (handleMessage' (expandWindowAlt 4)) - ++ replicate 1 (handleMessage' (expandWindowAlt 3)) + -- Add some changes for the Mosaic layout to handle so it get's a + -- unique looking icon. (The default state is pretty boring). + ++ replicate 10 (handleMessage' (expandWindowAlt 1)) + ++ replicate 5 (handleMessage' (expandWindowAlt 4)) + ++ replicate 1 (handleMessage' (expandWindowAlt 3)) - (cached, xpm) <- drawXpmIO layout' + (cached, xpm) <- drawXpmIO layout' - return (cached , X.description layout, printf "<icon=%s/>" xpm) + return (cached, X.description layout, printf "<icon=%s/>" xpm) -- Returns true if a point is inside a rectangle (inclusive). pointInRect :: (Dimension, Dimension) -> Rectangle -> Bool @@ -76,8 +79,8 @@ sf :: (Integral a) => a sf = 1024 handleMessage' :: - (LayoutClass layout a, Message m) => m -> layout a -> X (layout a) -handleMessage' message layout = do + (LayoutClass layout a, Message m) => m -> layout a -> X (layout a) +handleMessage' message layout = do fromMaybe layout <$> X.handleMessage layout (SomeMessage message) -- Creates the XPM for the given layout and returns the path to it. @@ -89,15 +92,21 @@ drawXpmIO l = do dir <- X.asks (X.cfgDir . X.directories) let shrinkAmt = 5 -- amount to shrink the windows by to make pretty gaps. - let (w, h) = (56, 24) let descr = X.description l let iconCacheDir = dir </> "icons" </> "cache" let iconPath = iconCacheDir </> (quickHash descr ++ ".xpm") - let colors = [ - "#cc9a9a", "#cc9999", "#cc8080", "#cc6666", - "#cc4c4c", "#cc3232", "#cc1818", "#cc0000" ] + let colors = + [ "#cc9a9a", + "#cc9999", + "#cc8080", + "#cc6666", + "#cc4c4c", + "#cc3232", + "#cc1818", + "#cc0000" + ] (rects', _) <- X.runLayout @@ -105,7 +114,7 @@ drawXpmIO l = do (Rectangle 0 0 ((w + shrinkAmt) * sf) ((h + shrinkAmt) * sf)) let rects = flip map rects' $ \(_, Rectangle x y w h) -> - Rectangle (x `div` sf) (y `div` sf) (w `div` sf) (h `div` sf) + Rectangle (x `div` sf) (y `div` sf) (w `div` sf) (h `div` sf) X.liftIO $ do exists <- doesFileExist iconPath @@ -126,35 +135,35 @@ drawXpmIO l = do -- - The amount to shrink the windows by for those pretty gaps. -- drawXpm :: - (Dimension, Dimension) -> [(String, Rectangle)] -> Dimension -> String + (Dimension, Dimension) -> [(String, Rectangle)] -> Dimension -> String drawXpm (w, h) rects' shrinkAmt = execWriter $ do - tell "/* XPM */\n" - tell "static char *out[] = {\n" - tell $ printf "\"%d %d %d 1 \",\n" (w + 7) (h + 7) (length rects + 1) - - let zipRects = zip ['A' .. 'Z'] rects - - forM_ zipRects $ \(char, (color, _)) -> do - tell $ printf "\"%c c %s\",\n" char color - tell "\"% c #000000\",\n" - - forM_ [0..2] $ \_ -> do - tell "\"%%%" - forM_ [0 .. w] $ \_ -> tell "%" - tell "%%%\"\n" - forM_ [0 .. h] $ \y -> do - tell "\"%%%" - forM_ [0 .. w] $ \x -> - (case find (matches x y) zipRects of + tell "/* XPM */\n" + tell "static char *out[] = {\n" + tell $ printf "\"%d %d %d 1 \",\n" (w + 7) (h + 7) (length rects + 1) + + let zipRects = zip ['A' .. 'Z'] rects + + forM_ zipRects $ \(char, (color, _)) -> do + tell $ printf "\"%c c %s\",\n" char color + tell "\"% c #000000\",\n" + + forM_ [0 .. 2] $ \_ -> do + tell "\"%%%" + forM_ [0 .. w] $ \_ -> tell "%" + tell "%%%\"\n" + forM_ [0 .. h] $ \y -> do + tell "\"%%%" + forM_ [0 .. w] $ \x -> + ( case find (matches x y) zipRects of Nothing -> tell "%" - Just (chr, _) -> tell [chr]) - tell "%%%\"\n" - forM_ [0..2] $ \_ -> do - tell "\"%%%" - forM_ [0 .. w] $ \_ -> tell "%" - tell "%%%\"\n" - tell "};\n" - + Just (chr, _) -> tell [chr] + ) + tell "%%%\"\n" + forM_ [0 .. 2] $ \_ -> do + tell "\"%%%" + forM_ [0 .. w] $ \_ -> tell "%" + tell "%%%\"\n" + tell "};\n" where matches x y (_, (_, r)) = pointInRect (x, y) r rects = map (second (shrink shrinkAmt)) rects' |