    {-# LANGUAGE PatternGuards, ParallelListComp, DeriveDataTypeable, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, TypeSynonymInstances #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  XMonad.Layout.SubLayouts
    -- Copyright   :  (c) 2009 Adam Vogt
    -- License     :  BSD-style (see xmonad/LICENSE)
    --
    -- Maintainer  :  vogt.adam@gmail.com
    -- Stability   :  unstable
    -- Portability :  unportable
    --
    -- A layout combinator that allows layouts to be nested.
    --
    -----------------------------------------------------------------------------

    module XMonad.Layout.SubLayouts (
        -- * Usage
        -- $usage
        subLayout,
        subTabbed,

        pushGroup, pullGroup,
        pushWindow, pullWindow,
        onGroup, toSubl, mergeDir,

        GroupMsg(..),
        Broadcast(..),

        defaultSublMap,

        Sublayout,

        -- * Screenshots
        -- $screenshots

        -- * Todo
        -- $todo
        )
        where

    import XMonad.Layout.Circle () -- so haddock can find the link

    import XMonad.Layout.Decoration(Decoration, DefaultShrinker)
    import XMonad.Layout.LayoutModifier(LayoutModifier(handleMess, modifyLayout,
                                        redoLayout),
                                        ModifiedLayout(..))
    import XMonad.Layout.Simplest(Simplest(..))
    import XMonad.Layout.Tabbed(shrinkText,
                                TabbedDecoration, addTabs)
    import XMonad.Layout.WindowNavigation(Navigate(Apply))
    import XMonad.Util.Invisible(Invisible(..))
    import XMonad.Util.Types(Direction2D(..))
    import XMonad hiding (def)
    import Control.Applicative((<$>),(<*))
    import Control.Arrow(Arrow(second, (&&&)))
    import Control.Monad(MonadPlus(mplus), foldM, guard, when, join)
    import Data.Function(on)
    import Data.List(nubBy, (\\), find)
    import Data.Maybe(isNothing, fromMaybe, listToMaybe, mapMaybe)
    import Data.Traversable(sequenceA)

    import qualified XMonad as X
    import qualified XMonad.Layout.BoringWindows as B
    import qualified XMonad.StackSet as W
    import qualified Data.Map as M
    import Data.Map(Map)

    -- $screenshots
    --
    -- <<http://haskell.org/sitewiki/images/thumb/8/8b/Xmonad-SubLayouts-xinerama.png/480px-Xmonad-SubLayouts-xinerama.png>>
    --
    -- Larger version: <http://haskell.org/sitewiki/images/8/8b/Xmonad-SubLayouts-xinerama.png>

    -- $todo
    --  /Issue 288/
    --
    --  "XMonad.Layout.ResizableTile" assumes that its environment
    --  contains only the windows it is running: sublayouts are currently run with
    --  the stack containing only the windows passed to it in its environment, but
    --  any changes that the layout makes are not merged back.
    --
    --  Should the behavior be made optional?
    --
    --  /Features/
    --
    --   * suggested managehooks for merging specific windows, or the apropriate
    --     layout based hack to find out the number of groups currently showed, but
    --     the size of current window groups is not available (outside of this
    --     growing module)
    --
    --  /SimpleTabbed as a SubLayout/
    --
    --  'subTabbed' works well, but it would be more uniform to avoid the use of
    --  addTabs, with the sublayout being Simplest (but
    --  'XMonad.Layout.Tabbed.simpleTabbed' is this...).  The only thing to be
    --  gained by fixing this issue is the ability to mix and match decoration
    --  styles. Better compatibility with some other layouts of which I am not
    --  aware could be another benefit.
    --
    --  'simpleTabbed' (and other decorated layouts) fail horribly when used as
    --  subLayouts:
    --
    --    * decorations stick around: layout is run after being told to Hide
    --
    --    * mouse events do not change focus: the group-ungroup does not respect
    --      the focus changes it wants?
    --
    --    * sending ReleaseResources before running it makes xmonad very slow, and
    --      still leaves borders sticking around
    --

    -- $usage
    -- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:
    --
    -- > import XMonad.Layout.SubLayouts
    -- > import XMonad.Layout.WindowNavigation
    --
    -- Using "XMonad.Layout.BoringWindows" is optional and it allows you to add a
    -- keybinding to skip over the non-visible windows.
    --
    -- > import XMonad.Layout.BoringWindows
    --
    -- Then edit your @layoutHook@ by adding the 'subTabbed' layout modifier:
    --
    -- > myLayout = windowNavigation $ subTabbed $ boringWindows $
    -- >                        Tall 1 (3/100) (1/2) ||| etc..
    -- > main = xmonad def { layoutHook = myLayout }
    --
    -- "XMonad.Layout.WindowNavigation" is used to specify which windows to merge,
    -- and it is not integrated into the modifier because it can be configured, and
    -- works best as the outer modifier.
    --
    -- Then to your keybindings add:
    --
    --  > , ((modm .|. controlMask, xK_h), sendMessage $ pullGroup L)
    --  > , ((modm .|. controlMask, xK_l), sendMessage $ pullGroup R)
    --  > , ((modm .|. controlMask, xK_k), sendMessage $ pullGroup U)
    --  > , ((modm .|. controlMask, xK_j), sendMessage $ pullGroup D)
    --  >
    --  > , ((modm .|. controlMask, xK_m), withFocused (sendMessage . MergeAll))
    --  > , ((modm .|. controlMask, xK_u), withFocused (sendMessage . UnMerge))
    --  >
    --  > , ((modm .|. controlMask, xK_period), onGroup W.focusUp')
    --  > , ((modm .|. controlMask, xK_comma), onGroup W.focusDown')
    --
    --  These additional keybindings require the optional
    --  "XMonad.Layout.BoringWindows" layoutModifier. The focus will skip over the
    --  windows that are not focused in each sublayout.
    --
    --  > , ((modm, xK_j), focusDown)
    --  > , ((modm, xK_k), focusUp)
    --
    --  A 'submap' can be used to make modifying the sublayouts using 'onGroup' and
    --  'toSubl' simpler:
    --
    --  > ,((modm, xK_s), submap $ defaultSublMap conf)
    --
    --  /NOTE:/ is there some reason that @asks config >>= submap . defaultSublMap@
    --  could not be used in the keybinding instead? It avoids having to explicitly
    --  pass the conf.
    --
    -- For more detailed instructions, see:
    --
    -- "XMonad.Doc.Extending#Editing_the_layout_hook"
    -- "XMonad.Doc.Extending#Adding_key_bindings"

    -- | The main layout modifier arguments:
    --
    -- @subLayout advanceInnerLayouts innerLayout outerLayout@
    --
    --  [@advanceInnerLayouts@] When a new group at index @n@ in the outer layout
    --  is created (even with one element), the @innerLayout@ is used as the
    --  layout within that group after being advanced with @advanceInnerLayouts !!
    --  n@ 'NextLayout' messages. If there is no corresponding element in the
    --  @advanceInnerLayouts@ list, then @innerLayout@ is not given any 'NextLayout'
    --  messages.
    --
    --  [@innerLayout@] The single layout given to be run as a sublayout.
    --
    --  [@outerLayout@] The layout that determines the rectangles given to each
    --  group.
    --
    --  Ex. The second group is 'Tall', the third is 'Circle', all others are tabbed
    --  with:
    --
    --  > myLayout = addTabs shrinkText def
    --  >          $ subLayout [0,1,2] (Simplest ||| Tall 1 0.2 0.5 ||| Circle)
    --  >          $ Tall 1 0.2 0.5 ||| Full
    subLayout :: [Int] -> subl a -> l a -> ModifiedLayout (Sublayout subl) l a
    subLayout nextLayout sl x = ModifiedLayout (Sublayout (I []) (nextLayout,sl) []) x

    -- | @subTabbed@ is a use of 'subLayout' with 'addTabs' to show decorations.
    subTabbed :: (Eq a, LayoutModifier (Sublayout Simplest) a, LayoutClass l a) =>
        l a -> ModifiedLayout (Decoration TabbedDecoration DefaultShrinker)
                              (ModifiedLayout (Sublayout Simplest) l) a
    subTabbed  x = addTabs shrinkText X.def $ subLayout [] Simplest x

    -- | @defaultSublMap@ is an attempt to create a set of keybindings like the
    -- defaults ones but to be used as a 'submap' for sending messages to the
    -- sublayout.
    defaultSublMap :: XConfig l -> Map (KeyMask, KeySym) (X ())
    defaultSublMap (XConfig { modMask = modm }) = M.fromList
             [((modm, xK_space), toSubl NextLayout),
              ((modm, xK_j), onGroup W.focusDown'),
              ((modm, xK_k), onGroup W.focusUp'),
              ((modm, xK_h), toSubl Shrink),
              ((modm, xK_l), toSubl Expand),
              ((modm, xK_Tab), onGroup W.focusDown'),
              ((modm .|. shiftMask, xK_Tab), onGroup W.focusUp'),
              ((modm, xK_m), onGroup focusMaster'),
              ((modm, xK_comma), toSubl $ IncMasterN 1),
              ((modm, xK_period), toSubl $ IncMasterN (-1)),
              ((modm, xK_Return), onGroup swapMaster')
             ]
            where
             -- should these go into XMonad.StackSet?
             focusMaster' st = let (f:fs) = W.integrate st
                in W.Stack f [] fs
             swapMaster' (W.Stack f u d) = W.Stack f [] $ reverse u ++ d

    data Sublayout l a = Sublayout
        { delayMess :: Invisible [] (SomeMessage,a)
                              -- ^ messages are handled when running the layout,
                              -- not in the handleMessage, I'm not sure that this
                              -- is necessary
        , def :: ([Int], l a) -- ^ how many NextLayout messages to send to newly
                              -- populated layouts. If there is no corresponding
                              -- index, then don't send any.
        , subls :: [(l a,W.Stack a)]
                              -- ^ The sublayouts and the stacks they manage
        }
        deriving (Read,Show)

    -- | Groups assumes this invariant:
    --     M.keys gs == map W.focus (M.elems gs)  (ignoring order)
    --     All windows in the workspace are in the Map
    --
    -- The keys are visible windows, the rest are hidden.
    --
    -- This representation probably simplifies the internals of the modifier.
    type Groups a = Map a (W.Stack a)

    -- | GroupMsg take window parameters to determine which group the action should
    -- be applied to
    data GroupMsg a
        = UnMerge a -- ^ free the focused window from its tab stack
        | UnMergeAll a
                    -- ^ separate the focused group into singleton groups
        | Merge a a -- ^ merge the first group into the second group
        | MergeAll a
                    -- ^ make one large group, keeping the parameter focused
        | Migrate a a
                    -- ^ used to the window named in the first argument to the
                    -- second argument's group, this may be replaced by a
                    -- combination of 'UnMerge' and 'Merge'
        | WithGroup (W.Stack a -> X (W.Stack a)) a
        | SubMessage SomeMessage  a
                    -- ^ the sublayout with the given window will get the message
        deriving (Typeable)

    -- | merge the window that would be focused by the function when applied to the
    -- W.Stack of all windows, with the current group removed. The given window
    -- should be focused by a sublayout. Example usage: @withFocused (sendMessage .
    -- mergeDir W.focusDown')@
    mergeDir :: (W.Stack Window -> W.Stack Window) -> Window -> GroupMsg Window
    mergeDir f w = WithGroup g w
     where g cs = do
            let onlyOthers = W.filter (`notElem` W.integrate cs)
            flip whenJust (sendMessage . Merge (W.focus cs) . W.focus . f)
                =<< fmap (onlyOthers =<<) currentStack
            return cs

    data Broadcast = Broadcast SomeMessage -- ^ send a message to all sublayouts
        deriving (Typeable)

    instance Message Broadcast
    instance Typeable a => Message (GroupMsg a)

    -- | @pullGroup@, @pushGroup@ allow you to merge windows or groups inheriting
    -- the position of the current window (pull) or the other window (push).
    --
    -- @pushWindow@ and @pullWindow@ move individual windows between groups. They
    -- are less effective at preserving window positions.
    pullGroup,pushGroup,pullWindow,pushWindow :: Direction2D -> Navigate
    pullGroup = mergeNav (\o c -> sendMessage $ Merge o c)
    pushGroup = mergeNav (\o c -> sendMessage $ Merge c o)
    pullWindow = mergeNav (\o c -> sendMessage $ Migrate o c)
    pushWindow = mergeNav (\o c -> sendMessage $ Migrate c o)

    mergeNav :: (Window -> Window -> X ()) -> Direction2D -> Navigate
    mergeNav f = Apply (\o -> withFocused (f o))

    -- | Apply a function on the stack belonging to the currently focused group. It
    -- works for rearranging windows and for changing focus.
    onGroup :: (W.Stack Window -> W.Stack Window) -> X ()
    onGroup f = withFocused (sendMessage . WithGroup (return . f))

    -- | Send a message to the currently focused sublayout.
    toSubl :: (Message a) => a -> X ()
    toSubl m = withFocused (sendMessage . SubMessage (SomeMessage m))

    instance (Read (l Window), Show (l Window), LayoutClass l Window) => LayoutModifier (Sublayout l) Window where
        modifyLayout (Sublayout { subls = osls }) (W.Workspace i la st) r = do
                let gs' = updateGroup st $ toGroups osls
                    st' = W.filter (`elem` M.keys gs') =<< st
                updateWs gs'
                oldStack <- gets $ W.stack . W.workspace . W.current . windowset
                setStack st'
                runLayout (W.Workspace i la st') r <* setStack oldStack
                -- FIXME: merge back reordering, deletions?

        redoLayout (Sublayout { delayMess = I ms, def = defl, subls = osls }) _r st arrs = do
            let gs' = updateGroup st $ toGroups osls
            sls <- fromGroups defl st gs' osls

            let newL :: LayoutClass l Window => Rectangle -> WorkspaceId -> (l Window) -> Bool
                        -> (Maybe (W.Stack Window)) -> X ([(Window, Rectangle)], l Window)
                newL rect n ol isNew sst = do
                    orgStack <- currentStack
                    let handle l (y,_)
                            | not isNew = fromMaybe l <$> handleMessage l y
                            | otherwise = return l
                        kms = filter ((`elem` M.keys gs') . snd) ms
                    setStack sst
                    nl <- foldM handle ol $ filter ((`elem` W.integrate' sst) . snd) kms
                    result <- runLayout (W.Workspace n nl sst) rect
                    setStack orgStack -- FIXME: merge back reordering, deletions?
                    return $ fromMaybe nl `second` result

                (urls,ssts) = unzip [ (newL gr i l isNew sst, sst)
                        | (isNew,(l,_st)) <- sls
                        | i <- map show [ 0 :: Int .. ]
                        | (k,gr) <- arrs, let sst = M.lookup k gs' ]

            arrs' <- sequence urls
            sls' <- return . Sublayout (I []) defl . map snd <$> fromGroups defl st gs'
                            [ (l,s) | (_,l) <- arrs' | (Just s) <- ssts ]
            return (concatMap fst arrs', sls')

        handleMess (Sublayout (I ms) defl sls) m
            | Just (SubMessage sm w) <- fromMessage m =
                return $ Just $ Sublayout (I ((sm,w):ms)) defl sls

            | Just (Broadcast sm) <- fromMessage m = do
                ms' <- fmap (zip (repeat sm) . W.integrate') currentStack
                return $ if null ms' then Nothing
                    else Just $ Sublayout (I $ ms' ++ ms) defl sls

            | Just B.UpdateBoring <- fromMessage m = do
                let bs = concatMap unfocused $ M.elems gs
                ws <- gets (W.workspace . W.current . windowset)
                flip sendMessageWithNoRefresh ws $ B.Replace "Sublayouts" bs
                return Nothing

            | Just (WithGroup f w) <- fromMessage m
            , Just g <- M.lookup w gs = do
                g' <- f g
                let gs' = M.insert (W.focus g') g' $ M.delete (W.focus g) gs
                when (gs' /= gs) $ updateWs gs'
                when (w /= W.focus g') $ windows (W.focusWindow $ W.focus g')
                return Nothing

            | Just (MergeAll w) <- fromMessage m =
                let gs' = fmap (M.singleton w)
                        $ (focusWindow' w =<<) $ W.differentiate
                        $ concatMap W.integrate $ M.elems gs
                in maybe (return Nothing) fgs gs'

            | Just (UnMergeAll w) <- fromMessage m =
                let ws = concatMap W.integrate $ M.elems gs
                    _ = w :: Window
                    mkSingleton f = M.singleton f (W.Stack f [] [])
                in fgs $ M.unions $ map mkSingleton ws

            | Just (Merge x y) <- fromMessage m
            , Just (W.Stack _ xb xn) <- findGroup x
            , Just yst <- findGroup y =
                let zs = W.Stack x xb (xn ++ W.integrate yst)
                in fgs $ M.insert x zs $ M.delete (W.focus yst) gs

            | Just (UnMerge x) <- fromMessage m =
                fgs . M.fromList . map (W.focus &&& id) . M.elems
                        $ M.mapMaybe (W.filter (x/=)) gs

            -- XXX sometimes this migrates an incorrect window, why?
            | Just (Migrate x y) <- fromMessage m
            , Just xst <- findGroup x
            , Just (W.Stack yf yu yd) <- findGroup y =
                let zs = W.Stack x (yf:yu) yd
                    nxsAdd = maybe id (\e -> M.insert (W.focus e) e) $ W.filter (x/=) xst
                in fgs $ nxsAdd $ M.insert x zs $ M.delete yf gs

            | otherwise = fmap join $ sequenceA $ catchLayoutMess <$> fromMessage m
         where gs = toGroups sls
               fgs gs' = do
                    st <- currentStack
                    Just . Sublayout (I ms) defl . map snd <$> fromGroups defl st gs' sls

               findGroup z = mplus (M.lookup z gs) $ listToMaybe
                        $ M.elems $ M.filter ((z `elem`) . W.integrate) gs
               -- catchLayoutMess :: LayoutMessages -> X (Maybe (Sublayout l Window))
               --  This l must be the same as from the instance head,
               --  -XScopedTypeVariables should bring it into scope, but we are
               --  trying to avoid warnings with ghc-6.8.2 and avoid CPP
               catchLayoutMess x = do
                let m' = x `asTypeOf` (undefined :: LayoutMessages)
                ms' <- zip (repeat $ SomeMessage m') . W.integrate'
                        <$> currentStack
                return $ do guard $ not $ null ms'
                            Just $ Sublayout (I $ ms' ++ ms) defl sls

    currentStack :: X (Maybe (W.Stack Window))
    currentStack = gets (W.stack . W.workspace . W.current . windowset)

    -- | update Group to follow changes in the workspace
    updateGroup :: Ord a => Maybe (W.Stack a) -> Groups a -> Groups a
    updateGroup mst gs =
            let flatten = concatMap W.integrate . M.elems
                news = W.integrate' mst \\ flatten gs
                deads = flatten gs \\ W.integrate' mst

                uniNew = M.union (M.fromList $ map (\n -> (n,single n)) news)
                single x = W.Stack x [] []

                -- pass through a list to update/remove keys
                remDead = M.fromList . map (\w -> (W.focus w,w))
                            . mapMaybe (W.filter (`notElem` deads)) . M.elems

                -- update the current tab group's order and focus
                followFocus hs = fromMaybe hs $ do
                    f' <- W.focus `fmap` mst
                    xs <- find (elem f' . W.integrate) $ M.elems hs
                    xs' <- W.filter (`elem` W.integrate xs) =<< mst
                    return $ M.insert f' xs' $ M.delete (W.focus xs) hs

            in remDead $ uniNew $ followFocus gs

    -- | rearrange the windowset to put the groups of tabs next to eachother, so
    -- that the stack of tabs stays put.
    updateWs :: Groups Window -> X ()
    updateWs = windowsMaybe . updateWs'

    updateWs' :: Groups Window -> WindowSet -> Maybe WindowSet
    updateWs' gs ws = do
        f <- W.peek ws
        let w = W.index ws
            nes = concatMap W.integrate $ mapMaybe (flip M.lookup gs) w
            ws' = W.focusWindow f $ foldr W.insertUp (foldr W.delete' ws nes) nes
        guard $ W.index ws' /= W.index ws
        return ws'

    -- | focusWindow'. focus an element of a stack, is Nothing if that element is
    -- absent. See also 'W.focusWindow'
    focusWindow' :: (Eq a) => a -> W.Stack a -> Maybe (W.Stack a)
    focusWindow' w st = do
        guard $ not $ null $ filter (w==) $ W.integrate st
        if W.focus st == w then Just st
            else focusWindow' w $ W.focusDown' st

    -- update only when Just
    windowsMaybe :: (WindowSet -> Maybe WindowSet) -> X ()
    windowsMaybe f = do
        xst <- get
        ws <- gets windowset
        let up fws = put xst { windowset = fws }
        maybe (return ()) up $ f ws

    unfocused :: W.Stack a -> [a]
    unfocused x = W.up x ++ W.down x

    toGroups :: (Ord a) => [(a1, W.Stack a)] -> Map a (W.Stack a)
    toGroups ws = M.fromList . map (W.focus &&& id) . nubBy (on (==) W.focus)
                        $ map snd ws

    -- | restore the default layout for each group. It needs the X monad to switch
    -- the default layout to a specific one (handleMessage NextLayout)
    fromGroups :: (LayoutClass layout a, Ord k) =>
                  ([Int], layout a)
                  -> Maybe (W.Stack k)
                  -> Groups k
                  -> [(layout a, b)]
                  -> X [(Bool,(layout a, W.Stack k))]
    fromGroups (skips,defl) st gs sls = do
        defls <- mapM (iterateM nextL defl !!) skips
        return $ fromGroups' defl defls st gs (map fst sls)
            where nextL l = fromMaybe l <$> handleMessage l (SomeMessage NextLayout)
                  iterateM f = iterate (>>= f) . return

    fromGroups' :: (Ord k) => a -> [a] -> Maybe (W.Stack k) -> Groups k -> [a]
                        -> [(Bool,(a, W.Stack k))]
    fromGroups' defl defls st gs sls =
        [ (isNew,fromMaybe2 (dl, single w) (l, M.lookup w gs))
            | l <- map Just sls ++ repeat Nothing, let isNew = isNothing l
            | dl <- defls ++ repeat defl
            | w <- W.integrate' $ W.filter (`notElem` unfocs) =<< st ]
        where unfocs = unfocused =<< M.elems gs
              single w = W.Stack w [] []
              fromMaybe2 (a,b) (x,y) = (fromMaybe a x, fromMaybe b y)

    -- this would be much cleaner with some kind of data-accessor
    setStack :: Maybe (W.Stack Window) -> X ()
    setStack x = modify (\s -> s { windowset = (windowset s)
                    { W.current = (W.current $ windowset s)
                    { W.workspace = (W.workspace $ W.current $ windowset s) { W.stack = x }}}})