    -----------------------------------------------------------------------------
    -- |
    -- Module       : XMonad.Actions.TagWindows
    -- Copyright    : (c) Karsten Schoelzel <kuser@gmx.de>
    -- License      : BSD
    --
    -- Maintainer   : Karsten Schoelzel <kuser@gmx.de>
    -- Stability    : unstable
    -- Portability  : unportable
    --
    -- Functions for tagging windows and selecting them by tags.
    -----------------------------------------------------------------------------

    module XMonad.Actions.TagWindows (
                     -- * Usage
                     -- $usage
                     addTag, delTag, unTag,
                     setTags, getTags, hasTag,
                     withTaggedP,  withTaggedGlobalP, withFocusedP,
                     withTagged ,  withTaggedGlobal ,
                     focusUpTagged,   focusUpTaggedGlobal,
                     focusDownTagged, focusDownTaggedGlobal,
                     shiftHere, shiftToScreen,
                     tagPrompt,
                     tagDelPrompt,
                     TagPrompt,
                     ) where

    import Data.List (nub,sortBy)
    import Control.Monad
    import Control.Exception as E

    import XMonad.StackSet hiding (filter)

    import XMonad.Prompt
    import XMonad hiding (workspaces)

    econst :: Monad m => a -> IOException -> m a
    econst = const . return

    -- $usage
    --
    -- To use window tags, import this module into your @~\/.xmonad\/xmonad.hs@:
    --
    -- > import XMonad.Actions.TagWindows
    -- > import XMonad.Prompt    -- to use tagPrompt
    --
    -- and add keybindings such as the following:
    --
    -- >   , ((modm,                 xK_f  ), withFocused (addTag "abc"))
    -- >   , ((modm .|. controlMask, xK_f  ), withFocused (delTag "abc"))
    -- >   , ((modm .|. shiftMask,   xK_f  ), withTaggedGlobalP "abc" W.sink)
    -- >   , ((modm,                 xK_d  ), withTaggedP "abc" (W.shiftWin "2"))
    -- >   , ((modm .|. shiftMask,   xK_d  ), withTaggedGlobalP "abc" shiftHere)
    -- >   , ((modm .|. controlMask, xK_d  ), focusUpTaggedGlobal "abc")
    -- >   , ((modm,                 xK_g  ), tagPrompt defaultXPConfig (\s -> withFocused (addTag s)))
    -- >   , ((modm .|. controlMask, xK_g  ), tagDelPrompt defaultXPConfig)
    -- >   , ((modm .|. shiftMask,   xK_g  ), tagPrompt defaultXPConfig (\s -> withTaggedGlobal s float))
    -- >   , ((modWinMask,                xK_g  ), tagPrompt defaultXPConfig (\s -> withTaggedP s (W.shiftWin "2")))
    -- >   , ((modWinMask .|. shiftMask,  xK_g  ), tagPrompt defaultXPConfig (\s -> withTaggedGlobalP s shiftHere))
    -- >   , ((modWinMask .|. controlMask, xK_g ), tagPrompt defaultXPConfig (\s -> focusUpTaggedGlobal s))
    --
    -- NOTE: Tags are saved as space separated strings and split with
    --       'unwords'. Thus if you add a tag \"a b\" the window will have
    --       the tags \"a\" and \"b\" but not \"a b\".
    --
    -- For detailed instructions on editing your key bindings, see
    -- "XMonad.Doc.Extending#Editing_key_bindings".

    -- | set multiple tags for a window at once (overriding any previous tags)
    setTags :: [String] -> Window -> X ()
    setTags = setTag . unwords

    -- | set a tag for a window (overriding any previous tags)
    --   writes it to the \"_XMONAD_TAGS\" window property
    setTag :: String -> Window -> X ()
    setTag s w = withDisplay $ \d ->
        io $ internAtom d "_XMONAD_TAGS" False >>= setTextProperty d w s

    -- | read all tags of a window
    --   reads from the \"_XMONAD_TAGS\" window property
    getTags :: Window -> X [String]
    getTags w = withDisplay $ \d ->
        io $ E.catch (internAtom d "_XMONAD_TAGS" False >>=
                    getTextProperty d w >>=
                    wcTextPropertyToTextList d)
                   (econst [[]])
        >>= return . words . unwords

    -- | check a window for the given tag
    hasTag :: String -> Window -> X Bool
    hasTag s w = (s `elem`) `fmap` getTags w

    -- | add a tag to the existing ones
    addTag :: String -> Window -> X ()
    addTag s w = do
        tags <- getTags w
        if (s `notElem` tags) then setTags (s:tags) w else return ()

    -- | remove a tag from a window, if it exists
    delTag :: String -> Window -> X ()
    delTag s w = do
        tags <- getTags w
        setTags (filter (/= s) tags) w

    -- | remove all tags
    unTag :: Window -> X ()
    unTag = setTag ""

    -- | Move the focus in a group of windows, which share the same given tag.
    --   The Global variants move through all workspaces, whereas the other
    --   ones operate only on the current workspace
    focusUpTagged, focusDownTagged, focusUpTaggedGlobal, focusDownTaggedGlobal :: String -> X ()
    focusUpTagged         = focusTagged' (reverse . wsToList)
    focusDownTagged       = focusTagged' wsToList
    focusUpTaggedGlobal   = focusTagged' (reverse . wsToListGlobal)
    focusDownTaggedGlobal = focusTagged' wsToListGlobal

    wsToList :: (Ord i) => StackSet i l a s sd -> [a]
    wsToList ws = crs ++ cls
        where
            (crs, cls) = (cms down, cms (reverse . up))
            cms f = maybe [] f (stack . workspace . current $ ws)

    wsToListGlobal :: (Ord i) => StackSet i l a s sd -> [a]
    wsToListGlobal ws = concat ([crs] ++ rws ++ lws ++ [cls])
        where
            curtag = currentTag ws
            (crs, cls) = (cms down, cms (reverse . up))
            cms f = maybe [] f (stack . workspace . current $ ws)
            (lws, rws) = (mws (<), mws (>))
            mws cmp = map (integrate' . stack) . sortByTag . filter (\w -> tag w `cmp` curtag) . workspaces $ ws
            sortByTag = sortBy (\x y -> compare (tag x) (tag y))

    focusTagged' :: (WindowSet -> [Window]) -> String -> X ()
    focusTagged' wl t = gets windowset >>= findM (hasTag t) . wl >>=
        maybe (return ()) (windows . focusWindow)

    findM :: (Monad m) => (a -> m Bool) -> [a] -> m (Maybe a)
    findM _ []      = return Nothing
    findM p (x:xs)  = do b <- p x
                         if b then return (Just x) else findM p xs

    -- | apply a pure function to windows with a tag
    withTaggedP, withTaggedGlobalP :: String -> (Window -> WindowSet -> WindowSet) -> X ()
    withTaggedP       t f = withTagged'       t (winMap f)
    withTaggedGlobalP t f = withTaggedGlobal' t (winMap f)

    winMap :: (Window -> WindowSet -> WindowSet) -> [Window] -> X ()
    winMap f tw = when (tw /= []) (windows $ foldl1 (.) (map f tw))

    withTagged, withTaggedGlobal :: String -> (Window -> X ()) -> X ()
    withTagged       t f = withTagged'       t (mapM_ f)
    withTaggedGlobal t f = withTaggedGlobal' t (mapM_ f)

    withTagged' :: String -> ([Window] -> X ()) -> X ()
    withTagged' t m = gets windowset >>= filterM (hasTag t) . index >>= m

    withTaggedGlobal' :: String -> ([Window] -> X ()) -> X ()
    withTaggedGlobal' t m = gets windowset >>=
        filterM (hasTag t) . concat . map (integrate' . stack) . workspaces >>= m

    withFocusedP :: (Window -> WindowSet -> WindowSet) -> X ()
    withFocusedP f = withFocused $ windows . f

    shiftHere :: (Ord a, Eq s, Eq i) => a -> StackSet i l a s sd -> StackSet i l a s sd
    shiftHere w s = shiftWin (currentTag s) w s

    shiftToScreen :: (Ord a, Eq s, Eq i) => s -> a -> StackSet i l a s sd -> StackSet i l a s sd
    shiftToScreen sid w s = case filter (\m -> sid /= screen m) ((current s):(visible s)) of
                                    []      -> s
                                    (t:_)   -> shiftWin (tag . workspace $ t) w s

    data TagPrompt = TagPrompt

    instance XPrompt TagPrompt where
        showXPrompt TagPrompt = "Select Tag:   "

    tagPrompt :: XPConfig -> (String -> X ()) -> X ()
    tagPrompt c f = do
      sc <- tagComplList
      mkXPrompt TagPrompt c (mkComplFunFromList' sc) f

    tagComplList :: X [String]
    tagComplList = gets (concat . map (integrate' . stack) . workspaces . windowset) >>=
        mapM getTags >>=
        return . nub . concat

    tagDelPrompt :: XPConfig -> X ()
    tagDelPrompt c = do
      sc <- tagDelComplList
      if (sc /= [])
        then mkXPrompt TagPrompt c (mkComplFunFromList' sc) (\s -> withFocused (delTag s))
        else return ()

    tagDelComplList :: X [String]
    tagDelComplList = gets windowset >>= maybe (return []) getTags . peek