    {-# OPTIONS_GHC -fno-warn-orphans #-}
    {-# LANGUAGE ExistentialQuantification, FlexibleContexts, FlexibleInstances, StandaloneDeriving #-}
    --------------------------------------------------------------------
    -- |
    -- Module      :  XMonad.Util.NamedActions
    -- Copyright   :  2009 Adam Vogt <vogt.adam@gmail.com>
    -- License     :  BSD3-style (see LICENSE)
    --
    -- Maintainer  :  Adam Vogt <vogt.adam@gmail.com>
    -- Stability   :  unstable
    -- Portability :  unportable
    --
    -- A wrapper for keybinding configuration that can list the available
    -- keybindings.
    --------------------------------------------------------------------

    module XMonad.Util.NamedActions (
        -- * Usage:
        -- $usage
        sendMessage',
        spawn',
        submapName,
        addDescrKeys,
        xMessage,

        showKmSimple,
        showKm,

        noName,
        oneName,
        addName,

        separator,
        subtitle,

        (^++^),

        NamedAction(..),
        HasName,
        defaultKeysDescr
        ) where

    import XMonad.Actions.Submap(submap)
    import XMonad
    import System.Posix.Process(executeFile)
    import Control.Arrow(Arrow((&&&), second, (***)))
    import Data.Bits(Bits((.&.), complement))
    import Data.List (groupBy)
    import System.Exit(ExitCode(ExitSuccess), exitWith)

    import Control.Applicative ((<*>))

    import qualified Data.Map as M
    import qualified XMonad.StackSet as W

    -- $usage
    -- Here is an example config that demonstrates the usage of 'sendMessage'',
    -- 'mkNamedKeymap', 'addDescrKeys', and '^++^'
    --
    -- > import XMonad
    -- > import XMonad.Util.NamedActions
    -- > import XMonad.Util.EZConfig
    -- >
    -- > main = xmonad $ addDescrKeys ((mod4Mask, xK_F1), xMessage) myKeys
    -- >                    defaultConfig { modMask = mod4Mask }
    -- >
    -- > myKeys c = (subtitle "Custom Keys":) $ mkNamedKeymap c $
    -- >    [("M-x a", addName "useless message" $ spawn "xmessage foo"),
    -- >     ("M-c", sendMessage' Expand)]
    -- >     ^++^
    -- >    [("<XF86AudioPlay>", spawn "mpc toggle" :: X ()),
    -- >     ("<XF86AudioNext>", spawn "mpc next")]
    --
    -- Using '^++^', you can combine bindings whose actions are @X ()@
    -- as well as actions that have descriptions. However you cannot mix the two in
    -- a single list, unless each is prefixed with 'addName' or 'noName'.
    --
    -- If you don't like EZConfig, you can still use '^++^' with the basic XMonad
    -- keybinding configuration too.
    --
    -- Also note the unfortunate necessity of a type annotation, since 'spawn' is
    -- too general.

    -- TODO: squeeze titles that have no entries (consider titles containing \n)
    --
    -- Output to Multiple columns
    --
    -- Devin Mullin's suggestions:
    --
    -- Reduce redundancy wrt mkNamedSubmaps, mkSubmaps and mkNamedKeymap to have a
    -- HasName context (and leave mkKeymap as a specific case of it?)
    --    Currently kept separate to aid error messages, common lines factored out
    --
    -- Suggestions for UI:
    --
    -- - An IO () -> IO () that wraps the main xmonad action and wrests control
    --   from it if the user asks for --keys.
    --
    -- Just a separate binary: keep this as the only way to show keys for simplicity
    --
    -- - An X () that toggles a cute little overlay like the ? window for gmail
    --   and reader.
    --
    -- Add dzen binding

    deriving instance Show XMonad.Resize
    deriving instance Show XMonad.IncMasterN

    -- | 'sendMessage' but add a description that is @show message@. Note that not
    -- all messages have show instances.
    sendMessage' :: (Message a, Show a) => a -> NamedAction
    sendMessage' x = NamedAction $ (XMonad.sendMessage x,show x)

    -- | 'spawn' but the description is the string passed
    spawn' :: String -> NamedAction
    spawn' x = addName x $ spawn x

    class HasName a where
        showName :: a -> [String]
        showName = const [""]
        getAction :: a -> X ()

    instance HasName (X ()) where
        getAction = id

    instance HasName (IO ()) where
        getAction = io

    instance HasName [Char] where
        getAction _ = return ()
        showName = (:[])

    instance HasName (X (),String) where
        showName = (:[]) . snd
        getAction = fst

    instance HasName (X (),[String]) where
        showName = snd
        getAction = fst

    -- show only the outermost description
    instance HasName (NamedAction,String) where
        showName = (:[]) . snd
        getAction = getAction . fst

    instance HasName NamedAction where
        showName (NamedAction x) = showName x
        getAction (NamedAction x) = getAction x

    -- | An existential wrapper so that different types can be combined in lists,
    -- and maps
    data NamedAction = forall a. HasName a => NamedAction a

    -- | 'submap', but propagate the descriptions of the actions. Does this belong
    -- in "XMonad.Actions.Submap"?
    submapName :: (HasName a) => [((KeyMask, KeySym), a)] -> NamedAction
    submapName = NamedAction . (submap . M.map getAction . M.fromList &&& showKm)
                    . map (second NamedAction)

    -- | Combine keymap lists with actions that may or may not have names
    (^++^) :: (HasName b, HasName b1) =>
         [(d, b)] -> [(d, b1)] -> [(d, NamedAction)]
    a ^++^ b = map (second NamedAction) a ++ map (second NamedAction) b

    -- | Or allow another lookup table?
    modToString :: KeyMask -> String
    modToString mask = concatMap (++"-") $ filter (not . null)
                    $ map (uncurry pick)
                    [(mod1Mask, "M1")
                    ,(mod2Mask, "M2")
                    ,(mod3Mask, "M3")
                    ,(mod4Mask, "M4")
                    ,(mod5Mask, "M5")
                    ,(controlMask, "C")
                    ,(shiftMask,"Shift")]
        where pick m str = if m .&. complement mask == 0 then str else ""

    keyToString :: (KeyMask, KeySym) -> [Char]
    keyToString = uncurry (++) . (modToString *** keysymToString)

    showKmSimple :: [((KeyMask, KeySym), NamedAction)] -> [[Char]]
    showKmSimple = concatMap (\(k,e) -> if snd k == 0 then "":showName e else map ((keyToString k ++) . smartSpace) $ showName e)

    smartSpace :: String -> String
    smartSpace [] = []
    smartSpace xs = ' ':xs

    _test :: String
    _test = unlines $ showKm $ defaultKeysDescr XMonad.defaultConfig { XMonad.layoutHook = XMonad.Layout $ XMonad.layoutHook XMonad.defaultConfig }

    showKm :: [((KeyMask, KeySym), NamedAction)] -> [String]
    showKm keybindings = padding $ do
        (k,e) <- keybindings
        if snd k == 0 then map ((,) "") $ showName e
            else map ((,) (keyToString k) . smartSpace) $ showName e
        where padding = let pad n (k,e) = if null k then "\n>> "++e else take n (k++repeat ' ') ++ e
                            expand xs n = map (pad n) xs
                            getMax = map (maximum . map (length . fst))
                in concat . (zipWith expand <*> getMax) . groupBy (const $ not . null . fst)

    -- | An action to send to 'addDescrKeys' for showing the keybindings. See also 'showKm' and 'showKmSimple'
    xMessage :: [((KeyMask, KeySym), NamedAction)] -> NamedAction
    xMessage x = addName "Show Keybindings" $ io $ do
        xfork $ executeFile "xmessage" True ["-default", "okay", unlines $ showKm x] Nothing
        return ()

    -- | Merge the supplied keys with 'defaultKeysDescr', also adding a keybinding
    -- to run an action for showing the keybindings.
    addDescrKeys :: (HasName b1, HasName b) =>
        ((KeyMask, KeySym),[((KeyMask, KeySym), NamedAction)] -> b)
        -> (XConfig Layout -> [((KeyMask, KeySym), b1)])
        -> XConfig l
        -> XConfig l
    addDescrKeys k ks = addDescrKeys' k (\l -> defaultKeysDescr l ^++^ ks l)

    -- | Without merging with 'defaultKeysDescr'
    addDescrKeys' :: (HasName b) =>
        ((KeyMask, KeySym),[((KeyMask, KeySym), NamedAction)] -> b)
        -> (XConfig Layout -> [((KeyMask, KeySym), NamedAction)]) -> XConfig l -> XConfig l
    addDescrKeys' (k,f) ks conf =
        let shk l = f $ [(k,f $ ks l)] ^++^ ks l
            keylist l = M.map getAction $ M.fromList $ ks l ^++^ [(k, shk l)]
        in conf { keys = keylist }

    -- | A version of the default keys from 'XMonad.Config.defaultConfig', but with
    -- 'NamedAction'  instead of @X ()@
    defaultKeysDescr :: XConfig Layout -> [((KeyMask, KeySym), NamedAction)]
    defaultKeysDescr conf@(XConfig {XMonad.modMask = modm}) =
        [ subtitle "launching and killing programs"
        , ((modm .|. shiftMask, xK_Return), addName "Launch Terminal" $ spawn $ XMonad.terminal conf) -- %! Launch terminal
        , ((modm,               xK_p     ), addName "Launch dmenu" $ spawn "exe=`dmenu_path | dmenu` && eval \"exec $exe\"") -- %! Launch dmenu
        , ((modm .|. shiftMask, xK_p     ), addName "Launch gmrun" $ spawn "gmrun") -- %! Launch gmrun
        , ((modm .|. shiftMask, xK_c     ), addName "Close the focused window" kill) -- %! Close the focused window

        , subtitle "changing layouts"
        , ((modm,               xK_space ), sendMessage' NextLayout) -- %! Rotate through the available layout algorithms
        , ((modm .|. shiftMask, xK_space ), addName "Reset the layout" $ setLayout $ XMonad.layoutHook conf) -- %!  Reset the layouts on the current workspace to default

        , separator
        , ((modm,               xK_n     ), addName "Refresh" refresh) -- %! Resize viewed windows to the correct size

        , subtitle "move focus up or down the window stack"
        , ((modm,               xK_Tab   ), addName "Focus down" $ windows W.focusDown) -- %! Move focus to the next window
        , ((modm .|. shiftMask, xK_Tab   ), addName "Focus up"   $ windows W.focusUp  ) -- %! Move focus to the previous window
        , ((modm,               xK_j     ), addName "Focus down" $ windows W.focusDown) -- %! Move focus to the next window
        , ((modm,               xK_k     ), addName "Focus up"   $ windows W.focusUp  ) -- %! Move focus to the previous window
        , ((modm,               xK_m     ), addName "Focus the master" $ windows W.focusMaster  ) -- %! Move focus to the master window

        , subtitle "modifying the window order"
        , ((modm,               xK_Return), addName "Swap with the master" $ windows W.swapMaster) -- %! Swap the focused window and the master window
        , ((modm .|. shiftMask, xK_j     ), addName "Swap down" $ windows W.swapDown  ) -- %! Swap the focused window with the next window
        , ((modm .|. shiftMask, xK_k     ), addName "Swap up"   $ windows W.swapUp    ) -- %! Swap the focused window with the previous window

        , subtitle "resizing the master/slave ratio"
        , ((modm,               xK_h     ), sendMessage' Shrink) -- %! Shrink the master area
        , ((modm,               xK_l     ), sendMessage' Expand) -- %! Expand the master area

        , subtitle "floating layer support"
        , ((modm,               xK_t     ), addName "Push floating to tiled" $ withFocused $ windows . W.sink) -- %! Push window back into tiling

        , subtitle "change the number of windows in the master area"
        , ((modm              , xK_comma ), sendMessage' (IncMasterN 1)) -- %! Increment the number of windows in the master area
        , ((modm              , xK_period), sendMessage' (IncMasterN (-1))) -- %! Deincrement the number of windows in the master area

        , subtitle "quit, or restart"
        , ((modm .|. shiftMask, xK_q     ), addName "Quit" $ io (exitWith ExitSuccess)) -- %! Quit xmonad
        , ((modm              , xK_q     ), addName "Restart" $ spawn "xmonad --recompile && xmonad --restart") -- %! Restart xmonad
        ]

        -- mod-[1..9] %! Switch to workspace N
        -- mod-shift-[1..9] %! Move client to workspace N
        ++
        subtitle "switching workspaces":
        [((m .|. modm, k), addName (n ++ i) $ windows $ f i)
            | (f, m, n) <- [(W.greedyView, 0, "Switch to workspace "), (W.shift, shiftMask, "Move client to workspace ")]
            , (i, k) <- zip (XMonad.workspaces conf) [xK_1 .. xK_9]]
        -- mod-{w,e,r} %! Switch to physical/Xinerama screens 1, 2, or 3
        -- mod-shift-{w,e,r} %! Move client to screen 1, 2, or 3
       ++
       subtitle "switching screens" :
       [((m .|. modm, key), addName (n ++ show sc) $ screenWorkspace sc >>= flip whenJust (windows . f))
            | (f, m, n) <- [(W.view, 0, "Switch to screen number "), (W.shift, shiftMask, "Move client to screen number ")]
            , (key, sc) <- zip [xK_w, xK_e, xK_r] [0..]]

    -- | For a prettier presentation: keymask, keysym of 0 are reserved for this
    -- purpose: they do not happen, afaik, and keysymToString 0 would raise an
    -- error otherwise
    separator :: ((KeyMask,KeySym), NamedAction)
    separator = ((0,0), NamedAction (return () :: X (),[] :: [String]))

    subtitle ::  String -> ((KeyMask, KeySym), NamedAction)
    subtitle x = ((0,0), NamedAction $ x ++ ":")

    -- | These are just the @NamedAction@ constructor but with a more specialized
    -- type, so that you don't have to supply any annotations, for ex coercing
    -- spawn to @X ()@ from the more general @MonadIO m => m ()@
    noName :: X () -> NamedAction
    noName = NamedAction

    oneName :: (X (), String) -> NamedAction
    oneName = NamedAction

    addName :: String -> X () -> NamedAction
    addName = flip (curry NamedAction)