make Combo work with class

darcs-hash:20070925174417-72aca-2c2fa630e5dad47d830674799715bcf027d06022.gz

1 files changed, 43 insertions, 26 deletions

diff --git a/Combo.hs b/Combo.hs
index 73caa3b..1823410 100644
--- a/Combo.hs
+++ b/Combo.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS -fallow-undecidable-instances #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonadContrib.Combo
@@ -19,24 +20,25 @@ module XMonadContrib.Combo (
                            ) where
 
 import Control.Arrow ( first )
+import Data.List ( delete )
 import Data.Maybe ( isJust )
 import XMonad
-import StackSet ( integrate, differentiate )
+import StackSet ( integrate, Stack(..) )
+import qualified StackSet as W ( differentiate )
 
 -- $usage
 --
 -- To use this layout write, in your Config.hs:
 -- 
 -- > import XMonadContrib.Combo 
--- > import XMonadContrib.SimpleStacking
 -- 
 -- and add something like
 -- 
--- > simpleStacking $ combo (twoPane 0.03 0.5) [(full,1),(tabbed shrinkText defaultTConf,1)]
+-- > combo (twoPane 0.03 0.5) [(full,1),(tabbed shrinkText defaultTConf,1)]
 --
 -- to your defaultLayouts.
 --
--- The first argument to combo is a Layout that will divide the screen into
+-- The first argument to combo is a layout that will divide the screen into
 -- one or more subscreens.  The second argument is a list of layouts which
 -- will be used to lay out the contents of each of those subscreens.
 -- Paired with each of these layouts is an integer giving the number of
@@ -44,33 +46,48 @@ import StackSet ( integrate, differentiate )
 -- layout, which will hold any excess windows.
 
 -- %import XMonadContrib.Combo
--- %import XMonadContrib.SimpleStacking
--- %layout , simpleStacking $ combo (twoPane 0.03 0.5) [(full,1),(tabbed shrinkText defaultTConf,1)]
+-- %layout , combo (twoPane 0.03 0.5) [(full,1),(tabbed shrinkText defaultTConf,1)]
 
-combo :: Layout (Layout a, Int) -> [(Layout a, Int)] -> Layout a
-combo super origls = Layout { doLayout = \r s -> arrange r (integrate s), modifyLayout = message }
-    where arrange _ [] = return ([], Nothing)
-          arrange r [w] = return ([(w,r)], Nothing)
-          arrange rinput origws =
-              do (lrs, msuper') <- runLayout super rinput (differentiate $ take (length origws) origls)
-                 let super' = maybe super id msuper'
-                     lwrs [] _ = []
-                     lwrs [((l,_),r)] ws = [((l,r),differentiate ws)]
-                     lwrs (((l,n),r):xs) ws = ((l,r),differentiate $ take len1 ws) : lwrs xs (drop len1 ws)
-                         where len1 = min n (length ws - length xs)
-                 out <- mapM (uncurry $ uncurry runLayout) $ lwrs lrs origws
-                 let origls' = zipWith foo (out++repeat ([],Nothing)) origls
-                     foo (_, Nothing) x = x
-                     foo (_, Just l') (_, n) = (l', n)
-                 return (concat $ map fst out, Just $ combo super' origls')
-          message m = do mls <- broadcastPrivate m (map fst origls)
+combo :: (Eq a, Show a, Read a, ReadableSomeLayout a, Layout l (SomeLayout a, Int))
+         => (l (SomeLayout a, Int)) -> [(SomeLayout a, Int)] -> Combo l a
+combo = Combo []
+
+data Combo l a = Combo [a] (l (SomeLayout a, Int)) [(SomeLayout a, Int)]
+                 deriving ( Show, Read )
+
+instance (Eq a, Show a, Read a, ReadableSomeLayout a, Layout l (SomeLayout a, Int))
+    => Layout (Combo l) a where
+    doLayout (Combo f super origls) rinput s = arrange (integrate s)
+        where arrange [] = return ([], Just $ Combo [] super origls)
+              arrange [w] = return ([(w,rinput)], Just $ Combo [w] super origls)
+              arrange origws =
+                do (lrs, msuper') <- runLayout super rinput (W.differentiate $ take (length origws) origls)
+                   let super' = maybe super id msuper'
+                       f' = focus s:delete (focus s) f
+                       lwrs [] _ = []
+                       lwrs [((l,_),r)] ws = [((l,r),differentiate f' ws)]
+                       lwrs (((l,n),r):xs) ws = ((l,r),differentiate f' $ take len1 ws) : lwrs xs (drop len1 ws)
+                           where len1 = min n (length ws - length xs)
+                   out <- mapM (uncurry $ uncurry runLayout) $ lwrs lrs origws
+                   let origls' = zipWith foo (out++repeat ([],Nothing)) origls
+                       foo (_, Nothing) x = x
+                       foo (_, Just l') (_, n) = (l', n)
+                   return (concat $ map fst out, Just $ Combo f' super' origls')
+              differentiate :: Eq q => [q] -> [q] -> Maybe (Stack q)
+              differentiate (z:zs) xs | z `elem` xs = Just $ Stack { focus=z
+                                                                   , up = reverse $ takeWhile (/=z) xs
+                                                                   , down = tail $ dropWhile (/=z) xs }
+                                      | otherwise = differentiate zs xs
+              differentiate [] xs = W.differentiate xs
+    modifyLayout (Combo f super origls) m =
+                      do mls <- broadcastPrivate m (map fst origls)
                          let mls' = (\x->zipWith first (map const x) origls) `fmap` mls
                          msuper <- broadcastPrivate m [super]
                          case msuper of
-                           Just [super'] -> return $ Just $ combo super' $ maybe origls id mls'
-                           _ -> return $ combo super `fmap` mls'
+                           Just [super'] -> return $ Just $ Combo f super' $ maybe origls id mls'
+                           _ -> return $ Combo f super `fmap` mls'
 
-broadcastPrivate :: SomeMessage -> [Layout b] -> X (Maybe [Layout b])
+broadcastPrivate :: Layout l b => SomeMessage -> [l b] -> X (Maybe [l b])
 broadcastPrivate a ol = do nml <- mapM f ol
                            if any isJust nml
                               then return $ Just $ zipWith ((flip maybe) id) ol nml