-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Util.Loggers.NamedScratchpad
-- Description :  A collection of Loggers for "XMonad.Util.NamedScratchpad".
-- Copyright   :  (c) Brandon S Allbery <allbery.b@gmail.com>
-- License     :  BSD-style (see LICENSE)
--
-- Maintainer  :  Brandon S Allbery <allbery.b@gmail.com>
-- Stability   :  unstable
-- Portability :  unportable
--
-- "XMonad.Util.Loggers" for "XMonad.Util.NamedScratchpad"
--
-----------------------------------------------------------------------------

module XMonad.Util.Loggers.NamedScratchpad (-- * Usage
                                            -- $usage
                                            nspTrackStartup
                                           ,nspTrackHook
                                           ,nspActiveIcon
                                           ,nspActive
                                           ,nspActive') where

import XMonad.Core
import Graphics.X11.Xlib (Window)
import Graphics.X11.Xlib.Extras (Event(..))
import XMonad.Util.Loggers (Logger)
import XMonad.Util.NamedScratchpad (NamedScratchpad(..))
import qualified XMonad.Util.ExtensibleState as XS
import XMonad.Prelude (All (..), chr, foldM, forM)
import qualified Data.IntMap as M
import qualified XMonad.StackSet as W (allWindows)

-- $usage
-- This is a set of 'Logger's for 'NamedScratchpad's.
-- It provides a 'startupHook' and 'handleEventHook' to keep track of
-- 'NamedScratchpad's, and several possible 'Logger's for use in
-- 'XMonad.Hooks.StatusBar.PP.ppExtras'.
--
-- You must add 'nspTrackStartup' to your 'startupHook' to initialize
-- 'NamedScratchpad' tracking and to detect any currently running
-- 'NamedScratchpad's on restart, and 'nspTrackHook' to your 'handleEventHook'
-- to track the coming and going of 'NamedScratchpad's.
--
-- Why would you want to do this? If you aren't using 'EwmhDesktops', this
-- gives you a way to see what 'NamedScratchpad's are running. If you are
-- using 'EwmhDesktops' then you can get that from a taskbar... but you may
-- have noticed that selecting the window from the taskbar moves you to
-- the 'NSP' workspace instead of moving the window to the current workspace.
-- (This is difficult to change; "minimizing" by moving it back to 'NSP'
-- is even harder.)
-- I hide the 'NamedScratchpad's from the taskbar and use this to track
-- them instead (see "XMonad.Util.NoTaskbar").

-- The extension data for tracking NSP windows
newtype NSPTrack = NSPTrack [Maybe Window]
instance ExtensionClass NSPTrack where
  initialValue :: NSPTrack
initialValue = [Maybe Window] -> NSPTrack
NSPTrack []

-- | 'startupHook' to initialize scratchpad activation tracking
--
-- > , startupHook = ... <> nspTrackStartup scratchpads
--
-- If you kickstart the 'logHook', do it /after/ 'nspTrackStartup'!
nspTrackStartup :: [NamedScratchpad] -> X ()
nspTrackStartup :: [NamedScratchpad] -> X ()
nspTrackStartup [NamedScratchpad]
ns = do
  let ns'i :: IntMap (Maybe a)
ns'i = [(Int, Maybe a)] -> IntMap (Maybe a)
forall a. [(Int, a)] -> IntMap a
M.fromList ([(Int, Maybe a)] -> IntMap (Maybe a))
-> [(Int, Maybe a)] -> IntMap (Maybe a)
forall a b. (a -> b) -> a -> b
$ [Int] -> [Maybe a] -> [(Int, Maybe a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] ([Maybe a] -> [(Int, Maybe a)]) -> [Maybe a] -> [(Int, Maybe a)]
forall a b. (a -> b) -> a -> b
$ (NamedScratchpad -> Maybe a) -> [NamedScratchpad] -> [Maybe a]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe a -> NamedScratchpad -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) [NamedScratchpad]
ns
  ns' <- (WindowSet -> X (IntMap (Maybe Window)))
-> X (IntMap (Maybe Window))
forall a. (WindowSet -> X a) -> X a
withWindowSet ((WindowSet -> X (IntMap (Maybe Window)))
 -> X (IntMap (Maybe Window)))
-> (WindowSet -> X (IntMap (Maybe Window)))
-> X (IntMap (Maybe Window))
forall a b. (a -> b) -> a -> b
$ (IntMap (Maybe Window) -> Window -> X (IntMap (Maybe Window)))
-> IntMap (Maybe Window) -> [Window] -> X (IntMap (Maybe Window))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([NamedScratchpad]
-> IntMap (Maybe Window) -> Window -> X (IntMap (Maybe Window))
isSp [NamedScratchpad]
ns) IntMap (Maybe Window)
forall {a}. IntMap (Maybe a)
ns'i ([Window] -> X (IntMap (Maybe Window)))
-> (WindowSet -> [Window])
-> WindowSet
-> X (IntMap (Maybe Window))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet -> [Window]
forall a i l s sd. Eq a => StackSet i l a s sd -> [a]
W.allWindows
  XS.put (NSPTrack (map snd $ M.toAscList ns'))

isSp :: [NamedScratchpad] -> M.IntMap (Maybe Window) -> Window -> X (M.IntMap (Maybe Window))
isSp :: [NamedScratchpad]
-> IntMap (Maybe Window) -> Window -> X (IntMap (Maybe Window))
isSp [NamedScratchpad]
ns IntMap (Maybe Window)
ws Window
w = do
  n <- Query (Maybe Int) -> Window -> X (Maybe Int)
forall a. Query a -> Window -> X a
runQuery ([NamedScratchpad] -> Query (Maybe Int)
scratchpadWindow [NamedScratchpad]
ns) Window
w
  return $ case n of
            Maybe Int
Nothing -> IntMap (Maybe Window)
ws
            Just Int
n' -> Int
-> Maybe Window -> IntMap (Maybe Window) -> IntMap (Maybe Window)
forall a. Int -> a -> IntMap a -> IntMap a
M.insert Int
n' (Window -> Maybe Window
forall a. a -> Maybe a
Just Window
w) IntMap (Maybe Window)
ws

scratchpadWindow :: [NamedScratchpad] -> Query (Maybe Int)
scratchpadWindow :: [NamedScratchpad] -> Query (Maybe Int)
scratchpadWindow [NamedScratchpad]
ns = (Maybe Int -> (Int, NamedScratchpad) -> Query (Maybe Int))
-> Maybe Int -> [(Int, NamedScratchpad)] -> Query (Maybe Int)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Maybe Int -> (Int, NamedScratchpad) -> Query (Maybe Int)
sp' Maybe Int
forall a. Maybe a
Nothing ([Int] -> [NamedScratchpad] -> [(Int, NamedScratchpad)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [NamedScratchpad]
ns)
  where sp' :: Maybe Int -> (Int,NamedScratchpad) -> Query (Maybe Int)
        sp' :: Maybe Int -> (Int, NamedScratchpad) -> Query (Maybe Int)
sp' r :: Maybe Int
r@(Just Int
_) (Int, NamedScratchpad)
_              = Maybe Int -> Query (Maybe Int)
forall a. a -> Query a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
r
        sp' Maybe Int
Nothing    (Int
n,NS String
_ String
_ Query Bool
q ManageHook
_) = Query Bool
q Query Bool -> (Bool -> Query (Maybe Int)) -> Query (Maybe Int)
forall a b. Query a -> (a -> Query b) -> Query b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
p -> Maybe Int -> Query (Maybe Int)
forall a. a -> Query a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int -> Query (Maybe Int)) -> Maybe Int -> Query (Maybe Int)
forall a b. (a -> b) -> a -> b
$ if Bool
p then Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n else Maybe Int
forall a. Maybe a
Nothing

-- | 'handleEventHook' to track scratchpad activation/deactivation
--
-- > , handleEventHook = ... <> nspTrackHook scratchpads
nspTrackHook :: [NamedScratchpad] -> Event -> X All
nspTrackHook :: [NamedScratchpad] -> Event -> X All
nspTrackHook [NamedScratchpad]
_ DestroyWindowEvent{ev_window :: Event -> Window
ev_window = Window
w} = do
  (NSPTrack -> NSPTrack) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify ((NSPTrack -> NSPTrack) -> X ()) -> (NSPTrack -> NSPTrack) -> X ()
forall a b. (a -> b) -> a -> b
$ \(NSPTrack [Maybe Window]
ws) -> [Maybe Window] -> NSPTrack
NSPTrack ([Maybe Window] -> NSPTrack) -> [Maybe Window] -> NSPTrack
forall a b. (a -> b) -> a -> b
$ (Maybe Window -> Maybe Window) -> [Maybe Window] -> [Maybe Window]
forall a b. (a -> b) -> [a] -> [b]
map (\Maybe Window
sw -> if Maybe Window
sw Maybe Window -> Maybe Window -> Bool
forall a. Eq a => a -> a -> Bool
== Window -> Maybe Window
forall a. a -> Maybe a
Just Window
w then Maybe Window
forall a. Maybe a
Nothing else Maybe Window
sw) [Maybe Window]
ws
  All -> X All
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)
nspTrackHook [NamedScratchpad]
ns ConfigureRequestEvent{ev_window :: Event -> Window
ev_window = Window
w} = do
  NSPTrack ws <- X NSPTrack
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
  ws' <- forM (zip3 [0 :: Integer ..] ws ns) $ \(Integer
_,Maybe Window
w',NS String
_ String
_ Query Bool
q ManageHook
_) -> do
    p <- Query Bool -> Window -> X Bool
