Scroller.hs

{-# LANGUAGE RecordWildCards #-}
module XNobar.Scroller (scroller, Config(..)) where

import Control.Concurrent.Async (withAsync)
import Control.Exception (finally)
import Control.Monad (forever, when)
import Control.Monad.State.Strict (evalStateT, get, liftIO, modify')
import Data.IORef (atomicModifyIORef', newIORef, readIORef, IORef)
import Data.Maybe (fromJust, isJust, maybe)
import Flow ((.>))
import System.Directory (removeFile)
import System.Exit (ExitCode(..))
import System.Process (readProcessWithExitCode)
import Xmobar (tenthSeconds)

import XNobar.Internal.Notification (makeId)
import XNobar.Internal.Scroller (onlyIf, remove, merge, scroll, showNotifs, Config(..))
import XNobar.Server (NotificationsRef, fetch)
import Control.Monad.IO.Class (MonadIO)

scroller :: Config -> (String -> IO ()) -> NotificationsRef -> IO ()
scroller config@(Config{..}) callback notifs
  = withIOState (\clicked pipe -> const $ evalStateT (forever (update clicked pipe)) Nothing)
    where
      removeLinebreak = init
      update clicked pipe = do

        newNotifs <- liftIO $ fetch notifs

        clicked' <- readIOState clicked

        when (isJust clicked') $ clearIOState clicked

        modify' $ onlyIf (isJust clicked')
                         (remove (getId $ fromJust clicked'))
               .> onlyIf (not $ null newNotifs)
                         (merge newNotifs)
               .> scroll

        get >>= maybe (noNewsPrefix ++ idleText) (showNotifs config pipe)
             .> (liftIO . callback)

        liftIO $ tenthSeconds scrollPeriod
        where
          clear = (`atomicModifyIORef'` const (Nothing, ()))
          getId = makeId . read

newtype IOState a = IOState (IORef a)

readIOState :: MonadIO m => IOState a -> m a
readIOState (IOState ref) = liftIO $ readIORef ref

clearIOState :: (MonadIO m, Monoid a) => IOState a -> m ()
clearIOState (IOState ref) = liftIO $ clear ref
  where
    clear = (`atomicModifyIORef'` const (mempty, ()))

withIOState f =  do
  clicked <- newIORef Nothing
  (_, n, _) <- readProcessWithExitCode "uuidgen" [] ""
  let pipe = "/tmp/xnobar-" ++ removeLinebreak n
  (_, _, _) <- readProcessWithExitCode "mkfifo" [pipe] ""
  withAsync (forever $ do (ret, out, _) <- readProcessWithExitCode "cat" [pipe] ""
                          case ret of
                            ExitSuccess -> atomicModifyIORef' clicked (const (Just (removeLinebreak out), ()))
                            ExitFailure _ -> error "how is this possible?")
            (f (IOState clicked) pipe)
    `finally` removeFile pipe
    where
      removeLinebreak = init