{-# 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)
ReadS [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]
readListPrec :: 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]
readPrec :: ReadPrec (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)
readList :: 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]
readsPrec :: Int -> 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)
Read, Int -> CombineTwo l l1 l2 a -> ShowS
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
showList :: [CombineTwo l l1 l2 a] -> ShowS
$cshowList :: forall l (l1 :: * -> *) (l2 :: * -> *) a.
(Show a, Show l, Show (l1 a), Show (l2 a)) =>
[CombineTwo l l1 l2 a] -> ShowS
show :: CombineTwo l l1 l2 a -> String
$cshow :: forall l (l1 :: * -> *) (l2 :: * -> *) a.
(Show a, Show l, Show (l1 a), Show (l2 a)) =>
CombineTwo l l1 l2 a -> String
showsPrec :: Int -> CombineTwo l l1 l2 a -> ShowS
$cshowsPrec :: forall l (l1 :: * -> *) (l2 :: * -> *) a.
(Show a, Show l, Show (l1 a), Show (l2 a)) =>
Int -> 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 = 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 (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 a
l1' <- forall a. a -> Maybe a -> a
fromMaybe l1 a
l1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> X (Maybe (layout a))
handleMessage l1 a
l1 (forall a. Message a => a -> SomeMessage
SomeMessage LayoutMessages
ReleaseResources)
                              l2 a
l2' <- forall a. a -> Maybe a -> a
fromMaybe l2 a
l2 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> X (Maybe (layout a))
handleMessage l2 a
l2 (forall a. Message a => a -> SomeMessage
SomeMessage LayoutMessages
ReleaseResources)
                              l ()
super' <- forall a. a -> Maybe a -> a
fromMaybe l ()
super forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                        forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> X (Maybe (layout a))
handleMessage l ()
super (forall a. Message a => a -> SomeMessage
SomeMessage LayoutMessages
ReleaseResources)
                              forall (m :: * -> *) a. Monad m => a -> m a
return ([], forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l (l1 :: * -> *) (l2 :: * -> *) a.
[a] -> [a] -> l -> l1 a -> l2 a -> CombineTwo l l1 l2 a
C2 [] [] l ()
super' l1 a
l1' l2 a
l2')
              arrange [a
w] = do l1 a
l1' <- forall a. a -> Maybe a -> a
fromMaybe l1 a
l1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> X (Maybe (layout a))
handleMessage l1 a
l1 (forall a. Message a => a -> SomeMessage
SomeMessage LayoutMessages
ReleaseResources)
                               l2 a
l2' <- forall a. a -> Maybe a -> a
fromMaybe l2 a
l2 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> X (Maybe (layout a))
handleMessage l2 a
l2 (forall a. Message a => a -> SomeMessage
SomeMessage LayoutMessages
ReleaseResources)
                               l ()
super' <- forall a. a -> Maybe a -> a
fromMaybe l ()
super forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                         forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> X (Maybe (layout a))
handleMessage l ()
super (forall a. Message a => a -> SomeMessage
SomeMessage LayoutMessages
ReleaseResources)
                               forall (m :: * -> *) a. Monad m => a -> m a
return ([(a
w,Rectangle
rinput)], forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l (l1 :: * -> *) (l2 :: * -> *) a.
[a] -> [a] -> l -> l1 a -> l2 a -> CombineTwo l l1 l2 a
C2 [a
w] [a
w] l ()
super' l1 a
l1' l2 a
l2')
              arrange [a]
origws =
                  do let w2' :: [a]
w2' = case [a]
origws forall a. Eq a => [a] -> [a] -> [a]
`intersect` [a]
w2 of [] -> forall a. Int -> [a] -> [a]
take Int
1 [a]
origws
                                                             [a
x] -> [a
x]
                                                             [a]
x -> case [a]
origws forall a. Eq a => [a] -> [a] -> [a]
\\ [a]
x of
                                                                  [] -> forall a. [a] -> [a]
init [a]
x
                                                                  [a]
_ -> [a]
x
                         superstack :: Stack ()
superstack = Stack { focus :: ()
focus=(), up :: [()]
up=[], down :: [()]
down=[()] }
                         s1 :: Maybe (Stack a)
s1 = forall q. Eq q => [q] -> [q] -> Zipper q
zipperFocusedAtFirstOf [a]
f' ([a]
origws forall a. Eq a => [a] -> [a] -> [a]
\\ [a]
w2')
                         s2 :: Maybe (Stack a)
s2 = 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') -> forall a. Stack a -> a
focus Stack a
s'forall a. a -> [a] -> [a]
:forall a. Eq a => a -> [a] -> [a]
delete (forall a. Stack a -> a
focus Stack a
s') [a]
f
                                        Maybe (Stack a)
Nothing -> [a]
f
                     ([((),Rectangle
r1),((),Rectangle
r2)], Maybe (l ())
msuper') <- forall (layout :: * -> *) a.
LayoutClass layout a =>
Workspace String (layout a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
runLayout (forall i l a. i -> l -> Maybe (Stack a) -> Workspace i l a
Workspace String
"" l ()
super (forall a. a -> Maybe a
Just Stack ()
superstack)) Rectangle
rinput
                     ([(a, Rectangle)]
wrs1, Maybe (l1 a)
ml1') <- forall (layout :: * -> *) a.
LayoutClass layout a =>
Workspace String (layout a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
runLayout (forall i l a. i -> l -> Maybe (Stack a) -> Workspace i l a
Workspace String
"" l1 a
l1 Maybe (Stack a)
s1) Rectangle
r1
                     ([(a, Rectangle)]
wrs2, Maybe (l2 a)
ml2') <- forall (layout :: * -> *) a.
LayoutClass layout a =>
Workspace String (layout a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
runLayout (forall i l a. i -> l -> Maybe (Stack a) -> Workspace i l a
Workspace String
"" l2 a
l2 Maybe (Stack a)
s2) Rectangle
r2
                     forall (m :: * -> *) a. Monad m => a -> m a
return ([(a, Rectangle)]
wrs1forall a. [a] -> [a] -> [a]
++[(a, Rectangle)]
wrs2, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l (l1 :: * -> *) (l2 :: * -> *) a.
[a] -> [a] -> l -> l1 a -> l2 a -> CombineTwo l l1 l2 a
C2 [a]
f' [a]
w2'
                                     (forall a. a -> Maybe a -> a
fromMaybe l ()
super Maybe (l ())
msuper') (forall a. a -> Maybe a -> a
fromMaybe l1 a
l1 Maybe (l1 a)
ml1') (forall a. a -> Maybe a -> a
fromMaybe l2 a
l2 Maybe (l2 a)
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) <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m,
          a
w1 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [a]
ws2,
          a
w2 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
ws2 = do l1 a
l1' <- forall a. a -> Maybe a -> a
fromMaybe l1 a
l1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> X (Maybe (layout a))
handleMessage l1 a
l1 SomeMessage
m
                             l2 a
l2' <- forall a. a -> Maybe a -> a
fromMaybe l2 a
l2 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> X (Maybe (layout a))
handleMessage l2 a
l2 SomeMessage
m
                             forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l (l1 :: * -> *) (l2 :: * -> *) a.
[a] -> [a] -> l -> l1 a -> l2 a -> CombineTwo l l1 l2 a
C2 [a]
f (a
w1forall a. a -> [a] -> [a]
:[a]
ws2) l ()
super l1 a
l1' l2 a
l2'
        | Just (MoveWindowToWindow a
w1 a
w2) <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m,
          a
w1 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
ws2,
          a
w2 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [a]
ws2 = do l1 a
l1' <- forall a. a -> Maybe a -> a
fromMaybe l1 a
l1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> X (Maybe (layout a))
handleMessage l1 a
l1 SomeMessage
m
                                l2 a
l2' <- forall a. a -> Maybe a -> a
fromMaybe l2 a
l2 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> X (Maybe (layout a))
handleMessage l2 a
l2 SomeMessage
m
                                let ws2' :: [a]
ws2' = case forall a. Eq a => a -> [a] -> [a]
delete a
w1 [a]
ws2 of [] -> [a
w2]
                                                                 [a]
x -> [a]
x
                                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l (l1 :: * -> *) (l2 :: * -> *) a.
[a] -> [a] -> l -> l1 a -> l2 a -> CombineTwo l l1 l2 a
C2 [a]
f [a]
ws2' l ()
super l1 a
l1' l2 a
l2'
        | Bool
otherwise = do Maybe [l1 a]
ml1' <- forall (l :: * -> *) b.
LayoutClass l b =>
SomeMessage -> [l b] -> X (Maybe [l b])
broadcastPrivate SomeMessage
m [l1 a
l1]
                         Maybe [l2 a]
ml2' <- forall (l :: * -> *) b.
LayoutClass l b =>
SomeMessage -> [l b] -> X (Maybe [l b])
broadcastPrivate SomeMessage
m [l2 a
l2]
                         Maybe [l ()]
msuper' <- forall (l :: * -> *) b.
LayoutClass l b =>
SomeMessage -> [l b] -> X (Maybe [l b])
broadcastPrivate SomeMessage
m [l ()
super]
                         if forall a. Maybe a -> Bool
isJust Maybe [l ()]
msuper' Bool -> Bool -> Bool
|| forall a. Maybe a -> Bool
isJust Maybe [l1 a]
ml1' Bool -> Bool -> Bool
|| forall a. Maybe a -> Bool
isJust Maybe [l2 a]
ml2'
                            then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l (l1 :: * -> *) (l2 :: * -> *) a.
[a] -> [a] -> l -> l1 a -> l2 a -> CombineTwo l l1 l2 a
C2 [a]
f [a]
ws2
                                                 (forall a. a -> Maybe a -> a
fromMaybe l ()
super (forall a. [a] -> Maybe a
listToMaybe forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe [l ()]
msuper'))
                                                 (forall a. a -> Maybe a -> a
fromMaybe l1 a
l1    (forall a. [a] -> Maybe a
listToMaybe forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe [l1 a]
ml1'))
                                                 (forall a. a -> Maybe a -> a
fromMaybe l2 a
l2    (forall a. [a] -> Maybe a
listToMaybe forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe [l2 a]
ml2'))
                            else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    description :: CombineTwo (l ()) l1 l2 a -> String
description (C2 [a]
_ [a]
_ l ()
super l1 a
l1 l2 a
l2) = String
"combining "forall a. [a] -> [a] -> [a]
++ forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> String
description l1 a
l1 forall a. [a] -> [a] -> [a]
++String
" and "forall a. [a] -> [a] -> [a]
++
                                       forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> String
description l2 a
l2 forall a. [a] -> [a] -> [a]
++String
" with "forall a. [a] -> [a] -> [a]
++ 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 [Maybe (l b)]
nml <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {layout :: * -> *} {a}.
LayoutClass layout a =>
layout a -> X (Maybe (layout a))
f [l b]
ol
                           if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a. Maybe a -> Bool
isJust [Maybe (l b)]
nml
                              then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (forall b a. b -> (a -> b) -> Maybe a -> b
`maybe` forall a. a -> a
id) [l b]
ol [Maybe (l b)]
nml
                              else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    where f :: layout a -> X (Maybe (layout a))
f layout a
l = forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> X (Maybe (layout a))
handleMessage layout a
l SomeMessage
a forall a. X a -> X a -> X a
`catchX` forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing