{-# LANGUAGE DeriveDataTypeable #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Actions.SwapPromote
-- Copyright   :  (c) 2018 Yclept Nemo
-- License     :  BSD-style (see LICENSE)
--
-- Maintainer  :
-- Stability   :  unstable
-- Portability :  unportable
--
-- Module for tracking master window history per workspace, and associated
-- functions for manipulating the stack using such history.
--
-----------------------------------------------------------------------------


module XMonad.Actions.SwapPromote
    ( -- * Usage
      -- $usage
      MasterHistory (..)
      -- * State Accessors
    , getMasterHistoryMap
    , getMasterHistoryFromTag
    , getMasterHistoryCurrent
    , getMasterHistoryFromWindow
    , modifyMasterHistoryFromTag
    , modifyMasterHistoryCurrent
      -- * Log Hook
    , masterHistoryHook
      -- * Log Hook Building Blocks
    , masterHistoryHook'
    , updateMasterHistory
      -- * Actions
    , swapPromote
    , swapPromote'
    , swapIn
    , swapIn'
    , swapHybrid
    , swapHybrid'
      -- * Action Building Blocks
    , swapApply
    , swapPromoteStack
    , swapInStack
    , swapHybridStack
      -- * List Utilities
    , cycleN
    , split
    , split'
    , merge
    , merge'
      -- * Stack Utilities
    , stackSplit
    , stackMerge
    ) where


import           XMonad
import qualified XMonad.StackSet                as W
import qualified XMonad.Util.ExtensibleState    as XS

import qualified Data.Map                       as M
import qualified Data.Set                       as S
import           Data.List
import           Data.Maybe
import           Control.Arrow
import           Control.Applicative ((<$>),(<*>))
import           Control.Monad


-- $usage
-- Given your configuration file, import this module:
--
-- > import XMonad.Actions.SwapPromote
--
-- First add 'masterHistoryHook' to your 'logHook' to track master windows per
-- workspace:
--
-- > myLogHook = otherHook >> masterHistoryHook
--
-- Then replace xmonad's default promote keybinding with 'swapPromote'':
--
-- > , ((mod1Mask, xK_Return), swapPromote' False)
--
-- Depending on your xmonad configuration or window actions the master history
-- may be empty. If this is the case you can still chain another promotion
-- function:
--
-- > import XMonad.Actions.DwmPromote
-- > , ((mod1Mask, xK_Return), whenX (swapPromote False) dwmpromote)
--
-- To be clear, this is only called when the lack of master history hindered
-- the swap and not other conditions, such as having a only a single window.
--
-- While 'swapPromote' preserves window focus, 'swapIn' preserves the focus
-- position - effectively "swapping" new windows into focus without moving the
-- zipper. A mix of both, 'swapHybrid' promotes focused non-master windows
-- while swapping windows into the focused master. This works well on layouts
-- with large masters. Both come with chainable variants, see 'swapIn'' and
-- 'swapHybrid''.
--
-- So far floating windows have been treated no differently than tiled windows
-- even though their positions are independent of the stack. Often, yanking
-- floating windows in and out of the workspace will obliterate the stack
-- history - particularly frustrating with 'XMonad.Util.Scratchpad' since it is
-- toggled so frequenty and always replaces the master window. That's why the
-- swap functions accept a boolean argument; when @True@ non-focused floating
-- windows will be ignored.
--
-- All together:
--
-- > , ((mod1Mask, xK_Return), whenX (swapHybrid True) dwmpromote)


-- | Mapping from workspace tag to master history list. The current master is
-- the head of the list, the previous master the second element, and so on.
-- Without history, the list is empty.
newtype MasterHistory = MasterHistory
    { getMasterHistory :: M.Map WorkspaceId [Window]
    } deriving (Read,Show,Typeable)

instance ExtensionClass MasterHistory where
    initialValue = MasterHistory M.empty

-- | Return the master history map from the state.
getMasterHistoryMap :: X (M.Map WorkspaceId [Window])
getMasterHistoryMap = XS.gets getMasterHistory

-- | Return the master history list of a given tag. The master history list may
-- be empty. An invalid tag will also result in an empty list.
getMasterHistoryFromTag :: WorkspaceId -> X [Window]
getMasterHistoryFromTag t = M.findWithDefault [] t <$> getMasterHistoryMap

-- | Return the master history list of the current workspace.
getMasterHistoryCurrent :: X [Window]
getMasterHistoryCurrent =   gets (W.currentTag . windowset)
                        >>= getMasterHistoryFromTag

-- | Return the master history list of the workspace containing the given
-- window. Return an empty list if the window is not in the stackset.
getMasterHistoryFromWindow :: Window -> X [Window]
getMasterHistoryFromWindow w =   gets (W.findTag w . windowset)
                             >>= maybe (return []) getMasterHistoryFromTag

-- | Modify the master history list of a given workspace, or the empty list of
-- no such workspace is mapped. The result is then re-inserted into the master
-- history map.
modifyMasterHistoryFromTag :: WorkspaceId -> ([Window] -> [Window]) -> X ()
modifyMasterHistoryFromTag t f = XS.modify $ \(MasterHistory m) ->
    let l = M.findWithDefault [] t m
    in  MasterHistory $ M.insert t (f l) m

-- | Modify the master history list of the current workspace. While the current
-- workspace is guaranteed to exist; its master history may not. For more
-- information see 'modifyMasterHistoryFromTag'.
modifyMasterHistoryCurrent :: ([Window] -> [Window]) -> X ()
modifyMasterHistoryCurrent f =   gets (W.currentTag . windowset)
                             >>= flip modifyMasterHistoryFromTag f

-- | A 'logHook' to update the master history mapping. Non-existent workspaces
-- are removed, and the master history list for the current workspaces is
-- updated. See 'masterHistoryHook''.
masterHistoryHook :: X ()
masterHistoryHook = masterHistoryHook' True updateMasterHistory

-- | Backend for 'masterHistoryHook'.
masterHistoryHook' :: Bool
                        -- ^ If @True@, remove non-existent workspaces.
                   -> ([Window] -> [Window] -> [Window])
                        -- ^ Function used to update the master history list of
                        -- the current workspace. First argument is the master
                        -- history, second is the integrated stack.  See
                        -- 'updateMasterHistory' for more details.
                   -> X ()
masterHistoryHook' removeWorkspaces historyModifier = do
    wset <- gets windowset
    let W.Workspace wid _ mst = W.workspace . W.current $ wset
        tags = map W.tag $ W.workspaces wset
        st = W.integrate' mst
    XS.modify $ \(MasterHistory mm) ->
        let mm' = if removeWorkspaces
                  then restrictKeys mm $ S.fromList tags
                  else mm
            ms  = M.findWithDefault [] wid mm'
            ms' = historyModifier ms st
        in  MasterHistory $ M.insert wid ms' mm'

-- | Less efficient version of 'M.restrictKeys'. Given broader eventual
-- adoption, replace this with 'M.restrictKeys'.
restrictKeys :: Ord k => M.Map k a -> S.Set k -> M.Map k a
restrictKeys m s = M.filterWithKey (\k _ -> k `S.member` s) m

-- | Given the current master history list and an integrated stack, return the
-- new master history list. The current master is either moved (if it exists
-- within the history) or added to the head of the list, and all missing (i.e.
-- closed) windows are removed.
updateMasterHistory :: [Window] -- ^ The master history list.
                    -> [Window] -- ^ The integrated stack.
                    -> [Window]
updateMasterHistory _  []       = []
updateMasterHistory ms ws@(w:_) = (w : delete w ms) `intersect` ws

-- | Wrap 'swapPromoteStack'; see also 'swapApply'.
swapPromote :: Bool -> X Bool
swapPromote = flip swapApply swapPromoteStack

-- | Like 'swapPromote'' but discard the result.
swapPromote' :: Bool -> X ()
swapPromote' = void . swapPromote

-- | Wrap 'swapInStack'; see also 'swapApply'.
swapIn :: Bool -> X Bool
swapIn = flip swapApply swapInStack

-- | Like 'swapIn'' but discard the result.
swapIn' :: Bool -> X ()
swapIn' = void . swapIn

-- | Wrap 'swapHybridStack'; see also 'swapApply'.
swapHybrid :: Bool -> X Bool
swapHybrid = flip swapApply swapHybridStack

-- | Like 'swapHybrid'' but discard the result.
swapHybrid' :: Bool -> X ()
swapHybrid' = void . swapHybrid

-- | Apply the given master history stack modifier to the current stack. If
-- given @True@, all non-focused floating windows will be ignored. Return
-- @True@ if insufficient history; if so use 'whenX' to sequence a backup
-- promotion function.
swapApply :: Bool
          -> (Maybe Window -> W.Stack Window -> (Bool,W.Stack Window))
          -> X Bool
swapApply ignoreFloats swapFunction = do
    fl <- gets $ W.floating . windowset
    st <- gets $ W.stack . W.workspace . W.current . windowset
    ch <- getMasterHistoryCurrent
    let swapApply' s1 =
            let fl' = if ignoreFloats then M.keysSet fl else S.empty
                ff = (||) <$> (`S.notMember` fl') <*> (== W.focus s1)
                fh = filter ff ch
                pm = listToMaybe . drop 1 $ fh
                (r,s2) = stackSplit s1 fl' :: ([(Int,Window)],W.Stack Window)
                (b,s3) = swapFunction pm s2
                s4 = stackMerge s3 r
                mh = let w = head . W.integrate $ s3
                     in  const $ w : delete w ch
            in (b,Just s4,mh)
        (x,y,z) = maybe (False,Nothing,id) swapApply' st
    -- Any floating master windows will be added to the history when 'windows'
    -- calls the log hook.
    modifyMasterHistoryCurrent z
    windows $ W.modify Nothing . const $ y
    return x

-- | If the focused window is the master window and there is no previous
-- master, do nothing. Otherwise swap the master with the previous master. If
-- the focused window is not the master window, swap it with the master window.
-- In either case focus follows the original window, i.e. the focused window
-- does not change, only its position.
--
-- The first argument is the previous master (which may not exist), the second
-- a window stack. Return @True@ if the master history hindered the swap; the
-- history is either empty or out-of-sync. Though the latter shouldn't happen
-- this function never changes the stack under such circumstances.
swapPromoteStack :: Maybe Window -> W.Stack Window -> (Bool,W.Stack Window)
swapPromoteStack _         st@(W.Stack _x [] []) = (False,st)
swapPromoteStack Nothing   st@(W.Stack _x [] _r) = (True,st)
swapPromoteStack (Just pm)    (W.Stack  x []  r) =
    let (r',l') = (reverse *** cycleN 1) $ span (/= pm) $ reverse r
        st'     = W.Stack x l' r'
        b       = null l'
    in  (b,st')
swapPromoteStack _            (W.Stack  x l   r) =
    let r'  = (++ r) . cycleN 1 . reverse $ l
        st' = W.Stack x [] r'
    in  (False,st')

-- | Perform the same swap as 'swapPromoteStack'. However the new window
-- receives the focus; it appears to "swap into" the position of the original
-- window. Under this model focus follows stack position and the zipper does
-- not move.
--
-- See 'swapPromoteStack' for more details regarding the parameters.
swapInStack :: Maybe Window -> W.Stack Window -> (Bool,W.Stack Window)
swapInStack _         st@(W.Stack _x [] []) = (False,st)
swapInStack Nothing   st@(W.Stack _x [] _r) = (True,st)
swapInStack (Just pm)    (W.Stack  x []  r) =
    let (x',r') = case span (/= pm) r of
            (__,[]) -> (x,r)
            (sl,sr) -> (pm,sl ++ x : drop 1 sr)
        st'     = W.Stack x' [] r'
        b       = x' == x
    in  (b,st')
swapInStack _            (W.Stack  x l   r) =
    let l'  = init l ++ [x]
        x'  = last l
        st' = W.Stack x' l' r
    in  (False,st')

-- | If the focused window is the master window, use 'swapInStack'. Otherwise use
-- 'swapPromoteStack'.
--
-- See 'swapPromoteStack' for more details regarding the parameters.
swapHybridStack :: Maybe Window -> W.Stack Window -> (Bool,W.Stack Window)
swapHybridStack m st@(W.Stack _ [] _) = swapInStack m st
swapHybridStack m st                  = swapPromoteStack m st

-- | Cycle a list by the given count. If positive, cycle to the left. If
-- negative, cycle to the right:
--
-- >>> cycleN 2 [1,2,3,4,5]
-- [3,4,5,1,2]
-- >>> cycleN (-2) [1,2,3,4,5]
-- [4,5,1,2,3]
cycleN :: Int -> [a] -> [a]
cycleN n ls =
    let l = length ls
    in  take l $ drop (n `mod` l) $ cycle ls

-- | Wrap 'split'' with an initial index of @0@, discarding the list's length.
split :: (Num a, Enum a) => (b -> Bool) -> [b] -> ([(a,b)],[b])
split p l =
    let (_,ys,ns) = split' p 0 l
    in  (ys,ns)

-- | Given a predicate, an initial index and a list, return a tuple containing:
--
--  * List length.
--  * Indexed list of elements which satisfy the predicate. An indexed element
--    is a tuple containing the element index (offset by the initial index) and
--    the element.
--  * List of elements which do not satisfy the predicate.
--
-- The initial index and length of the list simplify chaining calls to this
-- function, such as for zippers of lists.
split' :: (Num a, Enum a) => (b -> Bool) -> a -> [b] -> (a,[(a,b)],[b])
split' p i l =
    let accumulate e (c,ys,ns) = if p (snd e)
            then (c+1,e:ys,ns)
            else (c+1,ys,e:ns)
        (c',ys',ns') = foldr accumulate (0,[],[]) $ zip [i..] l
    in  (c',ys',snd . unzip $ ns')

-- | Wrap 'merge'' with an initial virtual index of @0@. Return only the
-- unindexed list with elements from the leftover indexed list appended.
merge :: (Ord a, Num a) => [(a,b)] -> [b] -> [b]
merge il ul =
    let (_,il',ul') = merge' 0 il ul
    in  ul' ++ map snd il'

-- | Inverse of 'split'. Merge an indexed list with an unindexed list (see
-- 'split''). Given a virtual index, an indexed list and an unindexed list,
-- return a tuple containing:
--
--  * Virtual index /after/ the unindexed list
--  * Remainder of the indexed list
--  * Merged unindexed list
--
-- If the indexed list is empty, this functions consumes the entire unindexed
-- list. If the unindexed list is empty, this function consumes only adjacent
-- indexed elements. For example, @[(10,"ten"),(12,"twelve")]@ implies missing
-- unindexed elements and so once @(10,"ten")@ is consumed this function
-- concludes.
--
-- The indexed list is assumed to have been created by 'split'' and not checked
-- for correctness. Indices are assumed to be ascending, i.e.
-- > [(1,"one"),(2,"two"),(4,"four")]
--
-- The initial and final virtual indices simplify chaining calls to the this
-- function, as as for zippers of lists. Positive values shift the unindexed
-- list towards the tail, as if preceded by that many elements.
merge' :: (Ord a, Num a) => a -> [(a,b)] -> [b] -> (a,[(a,b)],[b])
merge' i il@((j,a):ps) ul@(b:bs) = if j <= i
    then let (x,y,z) = merge' (i+1) ps ul
         in  (x,y,a:z)
    else let (x,y,z) = merge' (i+1) il bs
         in  (x,y,b:z)
merge' i [] (b:bs) =
         let (x,y,z) = merge' (i+1) [] bs
         in  (x,y,b:z)
merge' i il@((j,a):ps) [] = if j <= i
    then let (x,y,z) = merge' (i+1) ps []
         in  (x,y,a:z)
    else (i,il,[])
merge' i [] [] =
         (i,[],[])

-- | Remove all elements of the set from the stack. Skip the currently focused
-- member. Return an indexed list of excluded elements and the modified stack.
-- Use 'stackMerge' to re-insert the elements using this list.
stackSplit :: (Num a, Enum a, Ord b) => W.Stack b -> S.Set b -> ([(a,b)],W.Stack b)
stackSplit (W.Stack x l r) s =
    let (c,fl,tl) = split' (`S.member` s) 0 (reverse l)
        (_,fr,tr) = split' (`S.member` s) (c+1) r
    in  (fl++fr,W.Stack x (reverse tl) tr)

-- | Inverse of 'stackSplit'. Given a list of elements and their original
-- indices, re-insert the elements into these same positions within the stack.
-- Skip the currently focused member. Works best if the stack's length hasn't
-- changed, though if shorter any leftover elements will be tacked on.
stackMerge :: (Ord a, Num a) => W.Stack b -> [(a,b)] -> W.Stack b
stackMerge (W.Stack x l r) il =
    let (i,il1,l') = merge' 0 il (reverse l)
        (_,il2,r') = merge' (i+1) il1 r
    in  W.Stack x (reverse l') (r' ++ map snd il2)