content: {-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses,
               UndecidableInstances, PatternGuards #-}
  
  -----------------------------------------------------------------------------
  -- |
  -- Module      :  XMonad.Layout.Combo
  -- Copyright   :  (c) David Roundy <droundy@darcs.net>
  -- License     :  BSD-style (see LICENSE)
  --
  -- Maintainer  :  none
  -- Stability   :  unstable
  -- Portability :  unportable
  --
  -- A layout that combines multiple layouts.
  --
  -----------------------------------------------------------------------------
  
  module XMonad.Layout.Combo (
                              -- * Usage
                              -- $usage
                              combineTwo,
                              CombineTwo
                             ) where
  
  import Data.List ( delete, intersect, (\\) )
  import Data.Maybe ( isJust )
  import XMonad hiding (focus)
  import XMonad.StackSet ( integrate', Workspace (..), Stack(..) )
  import XMonad.Layout.WindowNavigation ( MoveWindowToWindow(..) )
  import qualified XMonad.StackSet as W ( differentiate )
  
  -- $usage
  -- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:
  --
  -- > import XMonad.Layout.Combo
  --
  -- and add something like
  --
  -- > combineTwo (TwoPane 0.03 0.5) (tabbed shrinkText defaultTConf) (tabbed shrinkText defaultTConf)
  --
  -- to your layouts.
  --
  -- For more detailed instructions on editing the layoutHook see:
  --
  -- "XMonad.Doc.Extending#Editing_the_layout_hook"
  --
  -- combineTwo is a new simple layout combinator. It allows the
  -- combination of two layouts using a third to split the screen
  -- between the two, but has the advantage of allowing you to
  -- dynamically adjust the layout, in terms of the number of windows in
  -- each sublayout. To do this, use "XMonad.Layout.WindowNavigation",
  -- and add the following key bindings (or something similar):
  --
  -- >    , ((modm .|. controlMask .|. shiftMask, xK_Right), sendMessage $ Move R)
  -- >    , ((modm .|. controlMask .|. shiftMask, xK_Left ), sendMessage $ Move L)
  -- >    , ((modm .|. controlMask .|. shiftMask, xK_Up   ), sendMessage $ Move U)
  -- >    , ((modm .|. controlMask .|. shiftMask, xK_Down ), sendMessage $ Move D)
  --
  -- For detailed instruction on editing the key binding see
  -- "XMonad.Doc.Extending#Editing_key_bindings".
  --
  -- These bindings will move a window into the sublayout that is
  -- up\/down\/left\/right of its current position.  Note that there is some
  -- weirdness in combineTwo, in that the mod-tab focus order is not very closely
  -- related to the layout order. This is because we're forced to keep track of
  -- the window positions separately, and this is ugly.  If you don't like this,
  -- lobby for hierarchical stacks in core xmonad or go reimplement the core of
  -- xmonad yourself.
  
  data CombineTwo l l1 l2 a = C2 [a] [a] l (l1 a) (l2 a)
                              deriving (Read, Show)
  
  combineTwo :: (Read a, Eq a, LayoutClass super (), LayoutClass l1 a, LayoutClass l2 a) =>
                super () -> l1 a -> l2 a -> CombineTwo (super ()) l1 l2 a
  combineTwo = C2 [] []
  
  instance (LayoutClass l (), LayoutClass l1 a, LayoutClass l2 a, Read a, Show a, Eq a, Typeable a)
      => LayoutClass (CombineTwo (l ()) l1 l2) a where
      runLayout (Workspace _ (C2 f w2 super l1 l2) s) rinput = arrange (integrate' s)
          where arrange [] = do l1' <- maybe l1 id `fmap` handleMessage l1 (SomeMessage ReleaseResources)
                                l2' <- maybe l2 id `fmap` handleMessage l2 (SomeMessage ReleaseResources)
                                super' <- maybe super id `fmap`
                                          handleMessage super (SomeMessage ReleaseResources)
                                return ([], Just $ C2 [] [] super' l1' l2')
                arrange [w] = do l1' <- maybe l1 id `fmap` handleMessage l1 (SomeMessage ReleaseResources)
                                 l2' <- maybe l2 id `fmap` handleMessage l2 (SomeMessage ReleaseResources)
                                 super' <- maybe super id `fmap`
                                           handleMessage super (SomeMessage ReleaseResources)
                                 return ([(w,rinput)], Just $ C2 [w] [w] super' l1' l2')
                arrange origws =
                    do let w2' = case origws `intersect` w2 of [] -> [head origws]
                                                               [x] -> [x]
                                                               x -> case origws \\ x of
                                                                    [] -> init x
                                                                    _ -> x
                           superstack = Stack { focus=(), up=[], down=[()] }
                           s1 = differentiate f' (origws \\ w2')
                           s2 = differentiate f' w2'
                           f' = case s of (Just s') -> focus s':delete (focus s') f
                                          Nothing -> f
                       ([((),r1),((),r2)], msuper') <- runLayout (Workspace "" super (Just superstack)) rinput
                       (wrs1, ml1') <- runLayout (Workspace "" l1 s1) r1
                       (wrs2, ml2') <- runLayout (Workspace "" l2 s2) r2
                       return (wrs1++wrs2, Just $ C2 f' w2'
                                       (maybe super id msuper') (maybe l1 id ml1') (maybe l2 id ml2'))
      handleMessage (C2 f ws2 super l1 l2) m
          | Just (MoveWindowToWindow w1 w2) <- fromMessage m,
            w1 `notElem` ws2,
            w2 `elem` ws2 = do l1' <- maybe l1 id `fmap` handleMessage l1 m
                               l2' <- maybe l2 id `fmap` handleMessage l2 m
                               return $ Just $ C2 f (w1:ws2) super l1' l2'
          | Just (MoveWindowToWindow w1 w2) <- fromMessage m,
            w1 `elem` ws2,
            w2 `notElem` ws2 = do l1' <- maybe l1 id `fmap` handleMessage l1 m
                                  l2' <- maybe l2 id `fmap` handleMessage l2 m
                                  let ws2' = case delete w1 ws2 of [] -> [w2]
                                                                   x -> x
                                  return $ Just $ C2 f ws2' super l1' l2'
          | otherwise = do ml1' <- broadcastPrivate m [l1]
                           ml2' <- broadcastPrivate m [l2]
                           msuper' <- broadcastPrivate m [super]
                           if isJust msuper' || isJust ml1' || isJust ml2'
                              then return $ Just $ C2 f ws2
                                                   (maybe super head msuper')
                                                   (maybe l1 head ml1')
                                                   (maybe l2 head ml2')
                              else return Nothing
      description (C2 _ _ super l1 l2) = "combining "++ description l1 ++" and "++
                                         description l2 ++" with "++ description super
  
  
  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
  
  broadcastPrivate :: LayoutClass 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
                                else return Nothing
      where f l = handleMessage l a `catchX` return Nothing
  