forall a. Query a -> Window -> X a
runQuery Query Bool
q Window
w
    return $ if p then Just w else w'
  XS.put $ NSPTrack ws'
  return (All True)
nspTrackHook [NamedScratchpad]
_ Event
_ = All -> X All
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)

-- | 'Logger' for scratchpads' state, using Unicode characters as "icons".
--
-- > , ppExtras = [..., nspActive' iconChars showActive showInactive, ...]
nspActiveIcon :: [Char] -> (String -> String) -> (String -> String) -> Logger
nspActiveIcon :: String -> (String -> String) -> (String -> String) -> Logger
nspActiveIcon String
icns String -> String
act String -> String
inact = do
  NSPTrack ws <- X NSPTrack
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
  return $ if null ws
            then Nothing
            else let icon' Int
n = if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
icns then String
icns String -> Int -> Char
forall a. HasCallStack => [a] -> Int -> a
!! Int
n else Char
'\NUL'
                     icon  Int
n = let c :: Char
c = Int -> Char
icon' Int
n
                                in [if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\NUL' then Int -> Char
chr (Int
0x2460 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) else Char
c]
                     ckact Int
n Maybe a
w = let icn :: String
icn = Int -> String
icon Int
n
                                  in case Maybe a
w of
                                      Maybe a
Nothing -> String -> String
inact String
icn
                                      Just a
_  -> String -> String
act   String
icn
                     s = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Int -> Maybe Window -> String)
