diff options
Diffstat (limited to 'src/Rahm/Desktop/Layout')
| -rw-r--r-- | src/Rahm/Desktop/Layout/Bordering.hs | 172 | ||||
| -rw-r--r-- | src/Rahm/Desktop/Layout/ConsistentMosaic.hs | 28 | ||||
| -rw-r--r-- | src/Rahm/Desktop/Layout/CornerLayout.hs | 24 | ||||
| -rw-r--r-- | src/Rahm/Desktop/Layout/Draw.hs | 135 | ||||
| -rw-r--r-- | src/Rahm/Desktop/Layout/Flip.hs | 57 | ||||
| -rw-r--r-- | src/Rahm/Desktop/Layout/Hole.hs | 9 | ||||
| -rw-r--r-- | src/Rahm/Desktop/Layout/List.hs | 125 | ||||
| -rw-r--r-- | src/Rahm/Desktop/Layout/Pop.hs | 86 | ||||
| -rw-r--r-- | src/Rahm/Desktop/Layout/Redescribe.hs | 14 | ||||
| -rw-r--r-- | src/Rahm/Desktop/Layout/ReinterpretMessage.hs | 12 | ||||
| -rw-r--r-- | src/Rahm/Desktop/Layout/Rotate.hs | 32 |
11 files changed, 367 insertions, 327 deletions
diff --git a/src/Rahm/Desktop/Layout/Bordering.hs b/src/Rahm/Desktop/Layout/Bordering.hs index 0a06319..5fb1259 100644 --- a/src/Rahm/Desktop/Layout/Bordering.hs +++ b/src/Rahm/Desktop/Layout/Bordering.hs @@ -1,45 +1,61 @@ {-# LANGUAGE DeriveAnyClass #-} -module Rahm.Desktop.Layout.Bordering - (Bordering(..), banishToBorder, unbanish, rotateBorderForward, - rotateBorderBackward, bordering, toggleBanish, - changeWidth, changeHeight, moveForward, moveBackward) where -import XMonad +module Rahm.Desktop.Layout.Bordering + ( Bordering (..), + banishToBorder, + unbanish, + rotateBorderForward, + rotateBorderBackward, + bordering, + toggleBanish, + changeWidth, + changeHeight, + moveForward, + moveBackward, + ) +where -import Control.Monad -import Data.Tuple (swap) import Control.Arrow +import Control.Monad +import Data.List (find, partition) import Data.Map (Map) -import Data.Maybe (fromMaybe) import qualified Data.Map as Map -import Data.List (partition, find) +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy) import qualified Data.Set as Set +import Data.Tuple (swap) import Data.Typeable (cast) -import Data.Proxy (Proxy) - import Rahm.Desktop.Logger import qualified Rahm.Desktop.StackSet as W +import XMonad -data BorderPosition = - North | NorthEast | East | SouthEast | South | SouthWest | West | NorthWest +data BorderPosition + = North + | NorthEast + | East + | SouthEast + | South + | SouthWest + | West + | NorthWest deriving (Eq, Show, Read, Ord, Enum, Bounded) -data BorderingData a = - BorderingData { - extraWindows :: Map BorderPosition a - , borderingWidth :: Rational - , borderingHeight :: Rational - , borderingPadding :: Int - } deriving (Eq, Ord, Show, Read) - -data Bordering (l :: * -> *) (a :: *) = - Bordering { - borderingData :: BorderingData a, +data BorderingData a = BorderingData + { extraWindows :: Map BorderPosition a, + borderingWidth :: Rational, + borderingHeight :: Rational, + borderingPadding :: Int + } + deriving (Eq, Ord, Show, Read) + +data Bordering (l :: * -> *) (a :: *) = Bordering + { borderingData :: BorderingData a, wrappedLayout :: l a - } deriving (Eq, Ord, Show, Read) + } + deriving (Eq, Ord, Show, Read) -data ModifyBordering a = - ModifyBordering (BorderingData a -> BorderingData a) +data ModifyBordering a + = ModifyBordering (BorderingData a -> BorderingData a) deriving (Message) enumNext :: (Eq a, Enum a, Bounded a) => a -> a @@ -53,40 +69,39 @@ enumPrev a | otherwise = pred a bordering :: l a -> Bordering l a -bordering = Bordering (BorderingData mempty (1/6) (1/6) 10) +bordering = Bordering (BorderingData mempty (1 / 6) (1 / 6) 10) banishToBorder :: a -> ModifyBordering a banishToBorder win = let allPositions = - (\(a, b) -> b ++ a) $ break (==SouthEast) [minBound .. maxBound] - in - ModifyBordering $ \dat -> + (\(a, b) -> b ++ a) $ break (== SouthEast) [minBound .. maxBound] + in ModifyBordering $ \dat -> maybe dat - (\pos -> - dat { extraWindows = Map.insert pos win (extraWindows dat)}) $ - find (not . (`Map.member`extraWindows dat)) allPositions + ( \pos -> + dat {extraWindows = Map.insert pos win (extraWindows dat)} + ) + $ find (not . (`Map.member` extraWindows dat)) allPositions toggleBanish :: (Eq a) => a -> ModifyBordering a toggleBanish win = ModifyBordering $ \dat -> - let (ModifyBordering fn) = + let (ModifyBordering fn) = if elem win $ Map.elems $ extraWindows dat then unbanish win else banishToBorder win - in fn dat - + in fn dat unbanish :: (Eq a) => a -> ModifyBordering a unbanish win = ModifyBordering $ \dat -> maybe dat - (\pos -> dat { extraWindows = Map.delete pos (extraWindows dat) }) $ - (fst <$> find ((==win) . snd) (Map.toList $ extraWindows dat)) + (\pos -> dat {extraWindows = Map.delete pos (extraWindows dat)}) + $ (fst <$> find ((== win) . snd) (Map.toList $ extraWindows dat)) rotateBorder :: (BorderPosition -> BorderPosition) -> ModifyBordering a rotateBorder next = ModifyBordering $ \dat -> - dat { extraWindows = Map.mapKeys next (extraWindows dat) } + dat {extraWindows = Map.mapKeys next (extraWindows dat)} rotateBorderForward :: Proxy a -> ModifyBordering a rotateBorderForward _ = rotateBorder enumNext @@ -96,45 +111,48 @@ rotateBorderBackward _ = rotateBorder enumPrev changeWidth :: Proxy a -> Rational -> ModifyBordering a changeWidth _ amt = ModifyBordering $ \dat -> - dat { borderingWidth = guard $ borderingWidth dat + amt } - where guard x | x < 1/12 = 1/12 - | x > 4/12 = 4/12 - | otherwise = x + dat {borderingWidth = guard $ borderingWidth dat + amt} + where + guard x + | x < 1 / 12 = 1 / 12 + | x > 4 / 12 = 4 / 12 + | otherwise = x changeHeight :: Proxy a -> Rational -> ModifyBordering a changeHeight _ amt = ModifyBordering $ \dat -> - dat { borderingHeight = guard $ borderingHeight dat + amt } - where guard x | x < 1/12 = 1/12 - | x > 4/12 = 4/12 - | otherwise = x + dat {borderingHeight = guard $ borderingHeight dat + amt} + where + guard x + | x < 1 / 12 = 1 / 12 + | x > 4 / 12 = 4 / 12 + | otherwise = x instance Semigroup (ModifyBordering a) where (<>) = mappend instance Monoid (ModifyBordering a) where - mempty = ModifyBordering id mappend (ModifyBordering f1) (ModifyBordering f2) = ModifyBordering (f2 . f1) - move :: (Eq a) => (BorderPosition -> BorderPosition) -> a -> ModifyBordering a move fn win = ModifyBordering $ \dat -> - let mKey = fst <$> find ((==win) . snd) (Map.toList $ extraWindows dat) in - case mKey of - Nothing -> dat - Just key -> - let newKey = until (\k -> not (Map.member k (extraWindows dat) && k /= key)) - fn (fn key) - wins' = Map.insert newKey win $ Map.delete key $ extraWindows dat - in - dat { extraWindows = wins' } + let mKey = fst <$> find ((== win) . snd) (Map.toList $ extraWindows dat) + in case mKey of + Nothing -> dat + Just key -> + let newKey = + until + (\k -> not (Map.member k (extraWindows dat) && k /= key)) + fn + (fn key) + wins' = Map.insert newKey win $ Map.delete key $ extraWindows dat + in dat {extraWindows = wins'} moveForward :: (Eq a) => a -> ModifyBordering a moveForward = move enumNext moveBackward :: (Eq a) => a -> ModifyBordering a moveBackward = move enumPrev - instance (Show a, Ord a, LayoutClass l a, Typeable a) => LayoutClass (Bordering l) a where runLayout (W.Workspace t (Bordering dat l) as) rect = do @@ -145,35 +163,33 @@ instance (Show a, Ord a, LayoutClass l a, Typeable a) => LayoutClass (Bordering filterStack Nothing = ([], Nothing) filterStack (Just (W.Stack f h t)) = do let elSet = Set.fromList (Map.elems $ extraWindows dat) - ((hp, h'), (tp, t')) = dbl (partition (`Set.member`elSet)) (h, t) - in case (Set.member f elSet, h', t', hp ++ tp) of - (False, _, _, r) -> (r, Just $ W.Stack f h' t') - (True, (a:h''), _, r) -> (f:r, Just $ W.Stack a h'' t') - (True, [], (a:t''), r) -> (f:r, Just $ W.Stack a [] t'') - (True, [], [], r) -> (f:r, Nothing) + ((hp, h'), (tp, t')) = dbl (partition (`Set.member` elSet)) (h, t) + in case (Set.member f elSet, h', t', hp ++ tp) of + (False, _, _, r) -> (r, Just $ W.Stack f h' t') + (True, (a : h''), _, r) -> (f : r, Just $ W.Stack a h'' t') + (True, [], (a : t''), r) -> (f : r, Just $ W.Stack a [] t'') + (True, [], [], r) -> (f : r, Nothing) layoutRest windows = map (second (scaleRationalRect (padRect rect) . loc2Rect) . swap) $ - filter ((`elem`windows) . snd) $ + filter ((`elem` windows) . snd) $ Map.toList (extraWindows dat) padRect (Rectangle x y w h) = let p :: (Integral a) => a - p = fromIntegral (borderingPadding dat) in - Rectangle (x + p) (y + p) (w - p*2) (h - p*2) + p = fromIntegral (borderingPadding dat) + in Rectangle (x + p) (y + p) (w - p * 2) (h - p * 2) loc2Rect loc = case loc of - North -> W.RationalRect (1/2 - (bw / 2)) 0 bw bh + North -> W.RationalRect (1 / 2 - (bw / 2)) 0 bw bh NorthEast -> W.RationalRect (1 - bw) 0 bw bh - East -> W.RationalRect (1 - bw) (1/2 - (bh / 2)) bw bh + East -> W.RationalRect (1 - bw) (1 / 2 - (bh / 2)) bw bh SouthEast -> W.RationalRect (1 - bw) (1 - bh) bw bh - South -> W.RationalRect (1/2 - (bw / 2)) (1 - bh) bw bh + South -> W.RationalRect (1 / 2 - (bw / 2)) (1 - bh) bw bh SouthWest -> W.RationalRect 0 (1 - bh) bw bh - West -> W.RationalRect 0 (1/2 - (bh / 2)) bw bh + West -> W.RationalRect 0 (1 / 2 - (bh / 2)) bw bh NorthWest -> W.RationalRect 0 0 bw bh - where - bw = borderingWidth dat bh = borderingHeight dat @@ -183,12 +199,10 @@ instance (Show a, Ord a, LayoutClass l a, Typeable a) => LayoutClass (Bordering maybeNewLayout <- handleMessage l m return $ Just $ Bordering (f d) (fromMaybe l maybeNewLayout) where - f e@BorderingData{ extraWindows = ws } = - e { extraWindows = Map.filter (maybe True (/=w) . cast) ws } - + f e@BorderingData {extraWindows = ws} = + e {extraWindows = Map.filter (maybe True (/= w) . cast) ws} handleMessage (Bordering d l) (fromMessage -> Just (ModifyBordering fn)) = return (Just $ Bordering (fn d) l) - handleMessage (Bordering d l) a = do maybeNewLayout <- handleMessage l a return (Bordering d <$> maybeNewLayout) diff --git a/src/Rahm/Desktop/Layout/ConsistentMosaic.hs b/src/Rahm/Desktop/Layout/ConsistentMosaic.hs index 3dbc44c..0d95c8f 100644 --- a/src/Rahm/Desktop/Layout/ConsistentMosaic.hs +++ b/src/Rahm/Desktop/Layout/ConsistentMosaic.hs @@ -1,27 +1,23 @@ - -- This module provides a wrapper around the Mosaic layout to create a more -- consistent experience where instead of the windows being the ones it works -- on, it instead works on the window places so things like window swapping -- still work as expected. module Rahm.Desktop.Layout.ConsistentMosaic where -import XMonad -import qualified Rahm.Desktop.StackSet as W -import qualified Data.Map as Map import Data.Map (Map) +import qualified Data.Map as Map import Data.Maybe (mapMaybe) - -import XMonad.Layout.MosaicAlt - import Rahm.Desktop.Logger - +import qualified Rahm.Desktop.StackSet as W +import XMonad +import XMonad.Layout.MosaicAlt newtype MosaicWrap l a = MosaicWrap (l a) deriving (Read, Show) doAlt :: (Window -> HandleWindowAlt) -> X HandleWindowAlt doAlt f = do - (W.StackSet (W.Screen (W.Workspace _ _ mStack) _ _) _ _ _) - <- windowset <$> get + (W.StackSet (W.Screen (W.Workspace _ _ mStack) _ _) _ _ _) <- + windowset <$> get return $ case mStack of @@ -34,11 +30,9 @@ expandPositionAlt = doAlt expandWindowAlt shrinkPositionAlt :: X HandleWindowAlt shrinkPositionAlt = doAlt shrinkWindowAlt - instance (LayoutClass l a, Show a, Ord a, Enum a, Num a) => LayoutClass (MosaicWrap l) a where - runLayout (W.Workspace t (MosaicWrap l) (id -> Just s)) rect = do - let zs = zipStack [100..] s + let zs = zipStack [100 ..] s s' = fmap fst zs m = Map.fromList (W.integrate zs) @@ -48,18 +42,14 @@ instance (LayoutClass l a, Show a, Ord a, Enum a, Num a) => LayoutClass (MosaicW (,rect) <$> Map.lookup place m return (rects', MosaicWrap <$> maybeNewLayout) - where zipStack as (W.Stack b c d) = - let (cz, bz : dz) = splitAt (length c) as in - W.Stack (bz, b) (zip (reverse cz) c) (zip dz d) - - + let (cz, bz : dz) = splitAt (length c) as + in W.Stack (bz, b) (zip (reverse cz) c) (zip dz d) runLayout (W.Workspace t (MosaicWrap l) a) rect = do (rects, maybeNewLayout) <- runLayout (W.Workspace t l a) rect return (rects, MosaicWrap <$> maybeNewLayout) - -- By default just pass the message to the underlying layout. handleMessage (MosaicWrap l) mess = do maybeNewLayout <- handleMessage l mess diff --git a/src/Rahm/Desktop/Layout/CornerLayout.hs b/src/Rahm/Desktop/Layout/CornerLayout.hs index 7cf4421..f87d9fa 100644 --- a/src/Rahm/Desktop/Layout/CornerLayout.hs +++ b/src/Rahm/Desktop/Layout/CornerLayout.hs @@ -3,8 +3,8 @@ module Rahm.Desktop.Layout.CornerLayout where import Data.Typeable (Typeable) -import XMonad (LayoutClass(..), Rectangle(..), Resize(..), fromMessage) import qualified Rahm.Desktop.StackSet as S +import XMonad (LayoutClass (..), Rectangle (..), Resize (..), fromMessage) data Corner a = Corner Rational Rational deriving (Show, Typeable, Read) @@ -20,18 +20,20 @@ instance LayoutClass Corner a where vn = (length ws - 1) `div` 2 hn = (length ws - 1) - vn - in - case ws of + in case ws of [a] -> [(a, screen)] - [a, b] -> [ - (a, Rectangle x y w' h), - (b, Rectangle (x + fromIntegral w') y (w - w') h)] + [a, b] -> + [ (a, Rectangle x y w' h), + (b, Rectangle (x + fromIntegral w') y (w - w') h) + ] _ -> - zip ws $ map ( - \(Rectangle x' y' w h) -> Rectangle (x + x') (y + y') w h) $ - corner : - splitVert vertRect vn ++ - splitHoriz horizRect hn + zip ws $ + map + ( \(Rectangle x' y' w h) -> Rectangle (x + x') (y + y') w h + ) + $ corner : + splitVert vertRect vn + ++ splitHoriz horizRect hn pureMessage (Corner frac delta) m = fmap resize (fromMessage m) where 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' diff --git a/src/Rahm/Desktop/Layout/Flip.hs b/src/Rahm/Desktop/Layout/Flip.hs index fe425e9..5942a4a 100644 --- a/src/Rahm/Desktop/Layout/Flip.hs +++ b/src/Rahm/Desktop/Layout/Flip.hs @@ -1,27 +1,27 @@ {-# LANGUAGE DeriveAnyClass #-} -- Layout modifier to flip a layout either horizontally or vertically or both. -module Rahm.Desktop.Layout.Flip ( - Flip(..), +module Rahm.Desktop.Layout.Flip + ( Flip (..), flippable, flipVertically, flipHorizontally, - DoFlip - ) where - -import XMonad -import XMonad.Layout.LayoutModifier + DoFlip, + ) +where import Control.Arrow (second) +import Data.Default (Default (..)) import Data.List (intercalate) -import Data.Default (Default(..)) +import XMonad +import XMonad.Layout.LayoutModifier -- A flipped layout is either flipped horizontally or vertically. -data Flip a = - Flip { - horiz :: Bool - , vert :: Bool - } deriving (Eq, Show, Ord, Read) +data Flip a = Flip + { horiz :: Bool, + vert :: Bool + } + deriving (Eq, Show, Ord, Read) -- Default instance for Flip. Both are set to false. instance Default (Flip a) where @@ -31,11 +31,12 @@ instance Default (Flip a) where data DoFlip where -- Contains a function to modify Flip DoFlip :: (forall k (a :: k). Flip a -> Flip a) -> DoFlip - deriving Message + deriving (Message) -- DoFlip is a monoid. instance Semigroup DoFlip where - (<>) = mappend + (<>) = mappend + instance Monoid DoFlip where mempty = DoFlip id mappend (DoFlip a) (DoFlip b) = DoFlip (a . b) @@ -46,14 +47,13 @@ flippable = ModifiedLayout def -- Message to send a flipVertically message flipVertically :: DoFlip -flipVertically = DoFlip $ \f -> f { vert = not (vert f) } +flipVertically = DoFlip $ \f -> f {vert = not (vert f)} -- Message to send a flipHorizontally message. flipHorizontally :: DoFlip -flipHorizontally = DoFlip $ \f -> f { horiz = not (horiz f) } +flipHorizontally = DoFlip $ \f -> f {horiz = not (horiz f)} instance LayoutModifier Flip a where - -- Modifies the layout. For each rectangle returned from the underlying -- layout, flip it relative to the screen. pureModifier flip (Rectangle sx sy sw sh) stack returned = @@ -62,8 +62,8 @@ instance LayoutModifier Flip a where -- doFlip -- the composition of maybe flipping horizontally and -- vertically. doFlip = - (if horiz flip then flipHoriz else id) . - (if vert flip then flipVert else id) + (if horiz flip then flipHoriz else id) + . (if vert flip then flipVert else id) flipVert (Rectangle x y w h) = Rectangle ((sx + fromIntegral sw) - x - fromIntegral w + sx) y w h @@ -78,10 +78,15 @@ instance LayoutModifier Flip a where modifyDescription flip (description -> descr) = (++) descr $ if horiz flip || vert flip - then intercalate " and " ( - map snd $ - filter fst [ - (horiz flip, "Horizontally"), - (vert flip, "Vertically")]) - ++ " Flipped" + then + intercalate + " and " + ( map snd $ + filter + fst + [ (horiz flip, "Horizontally"), + (vert flip, "Vertically") + ] + ) + ++ " Flipped" else "" diff --git a/src/Rahm/Desktop/Layout/Hole.hs b/src/Rahm/Desktop/Layout/Hole.hs index fe48340..42bac48 100644 --- a/src/Rahm/Desktop/Layout/Hole.hs +++ b/src/Rahm/Desktop/Layout/Hole.hs @@ -1,16 +1,17 @@ -{-# LANGUAGE UndecidableInstances, DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE UndecidableInstances #-} -- Delegates to a lower layout, but leaves a hole where the next window will go. module Rahm.Desktop.Layout.Hole (hole, toggleHole) where -import XMonad import Data.Maybe (mapMaybe) - import qualified Rahm.Desktop.StackSet as W +import XMonad data Hole (l :: * -> *) (a :: *) = Hole Bool (l a) deriving instance Show (l a) => Show (Hole l a) + deriving instance Read (l a) => Read (Hole l a) hole :: l a -> Hole l a @@ -26,7 +27,7 @@ data ManageHole where instance (LayoutClass l a, Eq a, Num a) => LayoutClass (Hole l) a where runLayout (W.Workspace t (Hole enabled l) a) rect = do (rects, maybeNewLayout) <- runLayout (app (-1) $ W.Workspace t l a) rect - return (filter ((/=(-1)) . fst) rects, fmap (Hole enabled) maybeNewLayout) + return (filter ((/= (-1)) . fst) rects, fmap (Hole enabled) maybeNewLayout) where app x w | not enabled = w app x (W.Workspace t l s) = diff --git a/src/Rahm/Desktop/Layout/List.hs b/src/Rahm/Desktop/Layout/List.hs index d6ab6ba..787697e 100644 --- a/src/Rahm/Desktop/Layout/List.hs +++ b/src/Rahm/Desktop/Layout/List.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE UndecidableInstances, TypeOperators #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {- - This module provides a more powerful version of the "Choose" layout that can @@ -7,34 +8,36 @@ - The indexing uses a type-safe zipper to keep track of the currently-selected - layout. -} -module Rahm.Desktop.Layout.List ( - LayoutList, - layoutList, - LCons, - LNil, - toNextLayout, - toPreviousLayout, - toFirstLayout, - toIndexedLayout, - (|:), - nil, - layoutListLength, - layoutListLengthProxy - )where +module Rahm.Desktop.Layout.List + ( LayoutList, + layoutList, + LCons, + LNil, + toNextLayout, + toPreviousLayout, + toFirstLayout, + toIndexedLayout, + (|:), + nil, + layoutListLength, + layoutListLengthProxy, + ) +where import Control.Applicative ((<|>)) import Control.Arrow (second, (>>>)) import Control.Monad.Identity (runIdentity) -import Data.Maybe (fromMaybe, fromJust) +import Data.Maybe (fromJust, fromMaybe) import Data.Proxy import Data.Void import GHC.TypeLits -import XMonad import qualified Rahm.Desktop.StackSet as W +import XMonad -- Type-level lists. LNil is the final of the list. LCons contains a layout and a -- tail. data LNil a = LNil deriving (Read, Show) + data LCons l t a = LCons (l a) (t a) deriving (Read, Show) -- Sel - This defines a structure where either this selected, or some @@ -55,20 +58,25 @@ data LCons l t a = LCons (l a) (t a) deriving (Read, Show) -- -- Note that a type (Sel End) can only be in the Sel as End may not be -- construted (without using undefined). -data Sel l = - Sel | - (Selector l) => Skip l +data Sel l + = Sel + | (Selector l) => Skip l + deriving instance (Read l, Selector l) => Read (Sel l) + deriving instance (Show l, Selector l) => Show (Sel l) + deriving instance (Eq l, Selector l) => Eq (Sel l) -- Reimplement Void as End, just to keep the two separate, but End is for all -- intents and purposes Void. data End + deriving instance Read End + deriving instance Show End -deriving instance Eq End +deriving instance Eq End -- Types that constitute a selection. Selections can be moved to the next -- selection, moved to the previous selection, optionally there could be a @@ -118,7 +126,6 @@ instance (Selector t) => Selector (Sel t) where -- The End structure (which is equivalent to Void) is the "null" selector; the -- basecase that the Sel selector terminates at. instance Selector End where - -- Incrementing the End Selector doesn't do anything. increment = const Nothing @@ -155,9 +162,12 @@ intToSelector n = incrementCycle $ intToSelector (n - 1) data LayoutList l a where LayoutList :: (LayoutSelect l a, Selector (SelectorFor l)) => - SelectorFor l -> l a -> LayoutList l a + SelectorFor l -> + l a -> + LayoutList l a deriving instance (LayoutSelect l a) => Show (LayoutList l a) + deriving instance (LayoutSelect l a) => Read (LayoutList l a) -- Type family to get the LengthOf a ConsList. @@ -183,8 +193,10 @@ infixr 5 |: -- Constructs a LayoutList. This function enforces that the SelectorFor l -- is a 'Sel' type. Essentially this enforces that there must be at least one -- underlying layout, otherwise a LayoutList cannot be constructed. -layoutList :: (LayoutSelect l a, SelectorFor l ~ Sel n) => - l a -> LayoutList l a +layoutList :: + (LayoutSelect l a, SelectorFor l ~ Sel n) => + l a -> + LayoutList l a layoutList = LayoutList Sel -- The termination of a layout zipper. @@ -193,11 +205,11 @@ nil = LNil -- Message to navigate to a layout. newtype NavigateLayout = - -- Sets the layout based on the given function. - NavigateLayout { - changeLayoutFn :: forall c. (Selector c) => c -> c - } - deriving (Typeable) + -- Sets the layout based on the given function. + NavigateLayout + { changeLayoutFn :: forall c. (Selector c) => c -> c + } + deriving (Typeable) -- NavigateLayout instance to move to the next layout, circularly. toNextLayout :: NavigateLayout @@ -213,28 +225,34 @@ toFirstLayout = NavigateLayout (`fromMaybe` initial) -- NavigateLayout instance to go to an indexed layout. toIndexedLayout :: Int -> NavigateLayout -toIndexedLayout i = NavigateLayout $ - (`fromMaybe` initial) >>> addSelector (intToSelector i) +toIndexedLayout i = + NavigateLayout $ + (`fromMaybe` initial) >>> addSelector (intToSelector i) -instance Message NavigateLayout where +instance Message NavigateLayout -- LayoutSelect class Describes a type that can be used to select a layout using -- the associated type SelectorFor. -- -- Instances of this class are LCons and LNil. -class (Show (l a), - Read (l a), - Read (SelectorFor l), - Show (SelectorFor l), - Selector (SelectorFor l)) => LayoutSelect l a where - +class + ( Show (l a), + Read (l a), + Read (SelectorFor l), + Show (SelectorFor l), + Selector (SelectorFor l) + ) => + LayoutSelect l a + where -- The selector that is used to update the layout corresponding to the -- selector. This selector must be an instance of the Selector class. type SelectorFor l :: * -- Update applies a functor to the selected layout and maybe returns a result -- and an updated layout. - update :: forall r m. (Monad m) => + update :: + forall r m. + (Monad m) => -- The selector for this type. Determines which layout the function is -- applied to. SelectorFor l -> @@ -243,18 +261,19 @@ class (Show (l a), -- Higher-ordered function to generically apply to the Layout associated -- with the Selector. Works on all LayoutClass's. (forall l'. (LayoutClass l' a) => l' a -> m (r, Maybe (l' a))) -> - -- Returns a result r, and an updated LayoutSelect. m (Maybe (r, l a)) -- Instance for LayoutSelect for cons -instance (Read (l a), - LayoutClass l a, - LayoutSelect t a, - Show (SelectorFor t), - Read (SelectorFor t)) => - LayoutSelect (LCons l t) a where - +instance + ( Read (l a), + LayoutClass l a, + LayoutSelect t a, + Show (SelectorFor t), + Read (SelectorFor t) + ) => + LayoutSelect (LCons l t) a + where -- The SelectorFor Cons is Sel (SelectorFor t). This creates the structure -- Sel (Sel (Sel ( ... (Sel End) .. ))) where the number of Sel's match the -- number of Cons in this structure enforcing safe selection. @@ -278,19 +297,19 @@ instance LayoutSelect LNil a where -- Instance of layout class for LayoutList. The implementation for this -- just delegates to the underlying LayoutSelect class using the generic -- update method. -instance (Show (l a), Typeable l, LayoutSelect l a) => - LayoutClass (LayoutList l) a where - +instance + (Show (l a), Typeable l, LayoutSelect l a) => + LayoutClass (LayoutList l) a + where runLayout (W.Workspace i (LayoutList idx l) ms) r = do r <- update idx l $ \layout -> - runLayout (W.Workspace i layout ms) r + runLayout (W.Workspace i layout ms) r case r of Nothing -> return ([], Nothing) Just (r, la) -> return (r, Just (LayoutList idx la)) handleMessage (LayoutList idx l) (fromMessage -> Just (NavigateLayout fn)) = return $ Just (LayoutList (fn idx) l) - handleMessage (LayoutList idx l) m = do r <- update idx l $ \layout -> ((),) <$> handleMessage layout m return $ LayoutList idx . snd <$> r diff --git a/src/Rahm/Desktop/Layout/Pop.hs b/src/Rahm/Desktop/Layout/Pop.hs index a7e2762..b518ee8 100644 --- a/src/Rahm/Desktop/Layout/Pop.hs +++ b/src/Rahm/Desktop/Layout/Pop.hs @@ -4,33 +4,32 @@ -- frame in the middle of the screen, sort of like fullscreen, but only taking -- up a percentage of the screen rather than the whole screen so other windows -- are still visible, alebeit typically not usable. -module Rahm.Desktop.Layout.Pop ( - Poppable(..), - PopMessage(..), - poppable, - resizePop, - togglePop, - setPop) where - -import XMonad -import XMonad.Layout.LayoutModifier (LayoutModifier(..), ModifiedLayout(..)) -import Data.Default (Default(..)) -import qualified Rahm.Desktop.StackSet as W - +module Rahm.Desktop.Layout.Pop + ( Poppable (..), + PopMessage (..), + poppable, + resizePop, + togglePop, + setPop, + ) +where + +import Data.Default (Default (..)) import Rahm.Desktop.Layout.ReinterpretMessage +import qualified Rahm.Desktop.StackSet as W +import XMonad +import XMonad.Layout.LayoutModifier (LayoutModifier (..), ModifiedLayout (..)) -data Poppable (l :: * -> *) (a :: *) = Poppable { - -- True if the current window is popped out or not. - isPopped :: Bool - +data Poppable (l :: * -> *) (a :: *) = Poppable + { -- True if the current window is popped out or not. + isPopped :: Bool, -- Fraction of the screen width around the window. - , xFrac :: Float - + xFrac :: Float, -- Fraction of the screen height around the window. - , yFrac :: Float - - , wrap :: l a - } deriving (Show, Read, Eq, Ord) + yFrac :: Float, + wrap :: l a + } + deriving (Show, Read, Eq, Ord) data PopMessage where PopMessage :: (forall l a. Poppable l a -> Poppable l a) -> PopMessage @@ -52,27 +51,30 @@ poppable :: l a -> Poppable l a poppable = Poppable False 0.05 0.05 instance (LayoutClass l a, Eq a) => LayoutClass (Poppable l) a where - -- If the current layout is not popped, then just return what the underlying -- layout returned. - runLayout (W.Workspace - t - (Poppable True xs ys l) - a@(Just (W.focus -> focused))) - rect@(Rectangle x y w h) = do - (returned, maybeNewLayout) <- runLayout (W.Workspace t l a) rect - return - ((focused, newRect) : filter ((/=focused) . fst) returned, - Poppable True xs ys <$> maybeNewLayout) - where - wp = floor $ fromIntegral w * xs - hp = floor $ fromIntegral h * ys - newRect = Rectangle - (x + wp) - (y + hp) - (w - fromIntegral (wp * 2)) - (h - fromIntegral (hp * 2)) + runLayout + ( W.Workspace + t + (Poppable True xs ys l) + a@(Just (W.focus -> focused)) + ) + rect@(Rectangle x y w h) = do + (returned, maybeNewLayout) <- runLayout (W.Workspace t l a) rect + return + ( (focused, newRect) : filter ((/= focused) . fst) returned, + Poppable True xs ys <$> maybeNewLayout + ) + where + wp = floor $ fromIntegral w * xs + hp = floor $ fromIntegral h * ys + newRect = + Rectangle + (x + wp) + (y + hp) + (w - fromIntegral (wp * 2)) + (h - fromIntegral (hp * 2)) -- If the pop is not active, just delegate to the underlying layout. runLayout (W.Workspace t (Poppable b x y l) a) rect = do @@ -82,14 +84,12 @@ instance (LayoutClass l a, Eq a) => LayoutClass (Poppable l) a where -- If the message is a PopMessage, handle that here. handleMessage p (fromMessage -> Just (PopMessage f)) = return $ Just $ f p - -- Intercept Shrink/Expand message if the pop is active, and resize the -- pop size. handleMessage p (fromMessage -> Just mess) | isPopped p = case mess of Shrink -> handleMessage p (SomeMessage $ resizePop 0.025) Expand -> handleMessage p (SomeMessage $ resizePop (-0.025)) - -- By default just pass the message to the underlying layout. handleMessage (Poppable b x y l) mess = do maybeNewLayout <- handleMessage l mess diff --git a/src/Rahm/Desktop/Layout/Redescribe.hs b/src/Rahm/Desktop/Layout/Redescribe.hs index 7f955d8..f5e51b7 100644 --- a/src/Rahm/Desktop/Layout/Redescribe.hs +++ b/src/Rahm/Desktop/Layout/Redescribe.hs @@ -1,17 +1,14 @@ - -- Module to enable redescribing layouts. Unlike LayoutModifiers though, this -- class is aware of the underlying type as it may need to access some internals -- to generate the new description. module Rahm.Desktop.Layout.Redescribe where -import XMonad - -import qualified Rahm.Desktop.StackSet as W import Data.Typeable (Typeable) +import qualified Rahm.Desktop.StackSet as W +import XMonad -- Type-class to modify the description of a layout. class Describer m l where - -- Returns the new description from the given description modifier, the layout -- and the existing description. newDescription :: m -> l a -> String -> String @@ -21,9 +18,10 @@ data Redescribe m l a = Redescribe m (l a) deriving (Show, Read) -- Delegates to the underlying Layout, except for the description -instance (Typeable m, Show m, Describer m l, LayoutClass l a) => - LayoutClass (Redescribe m l) a where - +instance + (Typeable m, Show m, Describer m l, LayoutClass l a) => + LayoutClass (Redescribe m l) a + where runLayout (W.Workspace t (Redescribe m l) a) rect = do (rects, maybeNewLayout) <- runLayout (W.Workspace t l a) rect return (rects, fmap (Redescribe m) maybeNewLayout) diff --git a/src/Rahm/Desktop/Layout/ReinterpretMessage.hs b/src/Rahm/Desktop/Layout/ReinterpretMessage.hs index e3434b1..fc3c447 100644 --- a/src/Rahm/Desktop/Layout/ReinterpretMessage.hs +++ b/src/Rahm/Desktop/Layout/ReinterpretMessage.hs @@ -1,8 +1,8 @@ module Rahm.Desktop.Layout.ReinterpretMessage where -import XMonad (SomeMessage, X) -import XMonad.Layout.LayoutModifier (LayoutModifier(..)) import Data.Proxy (Proxy (..)) +import XMonad (SomeMessage, X) +import XMonad.Layout.LayoutModifier (LayoutModifier (..)) -- This is a type class that defines how to reinterpret a message. One can think -- of this as a kind of type-level function. It lets one associate a function @@ -30,11 +30,11 @@ data ReinterpretMessage k a = ReinterpretMessage deriving (Show, Read) -- Instance for ReinterpretMessage as a Layout modifier. -instance (DoReinterpret k) => - LayoutModifier (ReinterpretMessage k) a where - +instance + (DoReinterpret k) => + LayoutModifier (ReinterpretMessage k) a + where handleMessOrMaybeModifyIt self message = do - -- Delegates to the reinterpretMessage function associated with the -- type-variable k. newMessage <- reinterpretMessage (ofProxy self) message diff --git a/src/Rahm/Desktop/Layout/Rotate.hs b/src/Rahm/Desktop/Layout/Rotate.hs index 8a8583a..e6f9a64 100644 --- a/src/Rahm/Desktop/Layout/Rotate.hs +++ b/src/Rahm/Desktop/Layout/Rotate.hs @@ -3,15 +3,17 @@ -- Layout modifier which optionally rotates the underlying layout. This actually -- uses the mirrorRect, so it's not strictly rotating, but when combined with -- flipping it works. -module Rahm.Desktop.Layout.Rotate ( - rotateable, - rotateLayout, - Rotate) where +module Rahm.Desktop.Layout.Rotate + ( rotateable, + rotateLayout, + Rotate, + ) +where +import Control.Arrow (second) +import Data.Default (Default (..)) import XMonad import XMonad.Layout.LayoutModifier -import Data.Default (Default(..)) -import Control.Arrow (second) -- Just a wrapper over a Bool. newtype Rotate a = Rotate Bool @@ -44,19 +46,19 @@ instance (Eq a) => LayoutModifier Rotate a where unzero (Rectangle x y w h) = Rectangle (x + x') (y + y') w h scaleRect (Rectangle x y w h) = - Rectangle (x * fi sw `div` fi sh) - (y * fi sh `div` fi sw) - (w * sw `div` sh) - (h * sh `div` sw) + Rectangle + (x * fi sw `div` fi sh) + (y * fi sh `div` fi sw) + (w * sw `div` sh) + (h * sh `div` sw) fi = fromIntegral - pureMess r (fromMessage -> Just (RotateMessage f)) = Just (f r) pureMess _ _ = Nothing modifyDescription (Rotate rot) underlying = - let descr = description underlying in - if rot - then descr ++ " Rotated" - else descr + let descr = description underlying + in if rot + then descr ++ " Rotated" + else descr |