{-# 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.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')
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 {
    forall a. Accordion a -> Tuning
tuning :: Tuning
  , forall a. Accordion a -> [a]
plugins :: [a]
  , forall a. Accordion a -> [a]
shortPlugins :: [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, shortPlugins :: [a]
shortPlugins = [] }

makeAccordion' :: Exec a => Tuning -> [a] -> [a] -> Accordion a
makeAccordion' :: forall a. Exec a => Tuning -> [a] -> [a] -> Accordion a
makeAccordion' Tuning
t [a]
rs [a]
rs' = Accordion { tuning :: Tuning
tuning = Tuning
t, plugins :: [a]
plugins = [a]
rs, shortPlugins :: [a]
shortPlugins = [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 => Exec (Accordion a) where
  alias :: Accordion a -> String
alias (Accordion Tuning{Bool
String
alias' :: Tuning -> String
initial :: Tuning -> Bool
expand :: Tuning -> String
shrink :: Tuning -> String
alias' :: String
initial :: Bool
expand :: String
shrink :: String
..} [a]
_ [a]
_) = String
alias'
  start :: Accordion a -> (String -> IO ()) -> IO ()
start (Accordion Tuning{Bool
String
alias' :: Tuning -> String
initial :: Tuning -> Bool
expand :: Tuning -> String
shrink :: Tuning -> String
alias' :: String
initial :: Bool
expand :: String
shrink :: String
..} [a]
runnables [a]
shortRunnables) String -> IO ()
cb = do
    clicked <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
    (_, 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] ""
    concurrently_ (forever $ do "" <- withFileBlocking pipe ReadMode hGetContents'
                                atomicModifyIORef' clicked (const (True, ())))
                  (do
                      strRefs <- mapM (newIORef . const "") runnables
                      strRefs' <- mapM (newIORef . const "") shortRunnables
                      let processClick = ReaderT ([IORef String], [IORef String]) (StateT Bool IO) ()
-> ReaderT ([IORef String], [IORef String]) (StateT Bool IO) a
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (do IO ()
-> ReaderT ([IORef String], [IORef String]) (StateT Bool IO) ()
forall a.
IO a -> ReaderT ([IORef String], [IORef String]) (StateT Bool IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> IO ()
tenthSeconds Int
1)
                                                     ReaderT ([IORef String], [IORef String]) (StateT Bool IO) Bool
-> ReaderT ([IORef String], [IORef String]) (StateT Bool IO) ()
-> ReaderT ([IORef String], [IORef String]) (StateT Bool IO) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (IO Bool
-> ReaderT ([IORef String], [IORef String]) (StateT Bool IO) Bool
forall a.
IO a -> ReaderT ([IORef String], [IORef String]) (StateT Bool IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool
 -> ReaderT ([IORef String], [IORef String]) (StateT Bool IO) Bool)
-> IO Bool
-> ReaderT ([IORef String], [IORef String]) (StateT Bool IO) Bool
forall a b. (a -> b) -> a -> b
$ IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
clicked)
                                                           (do IO ()
-> ReaderT ([IORef String], [IORef String]) (StateT Bool IO) ()
forall a.
IO a -> ReaderT ([IORef String], [IORef String]) (StateT Bool IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
 -> ReaderT ([IORef String], [IORef String]) (StateT Bool IO) ())
-> IO ()
-> ReaderT ([IORef String], [IORef String]) (StateT Bool IO) ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> IO ()
clear IORef Bool
clicked
                                                               (Bool -> Bool)
-> ReaderT ([IORef String], [IORef String]) (StateT Bool IO) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' Bool -> Bool
not)
                                                     ReaderT ([IORef String], [IORef String]) (StateT Bool IO) Bool
forall s (m :: * -> *). MonadState s m => m s
get ReaderT ([IORef String], [IORef String]) (StateT Bool IO) Bool
-> (Bool
    -> ReaderT ([IORef String], [IORef String]) (StateT Bool IO) ())
-> ReaderT ([IORef String], [IORef String]) (StateT Bool IO) ()
forall a b.
ReaderT ([IORef String], [IORef String]) (StateT Bool IO) a
-> (a
    -> ReaderT ([IORef String], [IORef String]) (StateT Bool IO) b)
-> ReaderT ([IORef String], [IORef String]) (StateT Bool IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String
-> Bool
-> ReaderT ([IORef String], [IORef String]) (StateT Bool IO) ()
forall (m :: * -> *).
(MonadIO m, MonadState Bool m,
 MonadReader ([IORef String], [IORef String]) m) =>
String -> Bool -> m ()
loop String
pipe)
                                           ReaderT ([IORef String], [IORef String]) (StateT Bool IO) a
-> ([IORef String], [IORef String]) -> StateT Bool IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` ([IORef String]
strRefs, [IORef String]
strRefs')
                                           StateT Bool IO a -> Bool -> IO a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
`evalStateT` Bool
initial
                      let startRunnables = (a -> (String -> IO ()) -> IO ())
-> [a] -> [String -> IO ()] -> [IO ()]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> (String -> IO ()) -> IO ()
forall e. Exec e => e -> (String -> IO ()) -> IO ()
start
                                                   ([a]
runnables [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
shortRunnables)
                                                   ((IORef String -> String -> IO ())
-> [IORef String] -> [String -> IO ()]
forall a b. (a -> b) -> [a] -> [b]
map IORef String -> String -> IO ()
forall a. IORef a -> a -> IO ()
writeToRef ([IORef String] -> [String -> IO ()])
-> [IORef String] -> [String -> IO ()]
forall a b. (a -> b) -> a -> b
$ [IORef String]
strRefs [IORef String] -> [IORef String] -> [IORef String]
forall a. [a] -> [a] -> [a]
++ [IORef String]
strRefs')
                      parallel_ $ processClick:startRunnables)
      `finally` removeFile pipe
    where
      loop :: (MonadIO m,
               MonadState Bool m,
               MonadReader ([IORef String], [IORef String]) m)
           => String -> Bool -> m ()
      loop :: forall (m :: * -> *).
(MonadIO m, MonadState Bool m,
 MonadReader ([IORef String], [IORef String]) m) =>
String -> Bool -> m ()
loop String
pipe Bool
bool = do
        (strRefs, strRefs') <- m ([IORef String], [IORef String])
forall r (m :: * -> *). MonadReader r m => m r
ask
        text <- join <$> mapM (liftIO . readIORef) (if bool then strRefs else strRefs')
        liftIO $ cb $ text ++ attachClick pipe (if bool then shrink else expand)
      parallel_ :: [IO b] -> IO ()
parallel_ = (IO b -> IO b) -> [IO b] -> IO ()
forall (f :: * -> *) a b. Foldable f => (a -> IO b) -> f a -> IO ()
mapConcurrently_ IO b -> IO b
forall a. a -> a
id

writeToRef :: IORef a -> a -> IO ()
writeToRef :: forall a. 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
. (,())

clear :: IORef Bool -> IO ()
clear :: IORef Bool -> IO ()
clear = (IORef Bool -> (Bool -> (Bool, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
`atomicModifyIORef'` (Bool, ()) -> Bool -> (Bool, ())
forall a b. a -> b -> a
const (Bool
False, ()))

removeLinebreak :: [a] -> [a]
removeLinebreak :: forall a. [a] -> [a]
removeLinebreak = [a] -> [a]
forall a. HasCallStack => [a] -> [a]
init

attachClick :: String -> String -> String
attachClick :: String -> ShowS
attachClick String
file String
icon = String
"<action=`echo -n > " 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>"