    -----------------------------------------------------------------------------
    -- |
    -- Module      :  XMonad.Actions.WorkspaceNames
    -- Description :  Persistently rename workspace and swap them along with their names.
    -- 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 a status bar 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.
    --
    -----------------------------------------------------------------------------

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

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

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

        -- * Workspace prompt
        workspaceNamePrompt,

        -- * StatusBar, EwmhDesktops integration
        workspaceNamesPP,
        workspaceNamesEwmh,
        ) where

    import XMonad
    import XMonad.Prelude (fromMaybe, isInfixOf, (<&>), (>=>))
    import qualified XMonad.StackSet as W
    import qualified XMonad.Util.ExtensibleState as XS

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

    import qualified Data.Map as M

    -- $usage
    -- You can use this module with the following in your @xmonad.hs@ file:
    --
    -- > import XMonad.Actions.WorkspaceNames
    --
    -- Then add keybindings like the following:
    --
    -- >   , ((modm .|. shiftMask, xK_r      ), renameWorkspace def)
    --
    -- and apply workspaceNamesPP to your pretty-printer:
    --
    -- > myPP = workspaceNamesPP xmobarPP
    --
    -- Check "XMonad.Hooks.StatusBar" for more information on how to incorprate
    -- this into your status bar.
    --
    -- To expose workspace names to pagers and other EWMH clients, integrate this
    -- with "XMonad.Hooks.EwmhDesktops":
    --
    -- > main = xmonad $ … . workspaceNamesEwmh . ewmh . … $ def{…}
    --
    -- 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
    -- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.

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

    instance ExtensionClass WorkspaceNames where
        initialValue :: WorkspaceNames
    initialValue = Map WorkspaceId WorkspaceId -> WorkspaceNames
    WorkspaceNames Map WorkspaceId WorkspaceId
    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 (WorkspaceId -> Maybe WorkspaceId)
    getWorkspaceNames' = do
        WorkspaceNames m <- X WorkspaceNames
    forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
    XS.get
        return (`M.lookup` m)

    -- | Returns a function for 'ppRename' that appends @sep@ and the workspace
    -- name, if set.
    getWorkspaceNames :: String -> X (String -> WindowSpace -> String)
    getWorkspaceNames :: WorkspaceId -> X (WorkspaceId -> WindowSpace -> WorkspaceId)
    getWorkspaceNames WorkspaceId
    sep = (WorkspaceId -> Maybe WorkspaceId)
    -> WorkspaceId -> WindowSpace -> WorkspaceId
    forall {t} {l} {a}.
    (t -> Maybe WorkspaceId)
    -> WorkspaceId -> Workspace t l a -> WorkspaceId
    ren ((WorkspaceId -> Maybe WorkspaceId)
     -> WorkspaceId -> WindowSpace -> WorkspaceId)
    -> X (WorkspaceId -> Maybe WorkspaceId)
    -> X (WorkspaceId -> WindowSpace -> WorkspaceId)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> X (WorkspaceId -> Maybe WorkspaceId)
    getWorkspaceNames'
      where
        ren :: (t -> Maybe WorkspaceId)
    -> WorkspaceId -> Workspace t l a -> WorkspaceId
    ren t -> Maybe WorkspaceId
    name WorkspaceId
    s Workspace t l a
    w = WorkspaceId
    s WorkspaceId -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ WorkspaceId -> ShowS -> Maybe WorkspaceId -> WorkspaceId
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe WorkspaceId
    "" (WorkspaceId
    sep WorkspaceId -> ShowS
    forall a. [a] -> [a] -> [a]
    ++) (t -> Maybe WorkspaceId
    name (Workspace t l a -> t
    forall i l a. Workspace i l a -> i
    W.tag Workspace t l a
    w))

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

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

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

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

    -- | Prompt for a new name for the current workspace and set it.
    renameWorkspace :: XPConfig -> X ()
    renameWorkspace :: XPConfig -> X ()
    renameWorkspace XPConfig
    conf = do
        completion <- XPConfig -> (WorkspaceId -> Bool) -> X ComplFunction
    historyCompletionP XPConfig
    conf (WorkspaceId
    prompt WorkspaceId -> WorkspaceId -> Bool
    forall a. Eq a => a -> a -> Bool
    ==)
        mkXPrompt (Wor prompt) conf completion setCurrentWorkspaceName
      where
        prompt :: WorkspaceId
    prompt = WorkspaceId
    "Workspace name: "

    -- | See 'XMonad.Actions.SwapWorkspaces.swapTo'. This is the same with names.
    swapTo :: Direction1D -> X ()
    swapTo :: Direction1D -> X ()
    swapTo 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' Direction1D
    dir WSType
    which = X WorkspaceSort -> Direction1D -> WSType -> Int -> X WorkspaceId
    findWorkspace X WorkspaceSort
    getSortByIndex Direction1D
    dir WSType
    which Int
    1 X WorkspaceId -> (WorkspaceId -> X ()) -> X ()
    forall a b. X a -> (a -> X b) -> X b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= WorkspaceId -> X ()
    swapWithCurrent

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

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

    -- | Same behavior than 'XMonad.Prompt.Workspace.workspacePrompt' excepted it acts on the workspace name provided by this module.
    workspaceNamePrompt :: XPConfig -> (WorkspaceId -> X ()) -> X ()
    workspaceNamePrompt :: XPConfig -> (WorkspaceId -> X ()) -> X ()
    workspaceNamePrompt XPConfig
    conf WorkspaceId -> X ()
    job = do
        myWorkspaces <- (XState -> [WindowSpace]) -> X [WindowSpace]
    forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
    gets ((XState -> [WindowSpace]) -> X [WindowSpace])
    -> (XState -> [WindowSpace]) -> X [WindowSpace]
    forall a b. (a -> b) -> a -> b
    $ StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
    -> [WindowSpace]
    forall i l a s sd. StackSet i l a s sd -> [Workspace i l a]
    W.workspaces (StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
     -> [WindowSpace])
    -> (XState
        -> StackSet
             WorkspaceId (Layout Window) Window ScreenId ScreenDetail)
    -> XState
    -> [WindowSpace]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . XState
    -> StackSet
         WorkspaceId (Layout Window) Window ScreenId ScreenDetail
    windowset
        myWorkspacesName <- getWorkspaceNames ":" <&> \WorkspaceId -> WindowSpace -> WorkspaceId
    n -> [WorkspaceId -> WindowSpace -> WorkspaceId
    n (WindowSpace -> WorkspaceId
    forall i l a. Workspace i l a -> i
    W.tag WindowSpace
    w) WindowSpace
    w | WindowSpace
    w <- [WindowSpace]
    myWorkspaces]
        let pairs = [WorkspaceId] -> [WorkspaceId] -> [(WorkspaceId, WorkspaceId)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [WorkspaceId]
    myWorkspacesName ((WindowSpace -> WorkspaceId) -> [WindowSpace] -> [WorkspaceId]
    forall a b. (a -> b) -> [a] -> [b]
    map WindowSpace -> WorkspaceId
    forall i l a. Workspace i l a -> i
    W.tag [WindowSpace]
    myWorkspaces)
        mkXPrompt (Wor "Select workspace: ") conf
                  (contains myWorkspacesName)
                  (job . toWsId pairs)
      where toWsId :: [(a, WorkspaceId)] -> a -> WorkspaceId
    toWsId [(a, WorkspaceId)]
    pairs a
    name = WorkspaceId -> Maybe WorkspaceId -> WorkspaceId
    forall a. a -> Maybe a -> a
    fromMaybe WorkspaceId
    "" (a -> [(a, WorkspaceId)] -> Maybe WorkspaceId
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup a
    name [(a, WorkspaceId)]
    pairs)
            contains :: [[a]] -> [a] -> m [[a]]
    contains [[a]]
    completions [a]
    input =
              [[a]] -> m [[a]]
    forall a. 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
    isInfixOf [a]
    input) [[a]]
    completions

    -- | Modify 'XMonad.Hooks.StatusBar.PP.PP'\'s pretty-printing format to show
    -- workspace names as well.
    workspaceNamesPP :: PP -> X PP
    workspaceNamesPP :: PP -> X PP
    workspaceNamesPP PP
    pp = WorkspaceId -> X (WorkspaceId -> WindowSpace -> WorkspaceId)
    getWorkspaceNames WorkspaceId
    ":" X (WorkspaceId -> WindowSpace -> WorkspaceId)
    -> ((WorkspaceId -> WindowSpace -> WorkspaceId) -> PP) -> X PP
    forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
    <&> \WorkspaceId -> WindowSpace -> WorkspaceId
    ren -> PP
    pp{ ppRename = ppRename pp >=> ren }

    -- | Tell "XMonad.Hooks.EwmhDesktops" to append workspace names to desktop
    -- names.
    workspaceNamesEwmh :: XConfig l -> XConfig l
    workspaceNamesEwmh :: forall (l :: * -> *). XConfig l -> XConfig l
    workspaceNamesEwmh = X (WorkspaceId -> WindowSpace -> WorkspaceId)
    -> XConfig l -> XConfig l
    forall (l :: * -> *).
    X (WorkspaceId -> WindowSpace -> WorkspaceId)
    -> XConfig l -> XConfig l
    addEwmhWorkspaceRename (X (WorkspaceId -> WindowSpace -> WorkspaceId)
     -> XConfig l -> XConfig l)
    -> X (WorkspaceId -> WindowSpace -> WorkspaceId)
    -> XConfig l
    -> XConfig l
    forall a b. (a -> b) -> a -> b
    $ WorkspaceId -> X (WorkspaceId -> WindowSpace -> WorkspaceId)
    getWorkspaceNames WorkspaceId
    ":"