diff options
| -rw-r--r-- | XMonad/Layout.hs | 162 |
1 files changed, 85 insertions, 77 deletions
diff --git a/XMonad/Layout.hs b/XMonad/Layout.hs index 5296b19..fab7db2 100644 --- a/XMonad/Layout.hs +++ b/XMonad/Layout.hs @@ -32,64 +32,8 @@ import Control.Arrow ((***), second) import Control.Monad import Data.Maybe (fromMaybe) - ------------------------------------------------------------------------ --- LayoutClass selection manager - --- | A layout that allows users to switch between various layout options. - --- | Messages to change the current layout. -data ChangeLayout = FirstLayout | NextLayout deriving (Eq, Show, Typeable) - -instance Message ChangeLayout - --- | The layout choice combinator -(|||) :: (LayoutClass l a, LayoutClass r a) => l a -> r a -> Choose l r a -(|||) = flip SLeft -infixr 5 ||| - -data Choose l r a = SLeft (r a) (l a) - | SRight (l a) (r a) deriving (Read, Show) - -data NextNoWrap = NextNoWrap deriving (Eq, Show, Typeable) -instance Message NextNoWrap - --- This has lots of pseudo duplicated code, we must find a better way -instance (LayoutClass l a, LayoutClass r a) => LayoutClass (Choose l r) a where - runLayout (W.Workspace i (SLeft r l) ms) = fmap (second . fmap $ SLeft r) . runLayout (W.Workspace i l ms) - runLayout (W.Workspace i (SRight l r) ms) = fmap (second . fmap $ SRight l) . runLayout (W.Workspace i r ms) - - description (SLeft _ l) = description l - description (SRight _ r) = description r - - handleMessage lr m | Just FirstLayout <- fromMessage m = case lr of - SLeft {} -> return Nothing - SRight l r -> fmap (Just . flip SLeft l . fromMaybe r) - $ handleMessage r (SomeMessage Hide) - - handleMessage lr m | Just NextLayout <- fromMessage m = do - mlr <- handleMessage lr $ SomeMessage NextNoWrap - maybe (handleMessage lr $ SomeMessage FirstLayout) (return . Just) mlr - - handleMessage (SLeft r l) m | Just NextNoWrap <- fromMessage m = do - handleMessage l (SomeMessage Hide) - mr <- handleMessage r (SomeMessage FirstLayout) - return . Just . SRight l $ fromMaybe r mr - - handleMessage lr m | Just ReleaseResources <- fromMessage m = - liftM2 ((Just .) . cons) - (fmap (fromMaybe l) $ handleMessage l m) - (fmap (fromMaybe r) $ handleMessage r m) - where (cons, l, r) = case lr of - (SLeft r' l') -> (flip SLeft, l', r') - (SRight l' r') -> (SRight, l', r') - - -- The default cases for left and right: - handleMessage (SLeft r l) m = fmap (fmap $ SLeft r) $ handleMessage l m - handleMessage (SRight l r) m = fmap (fmap $ SRight l) $ handleMessage r m - --- --- | Builtin layout algorithms: +-- | Builtin basic layout algorithms: -- -- > fullscreen mode -- > tall mode @@ -112,35 +56,25 @@ data Full a = Full deriving (Show, Read) instance LayoutClass Full a --- | The inbuilt tiling mode of xmonad, and its operations. +-- | The builtin tiling mode of xmonad, and its operations. data Tall a = Tall Int Rational Rational deriving (Show, Read) + -- TODO should be capped [0..1] .. +-- a nice pure layout, lots of properties for the layout, and its messages, in Properties.hs instance LayoutClass Tall a where pureLayout (Tall nmaster _ frac) r s = zip ws rs where ws = W.integrate s rs = tile frac r nmaster (length ws) - pureMessage (Tall nmaster delta frac) m = msum [fmap resize (fromMessage m) - ,fmap incmastern (fromMessage m)] - where resize Shrink = Tall nmaster delta (max 0 $ frac-delta) - resize Expand = Tall nmaster delta (min 1 $ frac+delta) - incmastern (IncMasterN d) = Tall (max 0 (nmaster+d)) delta frac - description _ = "Tall" + pureMessage (Tall nmaster delta frac) m = + msum [fmap resize (fromMessage m) + ,fmap incmastern (fromMessage m)] --- | Mirror a rectangle -mirrorRect :: Rectangle -> Rectangle -mirrorRect (Rectangle rx ry rw rh) = (Rectangle ry rx rh rw) - --- | Mirror a layout, compute its 90 degree rotated form. -data Mirror l a = Mirror (l a) deriving (Show, Read) + where resize Shrink = Tall nmaster delta (max 0 $ frac-delta) + resize Expand = Tall nmaster delta (min 1 $ frac+delta) + incmastern (IncMasterN d) = Tall (max 0 (nmaster+d)) delta frac -instance LayoutClass l a => LayoutClass (Mirror l) a where - runLayout (W.Workspace i (Mirror l) ms) r = (map (second mirrorRect) *** fmap Mirror) - `fmap` runLayout (W.Workspace i l ms) (mirrorRect r) - handleMessage (Mirror l) = fmap (fmap Mirror) . handleMessage l - description (Mirror l) = "Mirror "++ description l - ------------------------------------------------------------------------- + description _ = "Tall" -- | tile. Compute the positions for windows using the default 2 pane tiling algorithm. -- @@ -170,6 +104,7 @@ splitVertically n (Rectangle sx sy sw sh) = Rectangle sx sy sw smallh : splitVertically (n-1) (Rectangle sx (sy+fromIntegral smallh) sw (sh-smallh)) where smallh = sh `div` fromIntegral n --hmm, this is a fold or map. +-- Not used in the core, but exported splitHorizontally n = map mirrorRect . splitVertically n . mirrorRect -- Divide the screen into two rectangles, using a rational to specify the ratio @@ -179,4 +114,77 @@ splitHorizontallyBy f (Rectangle sx sy sw sh) = , Rectangle (sx + fromIntegral leftw) sy (sw-fromIntegral leftw) sh) where leftw = floor $ fromIntegral sw * f +-- Not used in the core, but exported splitVerticallyBy f = (mirrorRect *** mirrorRect) . splitHorizontallyBy f . mirrorRect + +------------------------------------------------------------------------ +-- | Mirror a layout, compute its 90 degree rotated form. + +-- | Mirror a layout, compute its 90 degree rotated form. +data Mirror l a = Mirror (l a) deriving (Show, Read) + +instance LayoutClass l a => LayoutClass (Mirror l) a where + runLayout (W.Workspace i (Mirror l) ms) r = (map (second mirrorRect) *** fmap Mirror) + `fmap` runLayout (W.Workspace i l ms) (mirrorRect r) + handleMessage (Mirror l) = fmap (fmap Mirror) . handleMessage l + description (Mirror l) = "Mirror "++ description l + +-- | Mirror a rectangle +mirrorRect :: Rectangle -> Rectangle +mirrorRect (Rectangle rx ry rw rh) = (Rectangle ry rx rh rw) + +------------------------------------------------------------------------ +-- LayoutClass selection manager +-- Layouts that transition between other layouts + +-- | A layout that allows users to switch between various layout options. + +-- | Messages to change the current layout. +data ChangeLayout = FirstLayout | NextLayout deriving (Eq, Show, Typeable) + +instance Message ChangeLayout + +-- | The layout choice combinator +(|||) :: (LayoutClass l a, LayoutClass r a) => l a -> r a -> Choose l r a +(|||) = flip SLeft +infixr 5 ||| + +data Choose l r a = SLeft (r a) (l a) + | SRight (l a) (r a) deriving (Read, Show) + +data NextNoWrap = NextNoWrap deriving (Eq, Show, Typeable) +instance Message NextNoWrap + +-- This has lots of pseudo duplicated code, we must find a better way +instance (LayoutClass l a, LayoutClass r a) => LayoutClass (Choose l r) a where + runLayout (W.Workspace i (SLeft r l) ms) = fmap (second . fmap $ SLeft r) . runLayout (W.Workspace i l ms) + runLayout (W.Workspace i (SRight l r) ms) = fmap (second . fmap $ SRight l) . runLayout (W.Workspace i r ms) + + description (SLeft _ l) = description l + description (SRight _ r) = description r + + handleMessage lr m | Just FirstLayout <- fromMessage m = case lr of + SLeft {} -> return Nothing + SRight l r -> fmap (Just . flip SLeft l . fromMaybe r) + $ handleMessage r (SomeMessage Hide) + + handleMessage lr m | Just NextLayout <- fromMessage m = do + mlr <- handleMessage lr $ SomeMessage NextNoWrap + maybe (handleMessage lr $ SomeMessage FirstLayout) (return . Just) mlr + + handleMessage (SLeft r l) m | Just NextNoWrap <- fromMessage m = do + handleMessage l (SomeMessage Hide) + mr <- handleMessage r (SomeMessage FirstLayout) + return . Just . SRight l $ fromMaybe r mr + + handleMessage lr m | Just ReleaseResources <- fromMessage m = + liftM2 ((Just .) . cons) + (fmap (fromMaybe l) $ handleMessage l m) + (fmap (fromMaybe r) $ handleMessage r m) + where (cons, l, r) = case lr of + (SLeft r' l') -> (flip SLeft, l', r') + (SRight l' r') -> (SRight, l', r') + + -- The default cases for left and right: + handleMessage (SLeft r l) m = fmap (fmap $ SLeft r) $ handleMessage l m + handleMessage (SRight l r) m = fmap (fmap $ SRight l) $ handleMessage r m |