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)
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 (onlyIf, 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
  clicked <- newIORef Nothing
  (_, n, _) <- readProcessWithExitCode "uuidgen" [] ""
  let pipe = "/tmp/xnobar-" ++ removeLinebreak n where removeLinebreak = init
  (_, _, _) <- readProcessWithExitCode "mkfifo" [pipe] ""
  withAsync (forever $ do out <- withFileBlocking pipe ReadMode hGetContents'
                          atomicModifyIORef' clicked (const (Just out, ())))
            (const $ 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 = makeId . read
          tenthSeconds = threadDelay . (100000*)