diff options
Diffstat (limited to 'src/Internal/LayoutDraw.hs')
| -rw-r--r-- | src/Internal/LayoutDraw.hs | 145 |
1 files changed, 88 insertions, 57 deletions
diff --git a/src/Internal/LayoutDraw.hs b/src/Internal/LayoutDraw.hs index 78ff59d..8b029bd 100644 --- a/src/Internal/LayoutDraw.hs +++ b/src/Internal/LayoutDraw.hs @@ -1,45 +1,61 @@ {-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables, BangPatterns #-} -module Internal.LayoutDraw where +module Internal.LayoutDraw (drawLayout) where -import System.IO - -import Control.Monad.Writer -import XMonad.Layout.Spacing -import System.Process -import Text.Printf -import Control.Arrow -import Control.Exception import Control.Monad -import Control.Concurrent (threadDelay) - -import System.FilePath -import XMonad -import XMonad.StackSet as S -import Data.Maybe -import Data.Foldable -import System.Directory - -import Internal.Layout -import Internal.Hash - -showLayout :: X (Bool, String, Maybe String) -showLayout = do - winset <- gets windowset - let layout = S.layout . S.workspace . S.current $ winset - - layout' <- handleMessage layout ( - SomeMessage $ ModifyWindowBorder ( - const (Border 0 0 0 0))) - - let layout'' = layout' - - (cached, xpm) <- - case layout'' of - Just l -> drawXpmIO l - Nothing -> drawXpmIO layout - return $ (cached, description layout, Just $ printf "<icon=%s/>" xpm) +import Control.Arrow (second) +import Control.Concurrent (threadDelay) +import Control.Exception (handle) +import Control.Monad.Writer (execWriter, tell) +import Data.Foldable (find) +import Data.Maybe (fromMaybe) +import Internal.Hash (quickHash) +import Internal.Layout (ZoomModifier(..)) +import System.Directory (createDirectoryIfMissing, doesFileExist) +import System.FilePath ((</>)) +import Text.Printf (printf) +import XMonad.Layout.Spacing (SpacingModifier(..), Border(..)) + +import XMonad (X, + Rectangle(..), + Dimension, + LayoutClass, + Message, + Window, + SomeMessage(..)) + +import qualified XMonad as X +import qualified XMonad.StackSet as S + +-- Draws and returns an XPM for the current layout. +-- +-- Returns +-- - Bool - true if the xpm has already been written, and is thus cached. +-- - String - description of the current layout +-- - String - the text to send to XMobar +-- +-- This function actually runs the current layout's doLayout function to +-- generate the XPM, so it's completely portable to all layouts. +-- +-- Note this function is impure and running the layout to create the XPM is also +-- 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' $ Unzoom + ] + + (cached, xpm) <- drawXpmIO layout' + + return $ (cached, X.description layout, printf "<icon=%s/>" xpm) + +-- Returns true if a point is inside a rectangle (inclusive). pointInRect :: (Dimension, Dimension) -> Rectangle -> Bool pointInRect (x, y) (Rectangle x' y' w h) = x <= (fi x' + fi w) && x >= fi x' && y <= (fi y' + fi h) && y >= fi y' @@ -47,17 +63,29 @@ pointInRect (x, y) (Rectangle x' y' w h) = fi :: (Integral a, Num b) => a -> b fi = fromIntegral +-- Scale factory. Scaling the rectangles before writing the XPM helps to reduce +-- noise from things like AvoidStruts, as there is unfortunately no way to force +-- avoid struts to be off, one can only toggle it. sf :: (Integral a) => a sf = 1024 +handleMessage' :: + (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. +-- +-- This function does run doLayout on the given layout, and that should be +-- accounted for. drawXpmIO :: (LayoutClass layout Window) => layout Window -> X (Bool, String) drawXpmIO l = do - dir <- getXMonadDir + dir <- X.getXMonadDir - let shrinkAmt = 4 + let shrinkAmt = 5 -- amount to shrink the windows by to make pretty gaps. - let (w, h) = (56 + shrinkAmt, 28 + shrinkAmt) - let descr = description l + let (w, h) = (56, 24) + let descr = X.description l let iconCacheDir = dir </> "icons" </> "cache" let iconPath = iconCacheDir </> (quickHash descr ++ ".xpm") @@ -66,14 +94,14 @@ drawXpmIO l = do "#cc4c4c", "#cc3232", "#cc1818", "#cc0000" ] (rects', _) <- - runLayout - (Workspace "0" l (differentiate [1 .. 7])) - (Rectangle 0 0 (w * sf) (h * sf)) + X.runLayout + (S.Workspace "0" l (S.differentiate [1 .. 5])) + (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) - liftIO $ do + X.liftIO $ do exists <- doesFileExist iconPath createDirectoryIfMissing True iconCacheDir @@ -83,34 +111,37 @@ drawXpmIO l = do return (exists, iconPath) -drawXpm :: (Dimension, Dimension) -> [(String, Rectangle)] -> Dimension -> String +-- +-- Create's an XPM, purely. Returns a string with the XPM contents. +-- Takes as arguments +-- +-- - dimensions of the icon. +-- - list of (color, rectangle) pairs. +-- - The amount to shrink the windows by for those pretty gaps. +-- +drawXpm :: + (Dimension, Dimension) -> [(String, Rectangle)] -> Dimension -> String drawXpm (w, h) rects' shrinkAmt = execWriter $ do tell "/* XPM */\n" tell "static char *out[] = {\n" - forM_ rects' $ \(_, rect) -> do - tell $ "/* " ++ show rect ++ " */\n" - tell $ "/* --------------------------- */\n" - forM_ rects $ \(_, rect) -> do - tell $ "/* " ++ show rect ++ " */\n" - - tell $ printf "\"%d %d %d 1 \",\n" (w - shrinkAmt) (h - shrinkAmt) (length rects + 1) + tell $ printf "\"%d %d %d 1 \",\n" w h (length rects + 1) - let zipRects = (zip ['A' .. 'Z'] rects) + let zipRects = zip ['A' .. 'Z'] rects forM_ zipRects $ \(char, (color, _)) -> do tell $ printf "\"%c c %s\",\n" char color tell "\"% c None\"a,\n" - forM_ [0 .. h - 1 - shrinkAmt] $ \y -> do + forM_ [0 .. h - 1] $ \y -> do tell "\"" - forM_ [0 .. w - 1 - shrinkAmt] $ \x -> + forM_ [0 .. w - 1] $ \x -> (case find (matches x y) zipRects of Nothing -> tell "%" Just (chr, _) -> tell [chr]) tell "\"" when (y /= h - 1 - shrinkAmt) (tell ",") tell "\n" - tell "};" + tell "};\n" where matches x y (_, (_, r)) = pointInRect (x, y) r |