{- Copyright (C) 2009-2010 Andrejs Sisojevs 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)