{-# 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 {
    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 = 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

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>"