{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE UndecidableInstances #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Layout.Combo
-- Description :  A layout that combines multiple layouts.
-- 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 XMonad hiding (focus)
import XMonad.Layout.WindowNavigation (MoveWindowToWindow (..))
import XMonad.Prelude (delete, fromMaybe, intersect, isJust, (\\), listToMaybe)
import XMonad.StackSet (Stack (..), Workspace (..), integrate')
import XMonad.Util.Stack (zipperFocusedAtFirstOf)

-- $usage
-- You can use this module with the following in your @xmonad.hs@:
--
-- > import XMonad.Layout.Combo
--
-- and add something like
--
-- > combineTwo (TwoPane 0.03 0.5) (tabbed shrinkText def) (tabbed shrinkText def)
--
-- to your layouts.
--
-- For more detailed instructions on editing the layoutHook see
-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and
-- "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
-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.
--
-- 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 (ReadPrec [CombineTwo l l1 l2 a]
ReadPrec (CombineTwo l l1 l2 a)
Int -> ReadS (CombineTwo l l1 l2 a)
ReadS [CombineTwo l l1 l2 a]
(Int -> ReadS (CombineTwo l l1 l2 a))
-> ReadS [CombineTwo l l1 l2 a]
-> ReadPrec (CombineTwo l l1 l2 a)
-> ReadPrec [CombineTwo l l1 l2 a]
-> Read (CombineTwo l l1 l2 a)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall l (l1 :: * -> *) (l2 :: * -> *) a.
(Read a, Read l, Read (l1 a), Read (l2 a)) =>
ReadPrec [CombineTwo l l1 l2 a]
forall l (l1 :: * -> *) (l2 :: * -> *) a.
(Read a, Read l, Read (l1 a), Read (l2 a)) =>
ReadPrec (CombineTwo l l1 l2 a)
forall l (l1 :: * -> *) (l2 :: * -> *) a.
(Read a, Read l, Read (l1 a), Read (l2 a)) =>
Int -> ReadS (CombineTwo l l1 l2 a)
forall l (l1 :: * -> *) (l2 :: * -> *) a.
(Read a, Read l, Read (l1 a), Read (l2 a)) =>
ReadS [CombineTwo l l1 l2 a]
$creadsPrec :: forall l (l1 :: * -> *) (l2 :: * -> *) a.
(Read a, Read l, Read (l1 a), Read (l2 a)) =>
Int -> ReadS (CombineTwo l l1 l2 a)
readsPrec :: Int -> ReadS (CombineTwo l l1 l2 a)
$creadList :: forall l (l1 :: * -> *) (l2 :: * -> *) a.
(Read a, Read l, Read (l1 a), Read (l2 a)) =>
ReadS [CombineTwo l l1 l2 a]
readList :: ReadS [CombineTwo l l1 l2 a]
$creadPrec :: forall l (l1 :: * -> *) (l2 :: * -> *) a.
(Read a, Read l, Read (l1 a), Read (l2 a)) =>
ReadPrec (CombineTwo l l1 l2 a)
readPrec :: ReadPrec (CombineTwo l l1 l2 a)
$creadListPrec :: forall l (l1 :: * -> *) (l2 :: * -> *) a.
(Read a, Read l, Read (l1 a), Read (l2 a)) =>
ReadPrec [CombineTwo l l1 l2 a]
readListPrec :: ReadPrec [CombineTwo l l1 l2 a]
Read, Int -> CombineTwo l l1 l2 a -> ShowS
[CombineTwo l l1 l2 a] -> ShowS
CombineTwo l l1 l2 a -> String
(Int -> CombineTwo l l1 l2 a -> ShowS)
-> (CombineTwo l l1 l2 a -> String)
-> ([CombineTwo l l1 l2 a] -> ShowS)
-> Show (CombineTwo l l1 l2 a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall l (l1 :: * -> *) (l2 :: * -> *) a.
(Show a, Show l, Show (l1 a), Show (l2 a)) =>
Int -> CombineTwo l l1 l2 a -> ShowS
forall l (l1 :: * -> *) (l2 :: * -> *) a.
(Show a, Show l, Show (l1 a), Show (l2 a)) =>
[CombineTwo l l1 l2 a] -> ShowS
forall l (l1 :: * -> *) (l2 :: * -> *) a.
(Show a, Show l, Show (l1 a), Show (l2 a)) =>
CombineTwo l l1 l2 a -> String
$cshowsPrec :: forall l (l1 :: * -> *) (l2 :: * -> *) a.
(Show a, Show l, Show (l1 a), Show (l2 a)) =>
Int -> CombineTwo l l1 l2 a -> ShowS
showsPrec :: Int -> CombineTwo l l1 l2 a -> ShowS
$cshow :: forall l (l1 :: * -> *) (l2 :: * -> *) a.
(Show a, Show l, Show (l1 a), Show (l2 a)) =>
CombineTwo l l1 l2 a -> String
show :: CombineTwo l l1 l2 a -> String
$cshowList :: forall l (l1 :: * -> *) (l2 :: * -> *) a.
(Show a, Show l, Show (l1 a), Show (l2 a)) =>
[CombineTwo l l1 l2 a] -> ShowS
showList :: [CombineTwo l l1 l2 a] -> ShowS
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 :: forall a (super :: * -> *) (l1 :: * -> *) (l2 :: * -> *).
(Read a, Eq a, LayoutClass super (), LayoutClass l1 a,
 LayoutClass l2 a) =>
super () -> l1 a -> l2 a -> CombineTwo (super ()) l1 l2 a
combineTwo = [a]
-> [a] -> super () -> l1 a -> l2 a -> CombineTwo (super ()) l1 l2 a
forall l (l1 :: * -> *) (l2 :: * -> *) a.
[a] -> [a] -> l -> l1 a -> l2 a -> CombineTwo l l1 l2 a
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 String (CombineTwo (l ()) l1 l2 a) a
-> Rectangle
-> X ([(a, Rectangle)], Maybe (CombineTwo (l ()) l1 l2 a))
runLayout (Workspace String
_ (C2 [a]
f [a]
w2 l ()
super l1 a
l1 l2 a
l2) Maybe (Stack a)
s) Rectangle
rinput = [a] -> X ([(a, Rectangle)], Maybe (CombineTwo (l ()) l1 l2 a))
arrange (Maybe (Stack a) -> [a]
forall a. Maybe (Stack a) -> [a]
integrate' Maybe (Stack a)
s)
        where arrange :: [a] -> X ([(a, Rectangle)], Maybe (CombineTwo (l ()) l1 l2 a))
arrange [] = do l1' <- l1 a -> Maybe (l1 a) -> l1 a
forall a. a -> Maybe a -> a
fromMaybe l1 a
l1 (Maybe (l1 a) -> l1 a) -> X (Maybe (l1 a)) -> X (l1 a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> l1 a -> SomeMessage -> X (Maybe (l1 a))
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> X (Maybe (layout a))
handleMessage l1 a
l1 (LayoutMessages -> SomeMessage
forall a. Message a => a -> SomeMessage
SomeMessage LayoutMessages
ReleaseResources)
                              l2' <- fromMaybe l2 <$> handleMessage l2 (SomeMessage ReleaseResources)
                              super' <- fromMaybe super <$>
                                        handleMessage super (SomeMessage ReleaseResources)
                              return ([], Just $ C2 [] [] super' l1' l2')
              arrange [a
w] = do l1' <- l1 a -> Maybe (l1 a) -> l1 a
forall a. a -> Maybe a -> a
fromMaybe l1 a
l1 (Maybe (l1 a) -> l1 a) -> X (Maybe (l1 a)) -> X (l1 a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> l1 a -> SomeMessage -> X (Maybe (l1 a))
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> X (Maybe (layout a))
handleMessage l1 a
l1 (LayoutMessages -> SomeMessage
forall a. Message a => a -> SomeMessage
SomeMessage LayoutMessages
ReleaseResources)
                               l2' <- fromMaybe l2 <$> handleMessage l2 (SomeMessage ReleaseResources)
                               super' <- fromMaybe super <$>
                                         handleMessage super (SomeMessage ReleaseResources)
                               return ([(w,rinput)], Just $ C2 [w] [w] super' l1' l2')
              arrange [a]
origws =
                  do let w2' :: [a]
w2' = case [a]
origws [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` [a]
w2 of [] -> Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
1 [a]
origws
                                                             [a
x] -> [a
x]
                                                             [a]
x -> case [a]
origws [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
\\ [a]
x of
                                                                  [] -> [a] -> [a]
forall a. HasCallStack => [a] -> [a]
init [a]
x
                                                                  [a]
_ -> [a]
x
                         superstack :: Stack ()
superstack = Stack { focus :: ()
focus=(), up :: [()]
up=[], down :: [()]
down=[()] }
                         s1 :: Maybe (Stack a)
s1 = [a] -> [a] -> Maybe (Stack a)
forall q. Eq q => [q] -> [q] -> Zipper q
zipperFocusedAtFirstOf [a]
f' ([a]
origws [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
\\ [a]
w2')
                         s2 :: Maybe (Stack a)
s2 = [a] -> [a] -> Maybe (Stack a)
forall q. Eq q => [q] -> [q] -> Zipper q
zipperFocusedAtFirstOf [a]
f' [a]
w2'
                         f' :: [a]
f' = case Maybe (Stack a)
s of (Just Stack a
s') -> Stack a -> a
forall a. Stack a -> a
focus Stack a
s'a -> [a] -> [a]
forall a. a -> [a] -> [a]
:a -> [a] -> [a]
forall a. Eq a => a -> [a] -> [a]
delete (Stack a -> a
forall a. Stack a -> a
focus Stack a
s') [a]
f
                                        Maybe (Stack a)
Nothing -> [a]
f
                     ([((),r1),((),r2)], msuper') <- Workspace String (l ()) ()
-> Rectangle -> X ([((), Rectangle)], Maybe (l ()))
forall (layout :: * -> *) a.
LayoutClass layout a =>
Workspace String (layout a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
runLayout (String -> l () -> Maybe (Stack ()) -> Workspace String (l ()) ()
forall i l a. i -> l -> Maybe (Stack a) -> Workspace i l a
Workspace String
"" l ()
super (Stack () -> Maybe (Stack ())
forall a. a -> Maybe a
Just Stack ()
superstack)) Rectangle
rinput
                     (wrs1, ml1') <- runLayout (Workspace "" l1 s1) r1
                     (wrs2, ml2') <- runLayout (Workspace "" l2 s2) r2
                     return (wrs1++wrs2, Just $ C2 f' w2'
                                     (fromMaybe super msuper') (fromMaybe l1 ml1') (fromMaybe l2 ml2'))
    handleMessage :: CombineTwo (l ()) l1 l2 a
-> SomeMessage -> X (Maybe (CombineTwo (l ()) l1 l2 a))
handleMessage (C2 [a]
f [a]
ws2 l ()
super l1 a
l1 l2 a
l2) SomeMessage
m
        | Just (MoveWindowToWindow a
w1 a
w2) <- SomeMessage -> Maybe (MoveWindowToWindow a)
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m,
          a
w1 a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [a]
ws2,
          a
w2 a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
ws2 = do l1' <- l1 a -> Maybe (l1 a) -> l1 a
forall a. a -> Maybe a -> a
fromMaybe l1 a
l1 (Maybe (l1 a) -> l1 a) -> X (Maybe (l1 a)) -> X (l1 a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> l1 a -> SomeMessage -> X (Maybe (l1 a))
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> X (Maybe (layout a))
handleMessage l1 a
l1 SomeMessage
m
                             l2' <- fromMaybe l2 <$> handleMessage l2 m
                             return $ Just $ C2 f (w1:ws2) super l1' l2'
        | Just (MoveWindowToWindow a
w1 a
w2) <- SomeMessage -> Maybe (MoveWindowToWindow a)
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m,
          a
w1 a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
ws2,
          a
w2 a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [a]
ws2 = do l1' <- l1 a -> Maybe (l1 a) -> l1 a
forall a. a -> Maybe a -> a
fromMaybe l1 a
l1 (Maybe (l1 a) -> l1 a) -> X (Maybe (l1 a)) -> X (l1 a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> l1 a -> SomeMessage -> X (Maybe (l1 a))
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> X (Maybe (layout a))
handleMessage l1 a
l1 SomeMessage
m
                                l2' <- fromMaybe l2 <$> handleMessage l2 m
                                let ws2' = case a -> [a] -> [a]
forall a. Eq a => a -> [a] -> [a]
delete a
w1 [a]
ws2 of [] -> [a
w2]
                                                                 [a]
x -> [a]
x
                                return $ Just $ C2 f ws2' super l1' l2'
        | Bool
otherwise = do ml1' <- SomeMessage -> [l1 a] -> X (Maybe [l1 a])
forall (l :: * -> *) b.
LayoutClass l b =>
SomeMessage -> [l b] -> X (Maybe [l b])
broadcastPrivate SomeMessage
m [l1 a
l1]
                         ml2' <- broadcastPrivate m [l2]
                         msuper' <- broadcastPrivate m [super]
                         if isJust msuper' || isJust ml1' || isJust ml2'
                            then return $ Just $ C2 f ws2
                                                 (fromMaybe super (listToMaybe =<< msuper'))
                                                 (fromMaybe l1    (listToMaybe =<< ml1'))
                                                 (fromMaybe l2    (listToMaybe =<< ml2'))
                            else return Nothing
    description :: CombineTwo (l ()) l1 l2 a -> String
description (C2 [a]
_ [a]
_ l ()
super l1 a
l1 l2 a
l2) = String
"combining "String -> ShowS
forall a. [a] -> [a] -> [a]
++ l1 a -> String
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> String
description l1 a
l1 String -> ShowS
forall a. [a] -> [a] -> [a]
++String
" and "String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                       l2 a -> String
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> String
description l2 a
l2 String -> ShowS
forall a. [a] -> [a] -> [a]
++String
" with "String -> ShowS
forall a. [a] -> [a] -> [a]
++ l () -> String
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> String
description l ()
super

broadcastPrivate :: LayoutClass l b => SomeMessage -> [l b] -> X (Maybe [l b])
broadcastPrivate :: forall (l :: * -> *) b.
LayoutClass l b =>
SomeMessage -> [l b] -> X (Maybe [l b])
broadcastPrivate SomeMessage
a [l b]
ol = do nml <- (l b -> X (Maybe (l b))) -> [l b] -> X [Maybe (l b)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM l b -> X (Maybe (l b))
forall {layout :: * -> *} {a}.
LayoutClass layout a =>
layout a -> X (Maybe (layout a))
f [l b]
ol
                           if any isJust nml
                              then return $ Just $ zipWith (`maybe` id) ol nml
                              else return Nothing
    where f :: layout a -> X (Maybe (layout a))
f layout a
l = layout a -> SomeMessage -> X (Maybe (layout a))
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> X (Maybe (layout a))
handleMessage layout a
l SomeMessage
a X (Maybe (layout a))
-> X (Maybe (layout a)) -> X (Maybe (layout a))
forall a. X a -> X a -> X a
`catchX` Maybe (layout a) -> X (Maybe (layout a))
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (layout a)
forall a. Maybe a
Nothing