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
|
{-# LANGUAGE TupleSections, FlexibleContexts #-}
-----------------------------------------------------------------------------
-- |
-- 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.Async (withAsync)
import Control.Exception (finally)
import Control.Monad (forever, join, when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (runReaderT, ask)
import Control.Monad.State.Strict (evalStateT, get, modify')
import Data.IORef (atomicModifyIORef', newIORef, readIORef, IORef)
import Data.Maybe (isJust)
import System.Directory (removeFile)
import System.Exit (ExitCode(..))
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, Read a, Show a) => Exec (Accordion a) where
alias (Accordion Tuning { alias' = name } _ _) = name
start (Accordion Tuning { initial = initial'
, expand = expandIcon
, shrink = shrinkIcon }
runnables
shortRunnables)
cb = do
clicked <- newIORef Nothing
(_, n, _) <- readProcessWithExitCode "uuidgen" [] ""
let pipe = "/tmp/accordion-" ++ removeLinebreak n
(_, _, _) <- readProcessWithExitCode "mkfifo" [pipe] ""
withAsync (forever $ do (ret, _, _) <- readProcessWithExitCode "cat" [pipe] ""
case ret of
ExitSuccess -> atomicModifyIORef' clicked (const (Just (), ()))
ExitFailure _ -> error "how is this possible?")
(const $ do
strRefs <- mapM (newIORef . const "") runnables
strRefs' <- mapM (newIORef . const "") shortRunnables
foldr (\(runnable, strRef) acc -> withAsync (start runnable (writeToRef strRef)) (const acc))
(forever (do liftIO (tenthSeconds 1)
clicked' <- liftIO $ readIORef clicked
when (isJust clicked')
(do liftIO $ clear clicked
modify' not)
b <- get
loop b pipe)
`runReaderT` (strRefs, strRefs')
`evalStateT` initial')
(zip (runnables ++ shortRunnables)
(strRefs ++ strRefs')))
`finally` removeFile pipe
where
loop b p = do
(strRefs, strRefs') <- ask
text <- join <$> mapM (liftIO . readIORef) (if b then strRefs else strRefs')
liftIO $ cb $ text ++ attachClick p (if b then shrinkIcon else expandIcon)
writeToRef :: IORef a -> a -> IO ()
writeToRef strRef = atomicModifyIORef' strRef . const . (,())
clear :: IORef (Maybe a) -> IO ()
clear = (`atomicModifyIORef'` const (Nothing, ()))
removeLinebreak :: [a] -> [a]
removeLinebreak = init
attachClick :: String -> String -> String
attachClick file icon = "<action=`echo 1 > " ++ file ++ "`>" ++ icon ++ "</action>"
|
