From 27bab2df6fe1195afacc7e7fc6231d3fc684ac77 Mon Sep 17 00:00:00 2001
From: David Roundy <droundy@darcs.net>
Date: Wed, 24 Oct 2007 17:26:48 +0200
Subject: add NewSelect layout combinator.

This patch adds a selection layout combinator ||| which
replaces Select, and makes the Layout data type unnecessary.
This combinator isn't yet feature-complete, as I didn't implement
backwards rotation (PrevLayout), but that's obviously doable.  This
patch requires the descriptions function be added to LayoutClass in
core.

darcs-hash:20071024152648-72aca-4ca84d747697ceee68e33f0afed95821d4b90229.gz
---
 LayoutCombinators.hs | 80 ++++++++++++++++++++++++++++++++++++++++++++++++++--
 1 file changed, 78 insertions(+), 2 deletions(-)

(limited to 'LayoutCombinators.hs')

diff --git a/LayoutCombinators.hs b/LayoutCombinators.hs
index c7e065d..19271f7 100644
--- a/LayoutCombinators.hs
+++ b/LayoutCombinators.hs
@@ -17,11 +17,14 @@
 module XMonadContrib.LayoutCombinators (
     -- * Usage
     -- $usage
-    (<|>), (</>), (<||>), (<//>)
+    (<|>), (</>), (<||>), (<//>), (|||)
     ) where
 
+import Data.Maybe ( isJust )
+
 import XMonad
-import Operations ( Tall(..), Mirror(..) )
+import Operations ( Tall(..), Mirror(..),
+                    ChangeLayout(NextLayout,JumpToLayout), LayoutMessages(..) )
 import XMonadContrib.Combo
 import XMonadContrib.DragPane
 
@@ -39,3 +42,76 @@ import XMonadContrib.DragPane
 (<//>) = combineTwo (dragPane Horizontal 0.1 0.5)
 (<|>) = combineTwo (Tall 1 0.1 0.5)
 (</>) = combineTwo (Mirror $ Tall 1 0.1 0.5)
+
+(|||) :: (LayoutClass l1 a, LayoutClass l2 a) => l1 a -> l2 a -> NewSelect l1 l2 a
+(|||) = NewSelect True
+
+data NewSelect l1 l2 a = NewSelect Bool (l1 a) (l2 a) deriving ( Read, Show )
+
+data NoWrap = NextLayoutNoWrap | Wrap deriving ( Read, Show, Typeable )
+instance Message NoWrap
+
+instance (LayoutClass l1 a, LayoutClass l2 a) => LayoutClass (NewSelect l1 l2) a where
+    doLayout (NewSelect True l1 l2) r s = do (wrs, ml1') <- doLayout l1 r s
+                                             return (wrs, (\l1' -> NewSelect True l1' l2) `fmap` ml1')
+    doLayout (NewSelect False l1 l2) r s = do (wrs, ml2') <- doLayout l2 r s
+                                              return (wrs, (\l2' -> NewSelect False l1 l2') `fmap` ml2')
+    description (NewSelect True l1 _) = description l1
+    description (NewSelect False _ l2) = description l2
+    descriptions (NewSelect _ l1 l2) = descriptions l1 ++ descriptions l2
+    handleMessage (NewSelect False l1 l2) m
+        | Just Wrap <- fromMessage m =
+                       do ml2' <- handleMessage l2 (SomeMessage Hide)
+                          ml1' <- handleMessage l1 m
+                          return $ Just $ NewSelect True (maybe l1 id ml1') (maybe l2 id ml2')
+    handleMessage (NewSelect True l1 l2) m
+        | Just NextLayoutNoWrap <- fromMessage m =
+                 do ml1' <- handleMessage l1 m
+                    case ml1' of
+                      Just l1' -> return $ Just (NewSelect True l1' l2)
+                      Nothing -> do ml1'' <- handleMessage l1 (SomeMessage Hide)
+                                    ml2' <- handleMessage l2 (SomeMessage Wrap)
+                                    return $ Just $ NewSelect False (maybe l1 id ml1'') (maybe l2 id ml2')
+    handleMessage l@(NewSelect True _ _) m
+        | Just NextLayout <- fromMessage m = handleMessage l (SomeMessage NextLayoutNoWrap)
+    handleMessage l@(NewSelect False l1 l2) m
+        | Just NextLayout <- fromMessage m =
+                 do ml' <- handleMessage l (SomeMessage NextLayoutNoWrap)
+                    case ml' of
+                      Just l' -> return $ Just l'
+                      Nothing -> do ml2' <- handleMessage l2 (SomeMessage Hide)
+                                    ml1' <- handleMessage l1 (SomeMessage Wrap)
+                                    return $ Just $ NewSelect True (maybe l1 id ml1') (maybe l2 id ml2')
+    handleMessage (NewSelect True l1 l2) m
+        | Just (JumpToLayout d) <- fromMessage m =
+                 if d `elem` descriptions l2
+                 then do ml1' <- handleMessage l1 (SomeMessage Hide)
+                         ml2' <- handleMessage l2 m
+                         return $ Just $ NewSelect False (maybe l1 id ml1') (maybe l2 id ml2')
+                 else if d `elem` descriptions l1
+                      then do ml1' <- handleMessage l1 m
+                              return $ (\l1' -> NewSelect True l1' l2) `fmap` ml1'
+                      else return Nothing
+    handleMessage (NewSelect False l1 l2) m
+        | Just (JumpToLayout d) <- fromMessage m =
+                 if d `elem` descriptions l1
+                 then do ml2' <- handleMessage l2 (SomeMessage Hide)
+                         ml1' <- handleMessage l1 m
+                         return $ Just $ NewSelect False (maybe l1 id ml1') (maybe l2 id ml2')
+                 else if d `elem` descriptions l2
+                      then do ml2' <- handleMessage l2 m
+                              return $ (\l2' -> NewSelect True l1 l2') `fmap` ml2'
+                      else return Nothing
+    handleMessage (NewSelect b l1 l2) m
+        | Just ReleaseResources  <- fromMessage m =
+        do ml1' <- handleMessage l1 m
+           ml2' <- handleMessage l2 m
+           return $ if isJust ml1' || isJust ml2'
+                    then Just $ NewSelect b (maybe l1 id ml1') (maybe l2 id ml2')
+                    else Nothing
+    handleMessage (NewSelect True l1 l2) m =
+        do ml1' <- handleMessage l1 m
+           return $ (\l1' -> NewSelect True l1' l2) `fmap` ml1'
+    handleMessage (NewSelect False l1 l2) m =
+        do ml2' <- handleMessage l2 m
+           return $ (\l2' -> NewSelect False l1 l2') `fmap` ml2'
-- 
cgit v1.2.3