{-# LANGUAGE RecordWildCards #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Hooks.DynamicIcons
-- Description :  Dynamically update workspace names based on its contents\/windows on it.
-- Copyright   :  (c) Will Pierlot <willp@outlook.com.au>
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  Will Pierlot <willp@outlook.com.au>
-- Stability   :  unstable
-- Portability :  unportable
--
-- Dynamically augment workspace names logged to a status bar
-- based on the contents (windows) of the workspace.
-----------------------------------------------------------------------------

module XMonad.Hooks.DynamicIcons (
    -- * Usage
    -- $usage

    -- * Creating Dynamic Icons
    iconsPP, dynamicLogIconsWithPP, appIcon,

    -- * Customization
    dynamicIconsPP, getWorkspaceIcons,
    IconConfig(..),
    iconsFmtAppend, iconsFmtReplace, wrapUnwords,
    iconsGetAll, iconsGetFocus,

    ) where
import XMonad

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

import XMonad.Hooks.StatusBar.PP
import XMonad.Prelude (for, maybeToList, (<&>), (<=<), (>=>))

-- $usage
-- Dynamically augment Workspace's 'WorkspaceId' as shown on a status bar
-- based on the 'Window's inside the Workspace.
--
-- Icons are specified by a @Query [String]@, which is something like a
-- 'ManageHook' (and uses the same syntax) that returns a list of 'String's
-- (icons). This 'Query' is evaluated for each window and the results are
-- joined together. 'appIcon' is a useful shortcut here.
--
-- For example:
--
-- > myIcons :: Query [String]
-- > myIcons = composeAll
-- >   [ className =? "discord" --> appIcon "\xfb6e"
-- >   , className =? "Discord" --> appIcon "\xf268"
-- >   , className =? "Firefox" --> appIcon "\63288"
-- >   , className =? "Spotify" <||> className =? "spotify" --> appIcon "阮"
-- >   ]
--
-- then you can add it to your "XMonad.Hooks.StatusBar" config:
--
-- > myBar = statusBarProp "xmobar" (iconsPP myIcons myPP)
-- > main = xmonad . withSB myBar $ … $ def
--
-- Here is an example of this
--
-- <<https://user-images.githubusercontent.com/300342/111010930-36a54300-8398-11eb-8aec-b3059b04fa31.png>>
--
-- Note: You can use any string you want here.
-- The example shown here uses NerdFont Icons to represent open applications.
--
-- If you want to customize formatting and/or combine this with other
-- 'PP' extensions like "XMonad.Util.ClickableWorkspaces", here's a more
-- advanced example how to do that:
--
-- > myIconConfig = def{ iconConfigIcons = myIcons, iconConfigFmt = iconsFmtAppend concat }
-- > myBar = statusBarProp "xmobar" (clickablePP =<< dynamicIconsPP myIconConfig myPP)
-- > main = xmonad . withSB myBar . … $ def
--
-- This can be also used with "XMonad.Hooks.DynamicLog":
--
-- > main = xmonad $ … $ def
-- >   { logHook = dynamicLogIconsWithPP myIcons xmobarPP
-- >   , … }
--
-- or with more customziation:
--
-- > myIconConfig = def{ iconConfigIcons = myIcons, iconConfigFmt = iconsFmtAppend concat }
-- > main = xmonad $ … $ def
-- >   { logHook = xmonadPropLog =<< dynamicLogString =<< clickablePP =<<
-- >               dynamicIconsPP myIconConfig xmobarPP
-- >   , … }


-- | Shortcut for configuring single icons.
appIcon :: String -> Query [String]
appIcon :: String -> Query [String]
appIcon = [String] -> Query [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> Query [String])
-> (String -> [String]) -> String -> Query [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Adjusts the 'PP' and then runs 'dynamicLogWithPP'
dynamicLogIconsWithPP :: Query [String] -- ^ The 'IconSet' to use
                      -> PP -- ^ The 'PP' to alter
                      -> X () -- ^ The resulting 'X' action
dynamicLogIconsWithPP :: Query [String] -> PP -> X ()
dynamicLogIconsWithPP Query [String]
q = PP -> X ()
dynamicLogWithPP (PP -> X ()) -> (PP -> X PP) -> PP -> X ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Query [String] -> PP -> X PP
iconsPP Query [String]
q

-- | Adjusts the 'PP' with the given 'IconSet'
iconsPP :: Query [String] -- ^ The 'IconSet' to use
        -> PP -- ^ The 'PP' to alter
        -> X PP -- ^ The resulting 'X PP'
iconsPP :: Query [String] -> PP -> X PP
iconsPP Query [String]
q = IconConfig -> PP -> X PP
dynamicIconsPP IconConfig
forall a. Default a => a
def{ iconConfigIcons :: Query [String]
iconConfigIcons = Query [String]
q }

-- | Modify a pretty-printer, 'PP', to augment
-- workspace names with icons based on the contents (windows) of the workspace.
dynamicIconsPP :: IconConfig -> PP -> X PP
dynamicIconsPP :: IconConfig -> PP -> X PP
dynamicIconsPP IconConfig
ic PP
pp = IconConfig -> X (String -> WindowSpace -> String)
getWorkspaceIcons IconConfig
ic X (String -> WindowSpace -> String)
-> ((String -> WindowSpace -> String) -> PP) -> X PP
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \String -> WindowSpace -> String
ren -> PP
pp{ ppRename :: String -> WindowSpace -> String
ppRename = PP -> String -> WindowSpace -> String
ppRename PP
pp (String -> WindowSpace -> String)
-> (String -> WindowSpace -> String)
-> String
-> WindowSpace
-> String
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> String -> WindowSpace -> String
ren }

-- | Returns a function for 'ppRename' that augments workspaces with icons
-- according to the provided 'IconConfig'.
getWorkspaceIcons :: IconConfig -> X (String -> WindowSpace -> String)
getWorkspaceIcons :: IconConfig -> X (String -> WindowSpace -> String)
getWorkspaceIcons conf :: IconConfig
conf@IconConfig{Query [String]
String -> [String] -> String
Maybe (Stack Window) -> X [Window]
iconConfigFilter :: IconConfig -> Maybe (Stack Window) -> X [Window]
iconConfigFmt :: IconConfig -> String -> [String] -> String
iconConfigFilter :: Maybe (Stack Window) -> X [Window]
iconConfigFmt :: String -> [String] -> String
iconConfigIcons :: Query [String]
iconConfigIcons :: IconConfig -> Query [String]
..} = Map String [String] -> String -> WindowSpace -> String
forall {k} {l} {a}.
Ord k =>
Map k [String] -> String -> Workspace k l a -> String
fmt (Map String [String] -> String -> WindowSpace -> String)
-> X (Map String [String]) -> X (String -> WindowSpace -> String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IconConfig -> X (Map String [String])
getWorkspaceIcons' IconConfig
conf
  where
    fmt :: Map k [String] -> String -> Workspace k l a -> String
fmt Map k [String]
icons String
s Workspace k l a
w = String -> [String] -> String
iconConfigFmt String
s ([String] -> k -> Map k [String] -> [String]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] (Workspace k l a -> k
forall i l a. Workspace i l a -> i
S.tag Workspace k l a
w) Map k [String]
icons)

getWorkspaceIcons' :: IconConfig  -> X (M.Map WorkspaceId [String])
getWorkspaceIcons' :: IconConfig -> X (Map String [String])
getWorkspaceIcons' IconConfig{Query [String]
String -> [String] -> String
Maybe (Stack Window) -> X [Window]
iconConfigFilter :: Maybe (Stack Window) -> X [Window]
iconConfigFmt :: String -> [String] -> String
iconConfigIcons :: Query [String]
iconConfigFilter :: IconConfig -> Maybe (Stack Window) -> X [Window]
iconConfigFmt :: IconConfig -> String -> [String] -> String
iconConfigIcons :: IconConfig -> Query [String]
..} = do
    [WindowSpace]
ws <- (XState -> [WindowSpace]) -> X [WindowSpace]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (StackSet String (Layout Window) Window ScreenId ScreenDetail
-> [WindowSpace]
forall i l a s sd. StackSet i l a s sd -> [Workspace i l a]
S.workspaces (StackSet String (Layout Window) Window ScreenId ScreenDetail
 -> [WindowSpace])
-> (XState
    -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> [WindowSpace]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState
-> StackSet String (Layout Window) Window ScreenId ScreenDetail
windowset)
    [[String]]
is <- [WindowSpace] -> (WindowSpace -> X [String]) -> X [[String]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [WindowSpace]
ws ((WindowSpace -> X [String]) -> X [[String]])
-> (WindowSpace -> X [String]) -> X [[String]]
forall a b. (a -> b) -> a -> b
$ (Window -> X [String]) -> [Window] -> X [String]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Query [String] -> Window -> X [String]
forall a. Query a -> Window -> X a
runQuery Query [String]
iconConfigIcons) ([Window] -> X [String])
-> (WindowSpace -> X [Window]) -> WindowSpace -> X [String]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Maybe (Stack Window) -> X [Window]
iconConfigFilter (Maybe (Stack Window) -> X [Window])
-> (WindowSpace -> Maybe (Stack Window))
-> WindowSpace
-> X [Window]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSpace -> Maybe (Stack Window)
forall i l a. Workspace i l a -> Maybe (Stack a)
S.stack
    Map String [String] -> X (Map String [String])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map String [String] -> X (Map String [String]))
-> Map String [String] -> X (Map String [String])
forall a b. (a -> b) -> a -> b
$ [(String, [String])] -> Map String [String]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([String] -> [[String]] -> [(String, [String])]
forall a b. [a] -> [b] -> [(a, b)]
zip ((WindowSpace -> String) -> [WindowSpace] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map WindowSpace -> String
forall i l a. Workspace i l a -> i
S.tag [WindowSpace]
ws) [[String]]
is)

-- | Datatype for expanded 'Icon' configurations
data IconConfig = IconConfig
    { IconConfig -> Query [String]
iconConfigIcons :: Query [String]
      -- ^ What icons to use for each window.
    , IconConfig -> String -> [String] -> String
iconConfigFmt :: WorkspaceId -> [String] -> String
      -- ^ How to format the result, see 'iconsFmtReplace', 'iconsFmtAppend'.
    , IconConfig -> Maybe (Stack Window) -> X [Window]
iconConfigFilter :: Maybe (S.Stack Window) -> X [Window]
      -- ^ Which windows (icons) to show.
    }

instance Default IconConfig where
    def :: IconConfig
def = IconConfig :: Query [String]
-> (String -> [String] -> String)
-> (Maybe (Stack Window) -> X [Window])
-> IconConfig
IconConfig
        { iconConfigIcons :: Query [String]
iconConfigIcons = Query [String]
forall a. Monoid a => a
mempty
        , iconConfigFmt :: String -> [String] -> String
iconConfigFmt = ([String] -> String) -> String -> [String] -> String
iconsFmtReplace (String -> String -> [String] -> String
wrapUnwords String
"{" String
"}")
        , iconConfigFilter :: Maybe (Stack Window) -> X [Window]
iconConfigFilter = Maybe (Stack Window) -> X [Window]
iconsGetAll
        }

-- | 'iconConfigFmt' that replaces the workspace name with icons, if any.
--
-- First parameter specifies how to concatenate multiple icons. Useful values
-- include: 'concat', 'unwords', 'wrapUnwords'.
--
-- ==== __Examples__
--
-- >>> iconsFmtReplace concat "1" []
-- "1"
--
-- >>> iconsFmtReplace concat "1" ["A", "B"]
-- "AB"
--
-- >>> iconsFmtReplace (wrapUnwords "{" "}") "1" ["A", "B"]
-- "{A B}"
iconsFmtReplace :: ([String] -> String) -> WorkspaceId -> [String] -> String
iconsFmtReplace :: ([String] -> String) -> String -> [String] -> String
iconsFmtReplace [String] -> String
cat String
ws [String]
is | [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
is   = String
ws
                          | Bool
otherwise = [String] -> String
cat [String]
is

-- | 'iconConfigFmt' that appends icons to the workspace name.
--
-- First parameter specifies how to concatenate multiple icons. Useful values
-- include: 'concat', 'unwords', 'wrapUnwords'.
--
-- ==== __Examples__
--
-- >>> iconsFmtAppend concat "1" []
-- "1"
--
-- >>> iconsFmtAppend concat "1" ["A", "B"]
-- "1:AB"
iconsFmtAppend :: ([String] -> String) -> WorkspaceId -> [String] -> String
iconsFmtAppend :: ([String] -> String) -> String -> [String] -> String
iconsFmtAppend [String] -> String
cat String
ws [String]
is | [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
is   = String
ws
                         | Bool
otherwise = String
ws String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
':' Char -> String -> String
forall a. a -> [a] -> [a]
: [String] -> String
cat [String]
is

-- | Join words with spaces, and wrap the result in delimiters unless there
-- was exactly one element.
--
-- ==== __Examples__
--
-- >>> wrapUnwords "{" "}" ["A", "B"]
-- "{A B}"
--
-- >>> wrapUnwords "{" "}" ["A"]
-- "A"
--
-- >>> wrapUnwords "{" "}" []
-- ""
wrapUnwords :: String -> String -> [String] -> String
wrapUnwords :: String -> String -> [String] -> String
wrapUnwords String
_ String
_ [String
x] = String
x
wrapUnwords String
l String
r [String]
xs  = String -> String -> String -> String
wrap String
l String
r ([String] -> String
unwords [String]
xs)

-- | 'iconConfigFilter' that shows all windows of every workspace.
iconsGetAll :: Maybe (S.Stack Window) -> X [Window]
iconsGetAll :: Maybe (Stack Window) -> X [Window]
iconsGetAll = [Window] -> X [Window]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Window] -> X [Window])
-> (Maybe (Stack Window) -> [Window])
-> Maybe (Stack Window)
-> X [Window]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Stack Window) -> [Window]
forall a. Maybe (Stack a) -> [a]
S.integrate'

-- | 'iconConfigFilter' that shows only the focused window for each workspace.
iconsGetFocus :: Maybe (S.Stack Window) -> X [Window]
iconsGetFocus :: Maybe (Stack Window) -> X [Window]
iconsGetFocus = [Window] -> X [Window]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Window] -> X [Window])
-> (Maybe (Stack Window) -> [Window])
-> Maybe (Stack Window)
-> X [Window]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Window -> [Window]
forall a. Maybe a -> [a]
maybeToList (Maybe Window -> [Window])
-> (Maybe (Stack Window) -> Maybe Window)
-> Maybe (Stack Window)
-> [Window]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stack Window -> Window) -> Maybe (Stack Window) -> Maybe Window
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Stack Window -> Window
forall a. Stack a -> a
S.focus