-> [Int] -> [Maybe Window] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Maybe Window -> String
forall {a}. Int -> Maybe a -> String
ckact [Int
0..] [Maybe Window]
ws
                  in Just s

-- | 'Logger' with String-s (and no defaults)
--
-- > , ppExtras = [..., nspActive iconStrs showActive showInactive, ...]
nspActive :: [String] -> (String -> String) -> (String -> String) -> Logger
nspActive :: [String] -> (String -> String) -> (String -> String) -> Logger
nspActive [String]
icns String -> String
act String -> String
inact = do
  NSPTrack ws <- X NSPTrack
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
  return $ if null ws
            then Nothing
            else let  ckact Int
n Maybe a
w = let icn :: String
icn = [String]
icns [String] -> Int -> String
forall a. HasCallStack => [a] -> Int -> a
!! Int
n
                                    in case Maybe a
w of
                                        Maybe a
Nothing -> String -> String
inact String
icn
                                        Just a
_  -> String -> String
act   String
icn
                      s = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Int -> Maybe Window -> String)
-> [Int] -> [Maybe Window] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Maybe Window -> String
forall {a}. Int -> Maybe a -> String
ckact [Int
0..] [Maybe Window]
ws
                  in Just s

-- | Variant of the above getting the String-s from the 'NamedScratchpad's
nspActive' :: [NamedScratchpad] -> (String -> String) -> (String -> String) -> Logger
nspActive' :: [NamedScratchpad]
-> (String -> String) -> (String -> String) -> Logger
nspActive' [NamedScratchpad]
ns = [String] -> (String -> String) -> (String -> String) -> Logger
nspActive ((NamedScratchpad -> String) -> [NamedScratchpad] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map NamedScratchpad -> String
name [NamedScratchpad]
ns)