1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
|
{-# LANGUAGE TupleSections, FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
-----------------------------------------------------------------------------
-- |
-- Module : Plugins.Monitors.Accordion
-- Copyright : (c) 2024 Enrico Maria De Angelis
-- License : BSD-style (see LICENSE)
--
-- Maintainer : Enrico Maria De Angelis <enricomaria.dean6elis@gmail.com>
-- Stability : unstable
-- Portability : unportable
--
-- A plugin to group adjacent plugins and make them, as a whole, shrinkable to
-- an alternate text upon clicking.
--
-----------------------------------------------------------------------------
module Xmobar.Plugins.Accordion (defaultTuning, makeAccordion, makeAccordion', Tuning(..)) where
import Control.Concurrent (rtsSupportsBoundThreads)
import Control.Concurrent.Async (concurrently_, mapConcurrently_)
import Control.Exception (finally)
import Control.Monad.Extra (whenM)
import Control.Monad (forever, join)
import Control.Monad.IO.Class (liftIO, MonadIO)
import Control.Monad.Reader (MonadReader, runReaderT, ask)
import Control.Monad.State.Strict (MonadState, evalStateT, get, modify')
import Data.IORef (atomicModifyIORef', newIORef, readIORef, IORef)
import GHC.IO.Handle.FD (withFileBlocking)
import System.Directory (removeFile)
import System.IO (IOMode(ReadMode), hGetContents', hPutStrLn, stderr)
import System.Process (readProcessWithExitCode)
import Xmobar.Run.Exec (Exec(..), tenthSeconds)
-- TODO: Ideally, I'd have just `Accordion`, and not `Tuning`, but since
-- `Accordion` is polymorphic, I can't have a `defaultAccordion` constructor
-- with `plugins = []`, because that leaves `a` undetermined.
-- So I have move all non-polymorphic typed members in `Tuning`, allowing for
-- default values at least for those members.
data Accordion a = Accordion {
tuning :: Tuning
, plugins :: [a]
, shortPlugins :: [a]
} deriving (Show, Read)
makeAccordion :: Exec a => Tuning -> [a] -> Accordion a
makeAccordion t rs = Accordion { tuning = t, plugins = rs, shortPlugins = [] }
makeAccordion' :: Exec a => Tuning -> [a] -> [a] -> Accordion a
makeAccordion' t rs rs' = Accordion { tuning = t, plugins = rs, shortPlugins = rs' }
data Tuning = Tuning {
alias' :: String
, initial :: Bool
, expand :: String
, shrink :: String
} deriving (Read, Show)
defaultTuning :: Tuning
defaultTuning = Tuning {
alias' = "accordion"
, initial = True
, expand = "<>"
, shrink = "><"
}
instance Exec a => Exec (Accordion a) where
alias (Accordion Tuning{..} _ _) = alias'
start (Accordion Tuning{..} runnables shortRunnables) cb
| not rtsSupportsBoundThreads = do
hPutStrLn stderr threadedRuntimeWarning
cb threadedRuntimeWarning
| otherwise = do
clicked <- newIORef False
(_, n, _) <- readProcessWithExitCode "uuidgen" [] ""
let pipe = "/tmp/accordion-" ++ removeLinebreak n
(_, _, _) <- readProcessWithExitCode "mkfifo" [pipe] ""
concurrently_ (forever $ do "" <- withFileBlocking pipe ReadMode hGetContents'
atomicModifyIORef' clicked (const (True, ())))
(do
strRefs <- mapM (newIORef . const "") runnables
strRefs' <- mapM (newIORef . const "") shortRunnables
let processClick = forever (do liftIO (tenthSeconds 1)
whenM (liftIO $ readIORef clicked)
(do liftIO $ clear clicked
modify' not)
get >>= loop pipe)
`runReaderT` (strRefs, strRefs')
`evalStateT` initial
let startRunnables = zipWith start
(runnables ++ shortRunnables)
(map writeToRef $ strRefs ++ strRefs')
parallel_ $ processClick:startRunnables)
`finally` removeFile pipe
where
loop :: (MonadIO m,
MonadState Bool m,
MonadReader ([IORef String], [IORef String]) m)
=> String -> Bool -> m ()
loop pipe bool = do
(strRefs, strRefs') <- ask
text <- join <$> mapM (liftIO . readIORef) (if bool then strRefs else strRefs')
liftIO $ cb $ text ++ attachClick pipe (if bool then shrink else expand)
parallel_ = mapConcurrently_ id
threadedRuntimeWarning :: String
threadedRuntimeWarning =
"xmobar: warning: Accordion requires the threaded RTS; rebuild with -threaded"
writeToRef :: IORef a -> a -> IO ()
writeToRef strRef = atomicModifyIORef' strRef . const . (,())
clear :: IORef Bool -> IO ()
clear = (`atomicModifyIORef'` const (False, ()))
removeLinebreak :: [a] -> [a]
removeLinebreak = init
attachClick :: String -> String -> String
attachClick file icon = "<action=`echo -n > " ++ file ++ "`>" ++ icon ++ "</action>"
|
