    -----------------------------------------------------------------------------
    -- |
    -- Module      :  XMonad.Actions.WorkspaceNames
    -- Copyright   :  (c) Tomas Janousek <tomi@nomi.cz>
    -- License     :  BSD3-style (see LICENSE)
    --
    -- Maintainer  :  Tomas Janousek <tomi@nomi.cz>
    -- Stability   :  experimental
    -- Portability :  unportable
    --
    -- Provides bindings to rename workspaces, show these names in DynamicLog and
    -- swap workspaces along with their names. These names survive restart.
    -- Together with "XMonad.Layout.WorkspaceDir" this provides for a fully
    -- dynamic topic space workflow.
    --
    -----------------------------------------------------------------------------

    {-# LANGUAGE DeriveDataTypeable #-}

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

        -- * Workspace naming
        renameWorkspace,
        workspaceNamesPP,
        getWorkspaceNames',
        getWorkspaceNames,
        getWorkspaceName,
        getCurrentWorkspaceName,
        setWorkspaceName,
        setCurrentWorkspaceName,

        -- * Workspace swapping
        swapTo,
        swapTo',
        swapWithCurrent,

        -- * Workspace prompt
        workspaceNamePrompt
        ) where

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

    import XMonad.Actions.CycleWS (findWorkspace, WSType(..), Direction1D(..))
    import qualified XMonad.Actions.SwapWorkspaces as Swap
    import XMonad.Hooks.DynamicLog (PP(..))
    import XMonad.Prompt (mkXPrompt, XPConfig)
    import XMonad.Prompt.Workspace (Wor(Wor))
    import XMonad.Util.WorkspaceCompare (getSortByIndex)

    import qualified Data.Map as M
    import Data.Maybe (fromMaybe)
    import Data.List (isInfixOf)

    -- $usage
    -- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@ file:
    --
    -- > import XMonad.Actions.WorkspaceNames
    --
    -- Then add keybindings like the following:
    --
    -- >   , ((modm .|. shiftMask, xK_r      ), renameWorkspace def)
    --
    -- and apply workspaceNamesPP to your DynamicLog pretty-printer:
    --
    -- > myLogHook =
    -- >     workspaceNamesPP xmobarPP >>= dynamicLogString >>= xmonadPropLog
    --
    -- We also provide a modification of "XMonad.Actions.SwapWorkspaces"\'s
    -- functionality, which may be used this way:
    --
    -- >   , ((modMask .|. shiftMask, xK_Left  ), swapTo Prev)
    -- >   , ((modMask .|. shiftMask, xK_Right ), swapTo Next)
    --
    -- > [((modm .|. controlMask, k), swapWithCurrent i)
    -- >     | (i, k) <- zip workspaces [xK_1 ..]]
    --
    -- For detailed instructions on editing your key bindings, see
    -- "XMonad.Doc.Extending#Editing_key_bindings".

    -- | Workspace names container.
    newtype WorkspaceNames = WorkspaceNames (M.Map WorkspaceId String)
        deriving (Typeable, ReadPrec [WorkspaceNames]
    ReadPrec WorkspaceNames
    Int -> ReadS WorkspaceNames
    ReadS [WorkspaceNames]
    (Int -> ReadS WorkspaceNames)
    -> ReadS [WorkspaceNames]
    -> ReadPrec WorkspaceNames
    -> ReadPrec [WorkspaceNames]
    -> Read WorkspaceNames
    forall a.
    (Int -> ReadS a)
    -> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
    readListPrec :: ReadPrec [WorkspaceNames]
    $creadListPrec :: ReadPrec [WorkspaceNames]
    readPrec :: ReadPrec WorkspaceNames
    $creadPrec :: ReadPrec WorkspaceNames
    readList :: ReadS [WorkspaceNames]
    $creadList :: ReadS [WorkspaceNames]
    readsPrec :: Int -> ReadS WorkspaceNames
    $creadsPrec :: Int -> ReadS WorkspaceNames
    Read, Int -> WorkspaceNames -> ShowS
    [WorkspaceNames] -> ShowS
    WorkspaceNames -> String
    (Int -> WorkspaceNames -> ShowS)
    -> (WorkspaceNames -> String)
    -> ([WorkspaceNames] -> ShowS)
    -> Show WorkspaceNames
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    showList :: [WorkspaceNames] -> ShowS
    $cshowList :: [WorkspaceNames] -> ShowS
    show :: WorkspaceNames -> String
    $cshow :: WorkspaceNames -> String
    showsPrec :: Int -> WorkspaceNames -> ShowS
    $cshowsPrec :: Int -> WorkspaceNames -> ShowS
    Show)

    instance ExtensionClass WorkspaceNames where
        initialValue :: WorkspaceNames
    initialValue = Map String String -> WorkspaceNames
    WorkspaceNames Map String String
    forall k a. Map k a
    M.empty
        extensionType :: WorkspaceNames -> StateExtension
    extensionType = WorkspaceNames -> StateExtension
    forall a. (Read a, Show a, ExtensionClass a) => a -> StateExtension
    PersistentExtension

    -- | Returns a lookup function that maps workspace tags to workspace names.
    getWorkspaceNames' :: X (WorkspaceId -> Maybe String)
    getWorkspaceNames' :: X (String -> Maybe String)
    getWorkspaceNames' = do
        WorkspaceNames m :: Map String String
    m <- X WorkspaceNames
    forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
    XS.get
        (String -> Maybe String) -> X (String -> Maybe String)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> Map String String -> Maybe String
    forall k a. Ord k => k -> Map k a -> Maybe a
    `M.lookup` Map String String
    m)

    -- | Returns a function that maps workspace tag @\"t\"@ to @\"t:name\"@ for
    -- workspaces with a name, and to @\"t\"@ otherwise.
    getWorkspaceNames :: X (WorkspaceId -> String)
    getWorkspaceNames :: X ShowS
    getWorkspaceNames = do
        String -> Maybe String
    lookup <- X (String -> Maybe String)
    getWorkspaceNames'
        ShowS -> X ShowS
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ShowS -> X ShowS) -> ShowS -> X ShowS
    forall a b. (a -> b) -> a -> b
    $ \wks :: String
    wks -> String
    wks String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String -> ShowS -> Maybe String -> String
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe "" (':' Char -> ShowS
    forall a. a -> [a] -> [a]
    :) (String -> Maybe String
    lookup String
    wks)

    -- | Gets the name of a workspace, if set, otherwise returns nothing.
    getWorkspaceName :: WorkspaceId -> X (Maybe String)
    getWorkspaceName :: String -> X (Maybe String)
    getWorkspaceName w :: String
    w = ((String -> Maybe String) -> String -> Maybe String
    forall a b. (a -> b) -> a -> b
    $ String
    w) ((String -> Maybe String) -> Maybe String)
    -> X (String -> Maybe String) -> X (Maybe String)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` X (String -> Maybe String)
    getWorkspaceNames'

    -- | Gets the name of the current workspace. See 'getWorkspaceName'
    getCurrentWorkspaceName :: X (Maybe String)
    getCurrentWorkspaceName :: X (Maybe String)
    getCurrentWorkspaceName = do
        String -> X (Maybe String)
    getWorkspaceName (String -> X (Maybe String)) -> X String -> X (Maybe String)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< (XState -> String) -> X String
    forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
    gets (StackSet String (Layout Window) Window ScreenId ScreenDetail
    -> String
    forall i l a s sd. StackSet i l a s sd -> i
    W.currentTag (StackSet String (Layout Window) Window ScreenId ScreenDetail
     -> String)
    -> (XState
        -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
    -> XState
    -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . XState
    -> StackSet String (Layout Window) Window ScreenId ScreenDetail
    windowset)

    -- | Sets the name of a workspace. Empty string makes the workspace unnamed
    -- again.
    setWorkspaceName :: WorkspaceId -> String -> X ()
    setWorkspaceName :: String -> String -> X ()
    setWorkspaceName w :: String
    w name :: String
    name = do
        WorkspaceNames m :: Map String String
    m <- X WorkspaceNames
    forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
    XS.get
        WorkspaceNames -> X ()
    forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
    XS.put (WorkspaceNames -> X ()) -> WorkspaceNames -> X ()
    forall a b. (a -> b) -> a -> b
    $ Map String String -> WorkspaceNames
    WorkspaceNames (Map String String -> WorkspaceNames)
    -> Map String String -> WorkspaceNames
    forall a b. (a -> b) -> a -> b
    $ if String -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null String
    name then String -> Map String String -> Map String String
    forall k a. Ord k => k -> Map k a -> Map k a
    M.delete String
    w Map String String
    m else String -> String -> Map String String -> Map String String
    forall k a. Ord k => k -> a -> Map k a -> Map k a
    M.insert String
    w String
    name Map String String
    m
        X ()
    refresh

    -- | Sets the name of the current workspace. See 'setWorkspaceName'.
    setCurrentWorkspaceName :: String -> X ()
    setCurrentWorkspaceName :: String -> X ()
    setCurrentWorkspaceName name :: String
    name = do
        String
    current <- (XState -> String) -> X String
    forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
    gets (StackSet String (Layout Window) Window ScreenId ScreenDetail
    -> String
    forall i l a s sd. StackSet i l a s sd -> i
    W.currentTag (StackSet String (Layout Window) Window ScreenId ScreenDetail
     -> String)
    -> (XState
        -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
    -> XState
    -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . XState
    -> StackSet String (Layout Window) Window ScreenId ScreenDetail
    windowset)
        String -> String -> X ()
    setWorkspaceName String
    current String
    name

    -- | Prompt for a new name for the current workspace and set it.
    renameWorkspace :: XPConfig -> X ()
    renameWorkspace :: XPConfig -> X ()
    renameWorkspace conf :: XPConfig
    conf = do
        Wor -> XPConfig -> ComplFunction -> (String -> X ()) -> X ()
    forall p.
    XPrompt p =>
    p -> XPConfig -> ComplFunction -> (String -> X ()) -> X ()
    mkXPrompt Wor
    pr XPConfig
    conf (IO [String] -> ComplFunction
    forall a b. a -> b -> a
    const ([String] -> IO [String]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [])) String -> X ()
    setCurrentWorkspaceName
        where pr :: Wor
    pr = String -> Wor
    Wor "Workspace name: "

    -- | Modify "XMonad.Hooks.DynamicLog"\'s pretty-printing format to show
    -- workspace names as well.
    workspaceNamesPP :: PP -> X PP
    workspaceNamesPP :: PP -> X PP
    workspaceNamesPP pp :: PP
    pp = do
        ShowS
    names <- X ShowS
    getWorkspaceNames
        PP -> X PP
    forall (m :: * -> *) a. Monad m => a -> m a
    return (PP -> X PP) -> PP -> X PP
    forall a b. (a -> b) -> a -> b
    $
            PP
    pp {
                ppCurrent :: ShowS
    ppCurrent         = PP -> ShowS
    ppCurrent         PP
    pp ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ShowS
    names,
                ppVisible :: ShowS
    ppVisible         = PP -> ShowS
    ppVisible         PP
    pp ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ShowS
    names,
                ppHidden :: ShowS
    ppHidden          = PP -> ShowS
    ppHidden          PP
    pp ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ShowS
    names,
                ppHiddenNoWindows :: ShowS
    ppHiddenNoWindows = PP -> ShowS
    ppHiddenNoWindows PP
    pp ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ShowS
    names,
                ppUrgent :: ShowS
    ppUrgent          = PP -> ShowS
    ppUrgent          PP
    pp ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ShowS
    names
            }

    -- | See 'XMonad.Actions.SwapWorkspaces.swapTo'. This is the same with names.
    swapTo :: Direction1D -> X ()
    swapTo :: Direction1D -> X ()
    swapTo dir :: Direction1D
    dir = Direction1D -> WSType -> X ()
    swapTo' Direction1D
    dir WSType
    AnyWS

    -- | Swap with the previous or next workspace of the given type.
    swapTo' :: Direction1D -> WSType -> X ()
    swapTo' :: Direction1D -> WSType -> X ()
    swapTo' dir :: Direction1D
    dir which :: WSType
    which = X WorkspaceSort -> Direction1D -> WSType -> Int -> X String
    findWorkspace X WorkspaceSort
    getSortByIndex Direction1D
    dir WSType
    which 1 X String -> (String -> X ()) -> X ()
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= String -> X ()
    swapWithCurrent

    -- | See 'XMonad.Actions.SwapWorkspaces.swapWithCurrent'. This is almost the
    -- same with names.
    swapWithCurrent :: WorkspaceId -> X ()
    swapWithCurrent :: String -> X ()
    swapWithCurrent t :: String
    t = do
        String
    current <- (XState -> String) -> X String
    forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
    gets (StackSet String (Layout Window) Window ScreenId ScreenDetail
    -> String
    forall i l a s sd. StackSet i l a s sd -> i
    W.currentTag (StackSet String (Layout Window) Window ScreenId ScreenDetail
     -> String)
    -> (XState
        -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
    -> XState
    -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . XState
    -> StackSet String (Layout Window) Window ScreenId ScreenDetail
    windowset)
        String -> String -> X ()
    swapNames String
    t String
    current
        (StackSet String (Layout Window) Window ScreenId ScreenDetail
     -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
    -> X ()
    windows ((StackSet String (Layout Window) Window ScreenId ScreenDetail
      -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
     -> X ())
    -> (StackSet String (Layout Window) Window ScreenId ScreenDetail
        -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
    -> X ()
    forall a b. (a -> b) -> a -> b
    $ String
    -> String
    -> StackSet String (Layout Window) Window ScreenId ScreenDetail
    -> StackSet String (Layout Window) Window ScreenId ScreenDetail
    forall i l a s sd.
    Eq i =>
    i -> i -> StackSet i l a s sd -> StackSet i l a s sd
    Swap.swapWorkspaces String
    t String
    current

    -- | Swap names of the two workspaces.
    swapNames :: WorkspaceId -> WorkspaceId -> X ()
    swapNames :: String -> String -> X ()
    swapNames w1 :: String
    w1 w2 :: String
    w2 = do
        WorkspaceNames m :: Map String String
    m <- X WorkspaceNames
    forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
    XS.get
        let getname :: ShowS
    getname w :: String
    w = String -> Maybe String -> String
    forall a. a -> Maybe a -> a
    fromMaybe "" (Maybe String -> String) -> Maybe String -> String
    forall a b. (a -> b) -> a -> b
    $ String -> Map String String -> Maybe String
    forall k a. Ord k => k -> Map k a -> Maybe a
    M.lookup String
    w Map String String
    m
            set :: k -> t a -> Map k (t a) -> Map k (t a)
    set w :: k
    w name :: t a
    name m' :: Map k (t a)
    m' = if t a -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null t a
    name then k -> Map k (t a) -> Map k (t a)
    forall k a. Ord k => k -> Map k a -> Map k a
    M.delete k
    w Map k (t a)
    m' else k -> t a -> Map k (t a) -> Map k (t a)
    forall k a. Ord k => k -> a -> Map k a -> Map k a
    M.insert k
    w t a
    name Map k (t a)
    m'
        WorkspaceNames -> X ()
    forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
    XS.put (WorkspaceNames -> X ()) -> WorkspaceNames -> X ()
    forall a b. (a -> b) -> a -> b
    $ Map String String -> WorkspaceNames
    WorkspaceNames (Map String String -> WorkspaceNames)
    -> Map String String -> WorkspaceNames
    forall a b. (a -> b) -> a -> b
    $ String -> String -> Map String String -> Map String String
    forall (t :: * -> *) k a.
    (Foldable t, Ord k) =>
    k -> t a -> Map k (t a) -> Map k (t a)
    set String
    w1 (ShowS
    getname String
    w2) (Map String String -> Map String String)
    -> Map String String -> Map String String
    forall a b. (a -> b) -> a -> b
    $ String -> String -> Map String String -> Map String String
    forall (t :: * -> *) k a.
    (Foldable t, Ord k) =>
    k -> t a -> Map k (t a) -> Map k (t a)
    set String
    w2 (ShowS
    getname String
    w1) (Map String String -> Map String String)
    -> Map String String -> Map String String
    forall a b. (a -> b) -> a -> b
    $ Map String String
    m

    -- | Same behavior than 'XMonad.Prompt.Workspace.workspacePrompt' excepted it acts on the workspace name provided by this module.
    workspaceNamePrompt :: XPConfig -> (String -> X ()) -> X ()
    workspaceNamePrompt :: XPConfig -> (String -> X ()) -> X ()
    workspaceNamePrompt conf :: XPConfig
    conf job :: String -> X ()
    job = do
        [String]
    myWorkspaces <- (XState -> [String]) -> X [String]
    forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
    gets ((XState -> [String]) -> X [String])
    -> (XState -> [String]) -> X [String]
    forall a b. (a -> b) -> a -> b
    $ (Workspace String (Layout Window) Window -> String)
    -> [Workspace String (Layout Window) Window] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map Workspace String (Layout Window) Window -> String
    forall i l a. Workspace i l a -> i
    W.tag ([Workspace String (Layout Window) Window] -> [String])
    -> (XState -> [Workspace String (Layout Window) Window])
    -> XState
    -> [String]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . StackSet String (Layout Window) Window ScreenId ScreenDetail
    -> [Workspace String (Layout Window) Window]
    forall i l a s sd. StackSet i l a s sd -> [Workspace i l a]
    W.workspaces (StackSet String (Layout Window) Window ScreenId ScreenDetail
     -> [Workspace String (Layout Window) Window])
    -> (XState
        -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
    -> XState
    -> [Workspace String (Layout Window) Window]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . XState
    -> StackSet String (Layout Window) Window ScreenId ScreenDetail
    windowset
        [String]
    myWorkspacesName <- X ShowS
    getWorkspaceNames X ShowS -> (ShowS -> X [String]) -> X [String]
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \f :: ShowS
    f -> [String] -> X [String]
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([String] -> X [String]) -> [String] -> X [String]
    forall a b. (a -> b) -> a -> b
    $ ShowS -> [String] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map ShowS
    f [String]
    myWorkspaces
        let pairs :: [(String, String)]
    pairs = [String] -> [String] -> [(String, String)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [String]
    myWorkspacesName [String]
    myWorkspaces
        Wor -> XPConfig -> ComplFunction -> (String -> X ()) -> X ()
    forall p.
    XPrompt p =>
    p -> XPConfig -> ComplFunction -> (String -> X ()) -> X ()
    mkXPrompt (String -> Wor
    Wor "Select workspace: ") XPConfig
    conf
                  ([String] -> ComplFunction
    forall (m :: * -> *) a. (Monad m, Eq a) => [[a]] -> [a] -> m [[a]]
    contains [String]
    myWorkspacesName)
                  (String -> X ()
    job (String -> X ()) -> ShowS -> String -> X ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [(String, String)] -> ShowS
    forall a. Eq a => [(a, String)] -> a -> String
    toWsId [(String, String)]
    pairs)
      where toWsId :: [(a, String)] -> a -> String
    toWsId pairs :: [(a, String)]
    pairs name :: a
    name = case a -> [(a, String)] -> Maybe String
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup a
    name [(a, String)]
    pairs of
                                    Nothing -> ""
                                    Just i :: String
    i -> String
    i
            contains :: [[a]] -> [a] -> m [[a]]
    contains completions :: [[a]]
    completions input :: [a]
    input =
              [[a]] -> m [[a]]
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([[a]] -> m [[a]]) -> [[a]] -> m [[a]]
    forall a b. (a -> b) -> a -> b
    $ ([a] -> Bool) -> [[a]] -> [[a]]
    forall a. (a -> Bool) -> [a] -> [a]
    filter ([a] -> [a] -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    Data.List.isInfixOf [a]
    input) [[a]]
    completions