{-# 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, 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)

-- 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]
} 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'