{-# LANGUAGE TupleSections, FlexibleContexts #-}
module Xmobar.Plugins.Accordion (defaultTuning, 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)
import Data.Maybe (isJust)
import System.Directory (removeFile)
import System.Exit (ExitCode(..))
import System.Process (readProcessWithExitCode)
import Xmobar.Run.Exec (Exec(..), tenthSeconds)
data Accordion a = Accordion {
forall a. Accordion a -> Tuning
tuning :: Tuning
, forall a. Accordion a -> [a]
plugins :: [a]
} deriving (Int -> Accordion a -> ShowS
[Accordion a] -> ShowS
Accordion a -> String
(Int -> Accordion a -> ShowS)
-> (Accordion a -> String)
-> ([Accordion a] -> ShowS)
-> Show (Accordion a)
forall a. Show a => Int -> Accordion a -> ShowS
forall a. Show a => [Accordion a] -> ShowS
forall a. Show a => Accordion a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Accordion a -> ShowS
showsPrec :: Int -> Accordion a -> ShowS
$cshow :: forall a. Show a => Accordion a -> String
show :: Accordion a -> String
$cshowList :: forall a. Show a => [Accordion a] -> ShowS
showList :: [Accordion a] -> ShowS
Show, ReadPrec [Accordion a]
ReadPrec (Accordion a)
Int -> ReadS (Accordion a)
ReadS [Accordion a]
(Int -> ReadS (Accordion a))
-> ReadS [Accordion a]
-> ReadPrec (Accordion a)
-> ReadPrec [Accordion a]
-> Read (Accordion a)
forall a. Read a => ReadPrec [Accordion a]
forall a. Read a => ReadPrec (Accordion a)
forall a. Read a => Int -> ReadS (Accordion a)
forall a. Read a => ReadS [Accordion a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. Read a => Int -> ReadS (Accordion a)
readsPrec :: Int -> ReadS (Accordion a)
$creadList :: forall a. Read a => ReadS [Accordion a]
readList :: ReadS [Accordion a]
$creadPrec :: forall a. Read a => ReadPrec (Accordion a)
readPrec :: ReadPrec (Accordion a)
$creadListPrec :: forall a. Read a => ReadPrec [Accordion a]
readListPrec :: ReadPrec [Accordion a]
Read)
makeAccordion :: Exec a => Tuning -> [a] -> Accordion a
makeAccordion :: forall a. Exec a => Tuning -> [a] -> Accordion a
makeAccordion Tuning
t [a]
rs = Accordion { tuning :: Tuning
tuning = Tuning
t, plugins :: [a]
plugins = [a]
rs }
data Tuning = Tuning {
Tuning -> String
alias' :: String
, Tuning -> Bool
initial :: Bool
, Tuning -> String
expand :: String
, Tuning -> String
shrink :: String
} deriving (ReadPrec [Tuning]
ReadPrec Tuning
Int -> ReadS Tuning
ReadS [Tuning]
(Int -> ReadS Tuning)
-> ReadS [Tuning]
-> ReadPrec Tuning
-> ReadPrec [Tuning]
-> Read Tuning
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Tuning
readsPrec :: Int -> ReadS Tuning
$creadList :: ReadS [Tuning]
readList :: ReadS [Tuning]
$creadPrec :: ReadPrec Tuning
readPrec :: ReadPrec Tuning
$creadListPrec :: ReadPrec [Tuning]
readListPrec :: ReadPrec [Tuning]
Read, Int -> Tuning -> ShowS
[Tuning] -> ShowS
Tuning -> String
(Int -> Tuning -> ShowS)
-> (Tuning -> String) -> ([Tuning] -> ShowS) -> Show Tuning
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Tuning -> ShowS
showsPrec :: Int -> Tuning -> ShowS
$cshow :: Tuning -> String
show :: Tuning -> String
$cshowList :: [Tuning] -> ShowS
showList :: [Tuning] -> ShowS
Show)
defaultTuning :: Tuning
defaultTuning :: Tuning
defaultTuning = Tuning {
alias' :: String
alias' = String
"accordion"
, initial :: Bool
initial = Bool
True
, expand :: String
expand = String
"<>"
, shrink :: String
shrink = String
"><"
}
instance (Exec a, Read a, Show a) => Exec (Accordion a) where
alias :: Accordion a -> String
alias (Accordion Tuning { alias' :: Tuning -> String
alias' = String
name } [a]
_) = String
name
start :: Accordion a -> (String -> IO ()) -> IO ()
start (Accordion Tuning { initial :: Tuning -> Bool
initial = Bool
initial'
, expand :: Tuning -> String
expand = String
expand'
, shrink :: Tuning -> String
shrink = String
shrink' }
[a]
runnables)
String -> IO ()
cb = do
clicked <- Maybe () -> IO (IORef (Maybe ()))
forall a. a -> IO (IORef a)
newIORef Maybe ()
forall a. Maybe a
Nothing
(_, n, _) <- readProcessWithExitCode "uuidgen" [] ""
let pipe = String
"/tmp/accordion-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall {a}. [a] -> [a]
removeLinebreak String
n
(_, _, _) <- readProcessWithExitCode "mkfifo" [pipe] ""
withAsync (forever $ do (ret, _, _) <- readProcessWithExitCode "cat" [pipe] ""
case ret of
ExitCode
ExitSuccess -> IORef (Maybe ()) -> (Maybe () -> (Maybe (), ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Maybe ())
clicked ((Maybe (), ()) -> Maybe () -> (Maybe (), ())
forall a b. a -> b -> a
const (() -> Maybe ()
forall a. a -> Maybe a
Just (), ()))
ExitFailure Int
_ -> String -> IO ()
forall a. HasCallStack => String -> a
error String
"how is this possible?")
(const $ do
srefs <- mapM (newIORef . const "") runnables
foldr (\(a
runnable, IORef String
sref) IO ()
acc -> IO () -> (Async () -> IO ()) -> IO ()
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (a -> (String -> IO ()) -> IO ()
forall e. Exec e => e -> (String -> IO ()) -> IO ()
start a
runnable (IORef String -> String -> IO ()
forall {a}. IORef a -> a -> IO ()
writeToRef IORef String
sref)) (IO () -> Async () -> IO ()
forall a b. a -> b -> a
const IO ()
acc))
(forever (do liftIO (tenthSeconds 1)
clicked' <- liftIO $ readIORef clicked
when (isJust clicked')
(do liftIO $ clear clicked
modify' not)
b <- get
if b then loop pipe else liftIO $ cb (click pipe expand'))
`runReaderT` srefs `evalStateT` initial')
(zip runnables srefs))
`finally` removeFile pipe
where
click :: String -> ShowS
click String
file String
icon = String
"<action=`echo 1 > " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
file String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"`>" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
icon String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"</action>"
clear :: IORef (Maybe a) -> IO ()
clear = (IORef (Maybe a) -> (Maybe a -> (Maybe a, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
`atomicModifyIORef'` (Maybe a, ()) -> Maybe a -> (Maybe a, ())
forall a b. a -> b -> a
const (Maybe a
forall a. Maybe a
Nothing, ()))
removeLinebreak :: [a] -> [a]
removeLinebreak = [a] -> [a]
forall a. HasCallStack => [a] -> [a]
init
writeToRef :: IORef a -> a -> IO ()
writeToRef IORef a
strRef = IORef a -> (a -> (a, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef a
strRef ((a -> (a, ())) -> IO ()) -> (a -> a -> (a, ())) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, ()) -> a -> (a, ())
forall a b. a -> b -> a
const ((a, ()) -> a -> (a, ())) -> (a -> (a, ())) -> a -> a -> (a, ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,())
loop :: String -> m ()
loop String
p = do
srefs <- m [IORef String]
forall r (m :: * -> *). MonadReader r m => m r
ask
text <- join <$> mapM (liftIO . readIORef) srefs
liftIO $ cb $ text ++ click p shrink'