    {-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module       : XMonad.Actions.WorkspaceCursors
    -- Copyright    : (c) 2009 Adam Vogt <vogt.adam@gmail.com>
    -- License      : BSD
    --
    -- Maintainer   : Adam Vogt
    -- Stability    : unstable
    -- Portability  : unportable
    --
    -- Like "XMonad.Actions.Plane" for an arbitrary number of dimensions.
    -----------------------------------------------------------------------------

    module XMonad.Actions.WorkspaceCursors
        (
        -- * Usage
        -- $usage

         focusDepth
        ,makeCursors
        ,toList
        ,workspaceCursors

        ,WorkspaceCursors
        ,getFocus

        -- * Modifying the focus
        ,modifyLayer
        ,modifyLayer'
        ,shiftModifyLayer,shiftLayer

        -- * Functions to pass to 'modifyLayer'
        ,focusNth'
        ,noWrapUp,noWrapDown

        -- * Todo
        -- $todo
        ) where

    import qualified XMonad.StackSet as W

    import XMonad.Actions.FocusNth(focusNth')
    import XMonad.Layout.LayoutModifier(ModifiedLayout(..),
                                        LayoutModifier(handleMess, redoLayout))
    import XMonad(Typeable, Message, WorkspaceId, X, XState(windowset),
                  fromMessage, sendMessage, windows, gets)
    import Control.Monad((<=<), guard, liftM, liftM2, when)
    import Control.Applicative((<$>))
    import Data.Foldable(Foldable(foldMap), toList)
    import Data.Maybe(fromJust, listToMaybe)
    import Data.Monoid(Monoid(mappend, mconcat))
    import Data.Traversable(sequenceA)

    -- $usage
    --
    -- Here is an example config:
    --
    -- > import XMonad
    -- > import XMonad.Actions.WorkspaceCursors
    -- > import XMonad.Hooks.DynamicLog
    -- > import XMonad.Util.EZConfig
    -- > import qualified XMonad.StackSet as W
    -- >
    -- > main = do
    -- >     x <- xmobar conf
    -- >     xmonad x
    -- >
    -- > conf = additionalKeysP defaultConfig
    -- >        { layoutHook = workspaceCursors myCursors $ layoutHook defaultConfig
    -- >        , workspaces = toList myCursors } $
    -- >        [("M-"++shift++control++[k], f direction depth)
    -- >          | (f,shift) <- zip [modifyLayer,shiftModifyLayer] ["","S-"]
    -- >          , (direction,control) <- zip [W.focusUp',W.focusDown'] ["C-",""]
    -- >          , (depth,k) <- zip (reverse [1..focusDepth myCursors]) "asdf"]
    -- >        ++ moreKeybindings
    -- >
    -- > moreKeybindings = []
    -- >
    -- > myCursors = makeCursors $ map (map (\x -> [x])) [ "1234", "abc", "xyz"]
    -- > -- myCursors = makeCursors [["wsA","wsB","wsC"],["-alpha-","-beta-","-gamma-"],["x","y"]]

    -- $todo
    --
    -- * Find and document how to raise the allowable length of arguments:
    --   restoring xmonad's state results in: @xmonad: executeFile: resource
    --   exhausted (Argument list too long)@ when you specify more than about 50
    --   workspaces. Or change it such that workspaces are created when you try to
    --   view it.
    --
    -- * Function for pretty printing for DynamicLog that groups workspaces by
    -- common prefixes
    --
    -- * Examples of adding workspaces to the cursors, having them appear multiple
    --   times for being able to show jumping to some n'th multiple workspace

    -- | makeCursors requires a nonempty string, and each sublist must be nonempty
    makeCursors ::  [[String]] -> Cursors String
    makeCursors [] = error "Workspace Cursors cannot be empty"
    makeCursors a = concat . reverse <$> foldl addDim x xs
        where x = end $ map return $ head a
              xs = map (map return) $ tail a
              -- this could probably be simplified, but this true:
              -- toList . makeCursors == map (concat . reverse) . sequence . reverse . map (map (:[]))
              -- the strange order is used because it makes the regular M-1..9
              -- bindings change the prefixes first

    addDim ::  (Monoid a) => Cursors a -> [a] -> Cursors a
    addDim prev prefixes = Cons . fromJust . W.differentiate
                $ map ((<$> prev) . mappend) prefixes

    end :: [a] -> Cursors a
    end = Cons . fromJust . W.differentiate . map End

    data Cursors a
        = Cons (W.Stack (Cursors a))
        | End a deriving (Eq,Show,Read,Typeable)

    instance Foldable Cursors where
        foldMap f (End x) = f x
        foldMap f (Cons (W.Stack x y z)) = foldMap f x `mappend` mconcat (map (foldMap f) $ reverse y ++ z)

    instance Functor Cursors where
        fmap f (End a) = End $ f a
        fmap f (Cons (W.Stack x y z)) = Cons $ W.Stack (fmap f x) (fmap (fmap f) y) (fmap (fmap f) z)

    changeFocus ::  (Cursors t -> Bool) -> Cursors t -> [Cursors t]
    changeFocus p (Cons x) = do
        choose <- chFocus p x
        foc    <- changeFocus p $ W.focus choose
        return . Cons $ choose { W.focus = foc }
    changeFocus p x = guard (p x) >> return x

    chFocus :: (a -> Bool) -> W.Stack a -> [W.Stack a]
    chFocus p st = filter (p . W.focus) $ zipWith const (iterate W.focusDown' st) (W.integrate st)

    getFocus ::  Cursors b -> b
    getFocus (Cons x) = getFocus $ W.focus x
    getFocus (End x) = x

    -- This could be made more efficient, if the fact that the suffixes are grouped
    focusTo ::  (Eq t) => t -> Cursors t -> Maybe (Cursors t)
    focusTo x = listToMaybe . filter ((x==) . getFocus) . changeFocus (const True)

    -- | non-wrapping version of 'W.focusUp''
    noWrapUp ::  W.Stack t -> W.Stack t
    noWrapUp (W.Stack t (l:ls) rs) = W.Stack l ls (t:rs)
    noWrapUp x@(W.Stack _ []   _ ) = x

    -- | non-wrapping version of 'W.focusDown''
    noWrapDown ::  W.Stack t -> W.Stack t
    noWrapDown = reverseStack . noWrapUp . reverseStack
        where reverseStack (W.Stack t ls rs) = W.Stack t rs ls

    focusDepth ::  Cursors t -> Int
    focusDepth (Cons x) = 1 + focusDepth (W.focus x)
    focusDepth (End  _) = 0

    descend :: Monad m =>(W.Stack (Cursors a) -> m (W.Stack (Cursors a)))-> Int-> Cursors a-> m (Cursors a)
    descend f 1 (Cons x) = Cons `liftM` f x
    descend f n (Cons x) | n > 1 = liftM Cons $ descend f (pred n) `onFocus` x
    descend _ _ x = return x

    onFocus :: (Monad m) => (a1 -> m a1) -> W.Stack a1 -> m (W.Stack a1)
    onFocus f st = (\x -> st { W.focus = x}) `liftM` f (W.focus st)

    -- | @modifyLayer@ is used to change the focus at a given depth
    modifyLayer :: (W.Stack (Cursors String) -> W.Stack (Cursors String)) -> Int -> X ()
    modifyLayer f depth = modifyCursors (descend (return . f) depth)

    -- | @shiftModifyLayer@ is the same as 'modifyLayer', but also shifts the
    -- currently focused window to the new workspace
    shiftModifyLayer :: (W.Stack (Cursors String) -> W.Stack (Cursors WorkspaceId))-> Int-> X ()
    shiftModifyLayer f = modifyLayer' $ \st -> do
        let st' = f st
        windows $ W.shift $ getFocus (Cons st')
        return st'

    -- | @shiftLayer@ is the same as 'shiftModifyLayer', but the focus remains on
    -- the current workspace.
    shiftLayer :: (W.Stack (Cursors String) -> W.Stack (Cursors WorkspaceId))-> Int-> X ()
    shiftLayer f = modifyLayer' $ \st -> do
        windows $ W.shift $ getFocus $ Cons $ f st
        return st

    -- | example usages are 'shiftLayer' and 'shiftModifyLayer'
    modifyLayer' :: (W.Stack (Cursors String) -> X (W.Stack (Cursors String))) -> Int -> X ()
    modifyLayer' f depth = modifyCursors (descend f depth)

    modifyCursors ::  (Cursors String -> X (Cursors String)) -> X ()
    modifyCursors = sendMessage . ChangeCursors . (liftM2 (>>) updateXMD return <=<)

    data WorkspaceCursors a = WorkspaceCursors (Cursors String)
        deriving (Typeable,Read,Show)

    -- | The state is stored in the 'WorkspaceCursors' layout modifier. Put this as
    -- your outermost modifier, unless you want different cursors at different
    -- times (using "XMonad.Layout.MultiToggle")
    workspaceCursors :: Cursors String -> l a -> ModifiedLayout WorkspaceCursors l a
    workspaceCursors = ModifiedLayout . WorkspaceCursors

    data ChangeCursors = ChangeCursors { unWrap :: Cursors String -> X (Cursors String) }
        deriving (Typeable)

    instance Message ChangeCursors

    updateXMD ::  Cursors WorkspaceId -> X ()
    updateXMD cs = do
        changed <- gets $ (getFocus cs /=) . W.currentTag . windowset
        when changed $ windows $ W.greedyView $ getFocus cs

    instance LayoutModifier WorkspaceCursors a where
        redoLayout (WorkspaceCursors cs) _ _ arrs = do
            cws <- gets $ W.currentTag . windowset
            return (arrs,WorkspaceCursors <$> focusTo cws cs)

        handleMess (WorkspaceCursors cs) m =
            sequenceA $ fmap WorkspaceCursors . ($ cs) . unWrap <$> fromMessage m