> {-# LANGUAGE OverloadedStrings, FlexibleContexts #-}
> module Main where
> import Control.Concurrent
> import Control.Concurrent.STM
> import qualified Data.Text as T
> import qualified Data.Text.IO as TIO
> import Control.Exception
> import System.IO.Error (IOError)
> import qualified System.IO.Error as E
> import Data.Time
> import System.IO
> import System.Environment
> import System.Locale
> import qualified Data.Concurrent.Queue as Q
> data Msg = Line T.Text
> | Tick
> data EMsg = Done
> | Error IOError
> gitLine :: IO (Either IOError T.Text)
> gitLine = try TIO.getLine
> ticksProc :: (Q.PutQueue q STM) => Int -> q Msg -> IO ()
> ticksProc interval chan = do
> threadDelay (interval * 100)
> atomically $ Q.put chan $! Tick
> ticksProc interval chan
> linesProc :: (Q.PutQueue q STM) => q EMsg -> q Msg -> IO ()
> linesProc echan chan = do
> l <- gitLine
> case l of
> Left err
> | E.isEOFError err -> do
> atomically $ Q.put echan Done
> | otherwise -> do
> atomically $ Q.put echan $ Error err
> Right line -> do
> atomically $ Q.put chan $ Line line
> linesProc echan chan
> output :: (Q.TakeQueue q STM) => (T.Text -> IO ()) -> q EMsg -> q Msg -> T.Text -> IO ()
> output disp echan chan state = do
> a <- atomically $ do
> m <- Q.take chan
> return $ do
> case m of
> Tick -> do
> disp state
> output disp echan chan state
> Line line -> do
> disp line
> output disp echan chan line
> `orElse` do
> m <- Q.take echan
> return $ do
> case m of
> Error e ->
> throwIO e
> Done ->
> return ()
> a
> display :: T.Text -> T.Text -> IO ()
> display sep txt = do
> time <- getZonedTime
> TIO.putStrLn $ T.concat [txt, sep, T.pack $ formatTime defaultTimeLocale (iso8601DateFormat $ Just "%H:%M:%S") time]
> hFlush stdout
> main :: IO ()
> main = do
> istate <- getArgs
> chan <- newEmptyTMVarIO
> echan <- newEmptyTMVarIO
> _ <- forkIO $ linesProc echan chan
> _ <- forkIO $ ticksProc 500 chan
> output (display $ T.pack $ unwords $ istate) echan chan ""