{-# LANGUAGE InstanceSigs #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Hooks.ShowWName
-- Description :  Like 'XMonad.Layout.ShowWName', but as a logHook
-- Copyright   :  (c) 2022  Tony Zorman
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  Tony Zorman <soliditsallgood@mailbox.org>
--
-- Flash the names of workspaces name when switching to them.  This is a
-- reimplementation of 'XMonad.Layout.ShowWName' as a logHook.
-----------------------------------------------------------------------------

module XMonad.Hooks.ShowWName (
  -- * Usage
  -- $usage
  showWNameLogHook,
  SWNConfig(..),
  flashName,
) where

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

import XMonad
import XMonad.Layout.ShowWName (SWNConfig (..))
import XMonad.Prelude
import XMonad.Util.XUtils (WindowConfig (..), showSimpleWindow)

import Control.Concurrent (threadDelay)

{- $usage

You can use this module with the following in your
@~\/.xmonad\/xmonad.hs@:

> import XMonad.Hooks.ShowWName
>
> main :: IO ()
> main = xmonad $ def
>   { logHook = showWNameLogHook def
>   }

Whenever a workspace gains focus, the above logHook will flash its name.
You can customise the duration of the flash, as well as colours by
customising the 'SWNConfig' argument that 'showWNameLogHook' takes.

Alternatively, you can also bind 'flashName' to a key and manually
invoke it when you want to know which workspace you are on.
-}

-- | LogHook for flashing the name of a workspace upon entering it.
showWNameLogHook :: SWNConfig -> X ()
showWNameLogHook :: SWNConfig -> X ()
showWNameLogHook SWNConfig
cfg = do
  LastShown WorkspaceId
s <- X LastShown
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
  WorkspaceId
foc         <- (WindowSet -> X WorkspaceId) -> X WorkspaceId
forall a. (WindowSet -> X a) -> X a
withWindowSet (WorkspaceId -> X WorkspaceId
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WorkspaceId -> X WorkspaceId)
-> (WindowSet -> WorkspaceId) -> WindowSet -> X WorkspaceId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet -> WorkspaceId
forall i l a s sd. StackSet i l a s sd -> i
W.currentTag)
  Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (WorkspaceId
s WorkspaceId -> WorkspaceId -> Bool
forall a. Eq a => a -> a -> Bool
== WorkspaceId
foc) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do
    SWNConfig -> X ()
flashName SWNConfig
cfg
    LastShown -> X ()
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put (WorkspaceId -> LastShown
LastShown WorkspaceId
foc)

-- | Flash the name of the currently focused workspace.
flashName :: SWNConfig -> X ()
flashName :: SWNConfig -> X ()
flashName SWNConfig
cfg = do
  WorkspaceId
n <- (WindowSet -> X WorkspaceId) -> X WorkspaceId
forall a. (WindowSet -> X a) -> X a
withWindowSet (WorkspaceId -> X WorkspaceId
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WorkspaceId -> X WorkspaceId)
-> (WindowSet -> WorkspaceId) -> WindowSet -> X WorkspaceId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet -> WorkspaceId
forall i l a s sd. StackSet i l a s sd -> i
W.currentTag)
  WindowConfig -> [WorkspaceId] -> X Window
showSimpleWindow WindowConfig
cfg' [WorkspaceId
n] X Window -> (Window -> X ()) -> X ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Window
w -> X ProcessID -> X ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (X ProcessID -> X ()) -> (IO () -> X ProcessID) -> IO () -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> X ProcessID
forall (m :: * -> *). MonadIO m => IO () -> m ProcessID
xfork (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ do
    Display
dpy <- WorkspaceId -> IO Display
openDisplay WorkspaceId
""
    Int -> IO ()
threadDelay (Rational -> Int
forall a. Enum a => a -> Int
fromEnum (Rational -> Int) -> Rational -> Int
forall a b. (a -> b) -> a -> b
$ SWNConfig -> Rational
swn_fade SWNConfig
cfg Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
1000000) -- 1_000_000 needs GHC 8.6.x and up
    IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Display -> Window -> IO ()
destroyWindow Display
dpy Window
w
    Display -> IO ()
closeDisplay Display
dpy
 where
  cfg' :: WindowConfig
  cfg' :: WindowConfig
cfg' = WindowConfig
forall a. Default a => a
def{ winFont :: WorkspaceId
winFont = SWNConfig -> WorkspaceId
swn_font SWNConfig
cfg, winBg :: WorkspaceId
winBg = SWNConfig -> WorkspaceId
swn_bgcolor SWNConfig
cfg, winFg :: WorkspaceId
winFg = SWNConfig -> WorkspaceId
swn_color SWNConfig
cfg }

-- | Last shown workspace.
newtype LastShown = LastShown WorkspaceId
  deriving (Int -> LastShown -> ShowS
[LastShown] -> ShowS
LastShown -> WorkspaceId
(Int -> LastShown -> ShowS)
-> (LastShown -> WorkspaceId)
-> ([LastShown] -> ShowS)
-> Show LastShown
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
showList :: [LastShown] -> ShowS
$cshowList :: [LastShown] -> ShowS
show :: LastShown -> WorkspaceId
$cshow :: LastShown -> WorkspaceId
showsPrec :: Int -> LastShown -> ShowS
$cshowsPrec :: Int -> LastShown -> ShowS
Show, ReadPrec [LastShown]
ReadPrec LastShown
Int -> ReadS LastShown
ReadS [LastShown]
(Int -> ReadS LastShown)
-> ReadS [LastShown]
-> ReadPrec LastShown
-> ReadPrec [LastShown]
-> Read LastShown
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [LastShown]
$creadListPrec :: ReadPrec [LastShown]
readPrec :: ReadPrec LastShown
$creadPrec :: ReadPrec LastShown
readList :: ReadS [LastShown]
$creadList :: ReadS [LastShown]
readsPrec :: Int -> ReadS LastShown
$creadsPrec :: Int -> ReadS LastShown
Read)

instance ExtensionClass LastShown where
  initialValue :: LastShown
  initialValue :: LastShown
initialValue  = WorkspaceId -> LastShown
LastShown WorkspaceId
""

  extensionType :: LastShown -> StateExtension
  extensionType :: LastShown -> StateExtension
extensionType = LastShown -> StateExtension
forall a. (Read a, Show a, ExtensionClass a) => a -> StateExtension
PersistentExtension