Add a LayoutCombinator class and a CombinedLayout and port PerWorkspace to the new system

darcs-hash:20080129192903-32816-de07daf3f32a823c1f3a0e593ff6229b78ae0494.gz

2 files changed, 109 insertions, 93 deletions

diff --git a/XMonad/Layout/LayoutCombinators.hs b/XMonad/Layout/LayoutCombinators.hs
index c4e36f3..ad3cba8 100644
--- a/XMonad/Layout/LayoutCombinators.hs
+++ b/XMonad/Layout/LayoutCombinators.hs
@@ -13,37 +13,40 @@
 -- A module for combining other layouts.
 -----------------------------------------------------------------------------
 
-module XMonad.Layout.LayoutCombinators (
-    -- * Usage
-    -- $usage
-
-    -- * Combinators using DragPane vertical
-    -- $dpv
-    (*||*), (**||*),(***||*),(****||*),(***||**),(****||***),
-    (***||****),(*||****),(**||***),(*||***),(*||**),
-
-    -- * Combinators using DragPane horizontal
-    -- $dph
-    (*//*), (**//*),(***//*),(****//*),(***//**),(****//***),
-    (***//****),(*//****),(**//***),(*//***),(*//**),
-
-    -- * Combinators using Tall (vertical)
-    -- $tv
-    (*|*), (**|*),(***|*),(****|*),(***|**),(****|***),
-    (***|****),(*|****),(**|***),(*|***),(*|**),
-
-    -- * Combinators using Mirror Tall (horizontal)
-    -- $mth
-    (*/*), (**/*),(***/*),(****/*),(***/**),(****/***),
-    (***/****),(*/****),(**/***),(*/***),(*/**),
-
-    -- * A new combinator
-    -- $nc
-    (|||),
-    JumpToLayout(JumpToLayout)
+module XMonad.Layout.LayoutCombinators
+    ( -- * Usage
+      -- $usage
+
+      -- * Combinators using DragPane vertical
+      -- $dpv
+      (*||*), (**||*),(***||*),(****||*),(***||**),(****||***)
+    , (***||****),(*||****),(**||***),(*||***),(*||**)
+
+      -- * Combinators using DragPane horizontal
+      -- $dph
+    , (*//*), (**//*),(***//*),(****//*),(***//**),(****//***)
+    , (***//****),(*//****),(**//***),(*//***),(*//**)
+
+      -- * Combinators using Tall (vertical)
+      -- $tv
+    , (*|*), (**|*),(***|*),(****|*),(***|**),(****|***)
+    , (***|****),(*|****),(**|***),(*|***),(*|**)
+
+      -- * Combinators using Mirror Tall (horizontal)
+      -- $mth
+    , (*/*), (**/*),(***/*),(****/*),(***/**),(****/***)
+    , (***/****),(*/****),(**/***),(*/***),(*/**)
+
+      -- * A new combinator
+      -- $nc
+    , (|||)
+    , JumpToLayout(JumpToLayout)
+    , LayoutCombinator (..)
+    , CombinedLayout (..)
+    , ComboType (..)
     ) where
 
-import Data.Maybe ( isJust, isNothing )
+import Data.Maybe ( fromMaybe, isJust, isNothing )
 
 import XMonad hiding ((|||))
 import XMonad.Layout.Combo
@@ -218,3 +221,66 @@ passOnM m (NewSelect False lt lf) = do mlf' <- handleMessage lf m
 when' :: Monad m => (a -> Bool) -> m a -> m a -> m a
 when' f a b = do a1 <- a; if f a1 then b else return a1
 
+
+data ComboType = DoFirst | DoSecond | DoBoth deriving ( Eq, Show )
+
+class (Read (lc a), Show (lc a)) => LayoutCombinator lc a where
+    chooser :: lc a -> X ComboType
+    chooser lc = return $ pureChooser lc 
+    pureChooser :: lc a -> ComboType
+    pureChooser _ =  DoFirst
+--    doFirst lc = if (chooser lc) == DoSecond then False else True
+    doFirst :: lc a -> Bool
+    combineResult :: lc a -> [(a,Rectangle)] -> [(a,Rectangle)] -> [(a,Rectangle)]
+    combineResult _ wrs1 wrs2 = wrs1 ++ wrs2
+    comboHandleMess :: (LayoutClass l1 a, LayoutClass l2 a) => lc a -> l1 a -> l2 a -> SomeMessage -> X (lc a)
+    comboHandleMess lc l1 l2 m = return $ pureComboHandleMess lc l1 l2 m
+    pureComboHandleMess :: (LayoutClass l1 a, LayoutClass l2 a) => lc a -> l1 a -> l2 a -> SomeMessage -> lc a
+    pureComboHandleMess lc _ _ _ = lc
+    sendToOther :: (LayoutClass l a) => lc a -> l a -> SomeMessage
+    sendToOther _ _ = SomeMessage Hide
+    comboName :: lc a -> String
+    comboName = show
+    comboDescription :: (LayoutClass l1 a, LayoutClass l2 a) => lc a -> l1 a -> l2 a -> String
+    comboDescription lc l1 l2 = show lc <> if doFirst lc then description l1 else description l2
+        where "" <> x = x
+              x  <> y = x ++ " " ++ y
+
+data CombinedLayout lc l1 l2 a = CombinedLayout (lc a) (l1 a) (l2 a) deriving ( Show,  Read )
+
+instance (LayoutClass l1 a, LayoutClass l2 a, LayoutCombinator lc a) => LayoutClass (CombinedLayout lc l1 l2) a where
+    doLayout (CombinedLayout lc l1 l2) r s = do
+        choose <- chooser lc
+        case choose of
+          DoSecond -> do (wrs, nl2)  <- doLayout l2 r s
+                         return (wrs, Just $ CombinedLayout lc l1 (fromMaybe l2 nl2))
+          DoBoth   -> do (wrs1, nl1) <- doLayout l1 r s
+                         (wrs2, nl2) <- doLayout l2 r s
+                         return (combineResult lc wrs1 wrs2  , Just $ CombinedLayout lc (fromMaybe l1 nl1) (fromMaybe l2 nl2))
+          _        -> do (wrs, nl1)  <- doLayout l1 r s
+                         return (wrs, Just $ CombinedLayout lc (fromMaybe l1 nl1) l2)
+    emptyLayout (CombinedLayout lc l1 l2) r = do 
+        choose <- chooser lc
+        case choose of
+          DoSecond -> do (wrs, nl2)  <- emptyLayout l2 r
+                         return (wrs, Just $ CombinedLayout lc l1 (fromMaybe l2 nl2))
+          DoBoth   -> do (wrs1, nl1) <- emptyLayout l1 r
+                         (wrs2, nl2) <- emptyLayout l2 r
+                         return (combineResult lc wrs1 wrs2  , Just $ CombinedLayout lc (fromMaybe l1 nl1) (fromMaybe l2 nl2))
+          _        -> do (wrs, nl1)  <- emptyLayout l1 r
+                         return (wrs, Just $ CombinedLayout lc (fromMaybe l1 nl1) l2)
+    handleMessage (CombinedLayout lc l1 l2) m = do
+      nc <- comboHandleMess lc l1 l2 m
+      choose <- chooser nc
+      case choose of
+        DoFirst ->  do nl1 <- handleMessage l1 m
+                       nl2 <- handleMessage l2 (sendToOther nc l2)
+                       return $ Just $ CombinedLayout nc (fromMaybe l1 nl1) (fromMaybe l2 nl2)
+        DoSecond -> do nl1 <- handleMessage l1 (sendToOther nc l1)
+                       nl2 <- handleMessage l2 m
+                       return $ Just $ CombinedLayout nc (fromMaybe l1 nl1) (fromMaybe l2 nl2)
+        DoBoth ->   do nl1 <- handleMessage l1 m
+                       nl2 <- handleMessage l2 m
+                       return $ Just $ CombinedLayout nc (fromMaybe l1 nl1) (fromMaybe l2 nl2)
+
+    description (CombinedLayout lc l1 l2) = comboDescription lc l1 l2
diff --git a/XMonad/Layout/PerWorkspace.hs b/XMonad/Layout/PerWorkspace.hs
index bc51a96..448e3ab 100644
--- a/XMonad/Layout/PerWorkspace.hs
+++ b/XMonad/Layout/PerWorkspace.hs
@@ -31,8 +31,7 @@ module XMonad.Layout.PerWorkspace (
 import XMonad
 import qualified XMonad.StackSet as W
 
-import Data.Maybe (fromMaybe)
-
+import XMonad.Layout.LayoutCombinators
 -- $usage
 -- You can use this module by importing it into your ~\/.xmonad\/xmonad.hs file:
 --
@@ -59,21 +58,19 @@ import Data.Maybe (fromMaybe)
 -- | Specify one layout to use on a particular workspace, and another
 --   to use on all others.  The second layout can be another call to
 --   'onWorkspace', and so on.
-onWorkspace :: (LayoutClass l1 a, LayoutClass l2 a)
-               => WorkspaceId -- ^ the tag of the workspace to match
-               -> (l1 a)      -- ^ layout to use on the matched workspace
-               -> (l2 a)      -- ^ layout to use everywhere else
-               -> PerWorkspace l1 l2 a
-onWorkspace wsId l1 l2 = PerWorkspace [wsId] Nothing l1 l2
+onWorkspace :: WorkspaceId  -- ^ tags of workspaces to match
+                -> (l1 a)         -- ^ layout to use on matched workspaces
+                -> (l2 a)         -- ^ layout to use everywhere else
+                -> CombinedLayout PerWorkspace l1 l2 a
+onWorkspace wsId l1 l2 = CombinedLayout (PerWorkspace [wsId]) l1 l2
 
 -- | Specify one layout to use on a particular set of workspaces, and
 --   another to use on all other workspaces.
-onWorkspaces :: (LayoutClass l1 a, LayoutClass l2 a)
-                => [WorkspaceId]  -- ^ tags of workspaces to match
+onWorkspaces :: [WorkspaceId]  -- ^ tags of workspaces to match
                 -> (l1 a)         -- ^ layout to use on matched workspaces
                 -> (l2 a)         -- ^ layout to use everywhere else
-                -> PerWorkspace l1 l2 a
-onWorkspaces wsIds l1 l2 = PerWorkspace wsIds Nothing l1 l2
+                -> CombinedLayout PerWorkspace l1 l2 a
+onWorkspaces wsIds l1 l2 = CombinedLayout (PerWorkspace wsIds) l1 l2
 
 -- | Structure for representing a workspace-specific layout along with
 --   a layout for all other workspaces.  We store the tags of workspaces
@@ -83,60 +80,13 @@ onWorkspaces wsIds l1 l2 = PerWorkspace wsIds Nothing l1 l2
 --   to be able to correctly implement the 'description' method of
 --   LayoutClass, since a call to description is not able to query the
 --   WM state to find out which workspace it was called in.
-data PerWorkspace l1 l2 a = PerWorkspace [WorkspaceId]
-                                         (Maybe Bool)
-                                         (l1 a)
-                                         (l2 a)
-    deriving (Read, Show)
-
-instance (LayoutClass l1 a, LayoutClass l2 a) => LayoutClass (PerWorkspace l1 l2) a where
+data PerWorkspace a = PerWorkspace [WorkspaceId] deriving (Read, Show)
 
-    -- do layout with l1, then return a modified PerWorkspace caching
-    --   the fact that we're in the matched workspace.
-    doLayout p@(PerWorkspace _ (Just True) lt _) r s = do
-        (wrs, mlt') <- doLayout lt r s
-        return (wrs, Just $ mkNewPerWorkspaceT p mlt')
-
-    -- do layout with l1, then return a modified PerWorkspace caching
-    --   the fact that we're not in the matched workspace.
-    doLayout p@(PerWorkspace _ (Just False) _ lf) r s = do
-        (wrs, mlf') <- doLayout lf r s
-        return (wrs, Just $ mkNewPerWorkspaceF p mlf')
-
-    -- figure out which layout to use based on the current workspace.
-    doLayout (PerWorkspace wsIds Nothing l1 l2) r s = do
+instance LayoutCombinator PerWorkspace a where
+    chooser (PerWorkspace wsIds) = do
         t <- getCurrentTag
-        doLayout (PerWorkspace wsIds (Just $ t `elem` wsIds) l1 l2) r s
-
-    -- handle messages; same drill as doLayout.
-    handleMessage p@(PerWorkspace _ (Just True) lt _) m = do
-        mlt' <- handleMessage lt m
-        return . Just $ mkNewPerWorkspaceT p mlt'
-
-    handleMessage p@(PerWorkspace _ (Just False) _ lf) m = do
-        mlf' <- handleMessage lf m
-        return . Just $ mkNewPerWorkspaceF p mlf'
-
-    handleMessage (PerWorkspace _ Nothing _ _) _ = return Nothing
-
-    description (PerWorkspace _ (Just True ) l1 _) = description l1
-    description (PerWorkspace _ (Just False) _ l2) = description l2
-
-    -- description's result is not in the X monad, so we have to wait
-    -- until a doLayout for the information about which workspace
-    -- we're in to get cached.
-    description _ = "PerWorkspace"
-
--- | Construct new PerWorkspace values with possibly modified layouts.
-mkNewPerWorkspaceT :: PerWorkspace l1 l2 a -> Maybe (l1 a) ->
-                      PerWorkspace l1 l2 a
-mkNewPerWorkspaceT (PerWorkspace wsIds b lt lf) mlt' =
-    (\lt' -> PerWorkspace wsIds b lt' lf) $ fromMaybe lt mlt'
-
-mkNewPerWorkspaceF :: PerWorkspace l1 l2 a -> Maybe (l2 a) ->
-                      PerWorkspace l1 l2 a
-mkNewPerWorkspaceF (PerWorkspace wsIds b lt lf) mlf' =
-    (\lf' -> PerWorkspace wsIds b lt lf') $ fromMaybe lf mlf'
+        return $ if t `elem` wsIds then DoFirst else DoSecond
+    doFirst (PerWorkspace _) = True
 
 -- | Get the tag of the currently active workspace.  Note that this
 --   is only guaranteed to be the same workspace for which doLayout