From a8f8c03a10ecc593ae216bb995e0c317a69b31a8 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Tue, 12 Apr 2022 12:24:37 -0600 Subject: Move LayoutDraw -> Layout.Draw --- src/Rahm/Desktop/Layout/Draw.hs | 161 ++++++++++++++++++++++++++++++++++ src/Rahm/Desktop/Layout/LayoutDraw.hs | 161 ---------------------------------- src/Rahm/Desktop/XMobarLog.hs | 2 +- 3 files changed, 162 insertions(+), 162 deletions(-) create mode 100644 src/Rahm/Desktop/Layout/Draw.hs delete mode 100644 src/Rahm/Desktop/Layout/LayoutDraw.hs diff --git a/src/Rahm/Desktop/Layout/Draw.hs b/src/Rahm/Desktop/Layout/Draw.hs new file mode 100644 index 0000000..e68bb17 --- /dev/null +++ b/src/Rahm/Desktop/Layout/Draw.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, +ScopedTypeVariables, BangPatterns #-} +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.Writer (execWriter, tell) +import Data.Foldable (find) +import Data.Maybe (fromMaybe) +import Rahm.Desktop.Hash (quickHash) +import Rahm.Desktop.Layout.Pop (setPop) +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 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' $ 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)) + + (cached, xpm) <- drawXpmIO layout' + + return (cached , X.description layout, printf "" 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' + where + 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 <- X.getXMonadDir + + 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" ] + + (rects', _) <- + 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) + + X.liftIO $ do + exists <- doesFileExist iconPath + createDirectoryIfMissing True iconCacheDir + + unless exists $ do + let xpmText = drawXpm (w, h) (zip (cycle colors) rects) 4 + writeFile iconPath xpmText + + return (exists, iconPath) + +-- +-- 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" + tell $ printf "\"%d %d %d 1 \",\n" w h (length rects + 1) + + 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] $ \y -> do + tell "\"" + 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 "};\n" + + where + matches x y (_, (_, r)) = pointInRect (x, y) r + rects = map (second (shrink shrinkAmt)) rects' + guard a b = if a <= shrinkAmt then 1 else b + shrink amt (Rectangle x y w h) = + Rectangle + x + y + (guard w $ w - fromIntegral amt) + (guard h $ h - fromIntegral amt) diff --git a/src/Rahm/Desktop/Layout/LayoutDraw.hs b/src/Rahm/Desktop/Layout/LayoutDraw.hs deleted file mode 100644 index 7e628fc..0000000 --- a/src/Rahm/Desktop/Layout/LayoutDraw.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, -ScopedTypeVariables, BangPatterns #-} -module Rahm.Desktop.Layout.LayoutDraw (drawLayout) where - -import Control.Monad - -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 Rahm.Desktop.Hash (quickHash) -import Rahm.Desktop.Layout.Pop (setPop) -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 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' $ 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)) - - (cached, xpm) <- drawXpmIO layout' - - return (cached , X.description layout, printf "" 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' - where - 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 <- X.getXMonadDir - - 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" ] - - (rects', _) <- - 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) - - X.liftIO $ do - exists <- doesFileExist iconPath - createDirectoryIfMissing True iconCacheDir - - unless exists $ do - let xpmText = drawXpm (w, h) (zip (cycle colors) rects) 4 - writeFile iconPath xpmText - - return (exists, iconPath) - --- --- 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" - tell $ printf "\"%d %d %d 1 \",\n" w h (length rects + 1) - - 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] $ \y -> do - tell "\"" - 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 "};\n" - - where - matches x y (_, (_, r)) = pointInRect (x, y) r - rects = map (second (shrink shrinkAmt)) rects' - guard a b = if a <= shrinkAmt then 1 else b - shrink amt (Rectangle x y w h) = - Rectangle - x - y - (guard w $ w - fromIntegral amt) - (guard h $ h - fromIntegral amt) diff --git a/src/Rahm/Desktop/XMobarLog.hs b/src/Rahm/Desktop/XMobarLog.hs index 4b266c1..82c05b7 100644 --- a/src/Rahm/Desktop/XMobarLog.hs +++ b/src/Rahm/Desktop/XMobarLog.hs @@ -6,7 +6,7 @@ import Control.Monad.Writer (tell, execWriter) import Data.List (sortBy) import Data.Maybe (mapMaybe) import Data.Ord (comparing) -import Rahm.Desktop.Layout.LayoutDraw (drawLayout) +import Rahm.Desktop.Layout.Draw (drawLayout) import System.IO (Handle, hSetEncoding, hPutStrLn, utf8) import XMonad.Util.NamedWindows (getName) import XMonad.Util.Run (spawnPipe) -- cgit