PriorityChansConverger-0.1: Control/Concurrent/ConcurrentUISupport.hs
{-
Copyright (C) 2009-2010 Andrejs Sisojevs <andrejs.sisojevs@nextmail.ru>
All rights reserved.
For license and copyright information, see the file COPYRIGHT
-}
--------------------------------------------------------------------------
--------------------------------------------------------------------------
-- | A bottleneck for UI from multiple threads. Prevents mixing of output
-- messages. Also makes possible a primitive form of input. By mastering
-- @'cuisUIInput_E'@ and @'cuisUIOutput_E'@ it's possible
-- to construct @'ConcurrentUISupport'@ with different than UI I/O.
module Control.Concurrent.ConcurrentUISupport where
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Concurrent.STM
import Control.Monad
import qualified Control.Exception as E
import Data.List
import qualified Data.Map as M
import Data.Map (Map)
import Data.MyHelpers
import Data.Typeable
import System.IO
-- * ConcurrentUISupport administration
type AskerID = String
type ReadFromConsoleStr = String
type ThreadFinisher = IO ()
data CUISCommand =
NewPage_CUISC
| PlusLine_CUISC
| PutStrLn_CUISC String
| ReadStr_CUISC AskerID deriving (Eq)
data ConcurrentUISupport =
ConcurrentUISupport {
-- | Supported threads are welcome to write their commands here.
-- It is recommended not to use this channel directly -
-- use @'cuisWrite'@, @'cuisReadLn'@ and other mediators instead.
cuisInputTChan :: TChan [CUISCommand]
-- | Map of feedback chans leading to threads, that issue the @'ReadStr_CUISC'@ commands.
, cuisOutputChans :: TVar (Map AskerID (TChan ReadFromConsoleStr))
-- | Call this, when you want to finish supporter thread.
, cuisFinish :: ThreadFinisher
-- | Was @'cuisFinish'@ called?
, cuisSupporterStopCheck :: STM Bool
-- | What to do, when supporter thread finishes?
, cuisFinalizer :: IO ()
-- | How to input, when @'ReadStr_CUISC'@ command comes?
, cuisUIInput_E :: Either (STM String) (IO String)
-- | How to output, when @'PutStrLn_CUISC'@ command comes?
, cuisUIOutput_E :: Either (String -> STM ()) (String -> IO ())
-- | If set, then call it on each @'NewPage_CUISC'@ command.
, cuisPressAnyKey_uiCmd :: Maybe (IO ())
-- | For @(Just i)@, if count of printed lines is > @i@,
-- then automatically issue @'NewPage_CUISC'@ command and
-- set lines counter to 0.
, cuisPressAnyKey_linesCountCond :: Maybe Int
}
defaultConcurrentUISupportIO :: IO ConcurrentUISupport
defaultConcurrentUISupportIO = do
input_tch <- atomically newTChan
breaker_tv <- atomically $ newTVar False
out_chans <- atomically $ newTVar (M.empty)
return ConcurrentUISupport {
cuisInputTChan = input_tch
, cuisOutputChans = out_chans
, cuisFinish = atomically $ writeTVar breaker_tv True
, cuisFinalizer = return ()
, cuisSupporterStopCheck = readTVar breaker_tv
, cuisUIInput_E = Right getLine
, cuisUIOutput_E = Right putStrLn
, cuisPressAnyKey_uiCmd = Just pressAnyKey
, cuisPressAnyKey_linesCountCond = Just 22
}
-- | UI in console + log to file.
defaultConcurrentUISupportIO_logInFile :: FilePath -> IOMode -> IO ConcurrentUISupport
defaultConcurrentUISupportIO_logInFile f_name io_mode = do
input_tch <- atomically newTChan
breaker_tv <- atomically $ newTVar False
out_chans <- atomically $ newTVar (M.empty)
h <- openFile f_name io_mode
hSetBuffering h LineBuffering
return ConcurrentUISupport {
cuisInputTChan = input_tch
, cuisOutputChans = out_chans
, cuisFinish = atomically $ writeTVar breaker_tv True
, cuisFinalizer = hClose h
, cuisSupporterStopCheck = readTVar breaker_tv
, cuisUIInput_E = Right (do { s <- getLine; hPutStrLn h s; return s})
, cuisUIOutput_E = Right (\ s -> (hPutStrLn h s >> putStrLn s))
, cuisPressAnyKey_uiCmd = Just pressAnyKey
, cuisPressAnyKey_linesCountCond = Just 22
}
-- | Whatever @'cuisUIInput_E'@ is - @Left@ or @Right@ - flattern it into IO.
cuisUIInput :: ConcurrentUISupport -> IO String
cuisUIInput cuis =
case cuisUIInput_E cuis of
Left stm_a -> atomically stm_a
Right io_a -> io_a
-- | Whatever @'cuisUIOutput_E'@ is - @Left@ or @Right@ - flattern it into IO.
cuisUIOutput :: ConcurrentUISupport -> String -> IO ()
cuisUIOutput cuis s =
case cuisUIOutput_E cuis of
Left stm_a -> atomically $ stm_a s
Right io_a -> io_a s
-- | Not to be confised with @'cuisUIInput'@, which interfaces with user.
-- This /input/ interfaces with threads, that makes use of it.
--
-- A wrapper around @'cuisInputTChan'@.
cuisInput :: ConcurrentUISupport -> [CUISCommand] -> IO ()
cuisInput cuis cmds = atomically $ writeTChan (cuisInputTChan cuis) cmds
acquirePutStr_fromCmdsList :: [CUISCommand] -> Maybe CUISCommand
acquirePutStr_fromCmdsList cmds =
let find_p e =
case e of
PutStrLn_CUISC _ -> True
_ -> False
in find find_p cmds
acquireReadStr_fromCmdsList :: [CUISCommand] -> Maybe CUISCommand
acquireReadStr_fromCmdsList cmds =
let find_p e =
case e of
ReadStr_CUISC _ -> True
_ -> False
in find find_p cmds
runConcurrentUISupport :: ConcurrentUISupport -> IO ()
runConcurrentUISupport cuis = do
_ <- forkIO $
let _cycle :: Int -> IO ()
_cycle i = do
(stop, mb_cmds) <- atomically $ do
stop <- cuisSupporterStopCheck cuis
case stop of
True -> return (stop, Nothing)
False -> do
cmds <- readTChan $ cuisInputTChan cuis
return (stop, Just cmds)
new_i <- case mb_cmds of
Nothing -> return i
Just cmds -> do
-- Process PutStrLn_CUISC
case acquirePutStr_fromCmdsList cmds of
Nothing -> return ()
Just (PutStrLn_CUISC s) -> cuisUIOutput cuis s
-- Process ReadStr_CUISC
case acquireReadStr_fromCmdsList cmds of
Nothing -> return ()
Just (ReadStr_CUISC asker_id) -> do
t <- cuisUIInput cuis
atomically $ do
outs_map <- readTVar (cuisOutputChans cuis)
asker_chan <- case M.lookup asker_id outs_map of
Nothing -> do
asker_chan <- newTChan
modifyTVar_ (cuisOutputChans cuis) (M.insert asker_id asker_chan)
return asker_chan
Just asker_chan -> return asker_chan
writeTChan asker_chan t
-- Process NewPage_CUISC, PlusLine_CUISC
let cond_1 = (cuisPressAnyKey_linesCountCond cuis >>= \ bnd -> return (i >= bnd) ) == Just True
let cond_2 = NewPage_CUISC `elem` cmds
case cond_1 || cond_2 of
True -> return 0 << whenJust (cuisPressAnyKey_uiCmd cuis)
False -> return (i + (bool2num $ PlusLine_CUISC `elem` cmds))
case stop of
True -> return () -- exit
False -> _cycle new_i
in E.finally (_cycle 0) (cuisFinalizer cuis)
-------------------
return ()
-- * Use these functions to deal with ConcurrentUISupport
cuisWriteSTM :: ConcurrentUISupport -> String -> STM ()
cuisWriteSTM cuis s =
mapM_ (\ _s -> writeTChan (cuisInputTChan cuis) [PlusLine_CUISC, PutStrLn_CUISC _s]) (lines s)
cuisWrite :: ConcurrentUISupport -> String -> IO ()
cuisWrite cuis s =
mapM_ (\ _s -> cuisInput cuis [PlusLine_CUISC, PutStrLn_CUISC _s]) (lines s)
cuisNewPage :: ConcurrentUISupport -> IO ()
cuisNewPage cuis =
cuisInput cuis [NewPage_CUISC]
cuisReadLn :: ConcurrentUISupport -> AskerID -> IO ReadFromConsoleStr
cuisReadLn cuis asker_id = do
cuisInput cuis [ReadStr_CUISC asker_id, PlusLine_CUISC]
atomically $ do
outs_map <- readTVar $ cuisOutputChans cuis
case M.lookup asker_id outs_map of
Nothing -> retry
Just asker_chan -> readTChan asker_chan
------------------------------------------------------------
-- * Few helpers for dealing with exceptions
reportExceptionIfAny :: (String -> IO ()) -> String -> IO a -> IO a
reportExceptionIfAny reportStr caller_f_name = E.handle (\ se@(E.SomeException e) -> reportStr ("An error occurred in function '" ++ caller_f_name ++ "'. Type: " ++ (show $ typeRepTyCon $ typeOf e) ++ ". Representation: " ++ show se) >> E.throw (se :: E.SomeException))
printExceptionIfAny :: String -> IO a -> IO a
printExceptionIfAny = reportExceptionIfAny putStrLn
reportExceptionIfAny_2 :: ConcurrentUISupport -> String -> IO a -> IO a
reportExceptionIfAny_2 cuis = reportExceptionIfAny (cuisWrite cuis)
reportExceptionIfAnySTM :: (String -> STM ()) -> String -> STM a -> STM a
reportExceptionIfAnySTM reportStr caller_f_name stma = catchSTM stma (\ se@(E.SomeException e) -> reportStr ("An error occurred in function '" ++ caller_f_name ++ "'. Type: " ++ (show $ typeRepTyCon $ typeOf e) ++ ". Representation: " ++ show se) >> E.throw (se :: E.SomeException))
reportExceptionIfAnySTM_2 :: ConcurrentUISupport -> String -> STM a -> STM a
reportExceptionIfAnySTM_2 cuis = reportExceptionIfAnySTM (cuisWriteSTM cuis)