Scroller.hs

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

import Control.Concurrent.Async (concurrently_)
import Control.Exception (finally)
import Control.Monad (forever, when)
import Control.Monad.State.Strict (evalStateT, get, liftIO, modify')
import Data.IORef (atomicModifyIORef', newIORef, readIORef)
import Data.Maybe (fromJust, isJust, maybe)
import Flow ((.>))
import GHC.IO.Handle.FD (withFileBlocking)
import System.Directory (removeFile)
import System.IO (IOMode(ReadMode), hGetContents')
import System.Process (readProcessWithExitCode)

import XNobar.Internal.Notification (makeId)
import XNobar.Internal.Scroller (remove, merge, scroll, showNotifs, Config(..))
import XNobar.Server (NotificationsRef, fetch)
import Control.Concurrent (threadDelay)

scroller :: Config -> (String -> IO ()) -> NotificationsRef -> IO ()
scroller config@(Config{..}) callback notifs = do
  (_, n, _) <- readProcessWithExitCode "uuidgen" [] ""
  let pipe = "/tmp/xnobar-" ++ removeLinebreak n where removeLinebreak = init
  (_, _, _) <- readProcessWithExitCode "mkfifo" [pipe] ""
  clicked <- newIORef Nothing
  concurrently_ (forever $ do out <- withFileBlocking pipe ReadMode hGetContents'
                              atomicModifyIORef' clicked (const (Just out, ())))
                (evalStateT (forever $ update clicked pipe) Nothing)
    `finally` removeFile pipe
    where
      update clicked pipe = do

        newNotifs <- liftIO $ fetch notifs

        clicked' <- liftIO $ readIORef clicked

        when (isJust clicked') $ liftIO $ clear 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 i = let i' = read i
                    in if i' == 0
                      then Nothing
                      else Just $ makeId i'
          tenthSeconds = threadDelay . (100000*)
          onlyIf b a = if b then a else id