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
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 {
cuisInputTChan :: TChan [CUISCommand]
, cuisOutputChans :: TVar (Map AskerID (TChan ReadFromConsoleStr))
, cuisFinish :: ThreadFinisher
, cuisSupporterStopCheck :: STM Bool
, cuisFinalizer :: IO ()
, cuisUIInput_E :: Either (STM String) (IO String)
, cuisUIOutput_E :: Either (String -> STM ()) (String -> IO ())
, cuisPressAnyKey_uiCmd :: Maybe (IO ())
, 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
}
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
}
cuisUIInput :: ConcurrentUISupport -> IO String
cuisUIInput cuis =
case cuisUIInput_E cuis of
Left stm_a -> atomically stm_a
Right io_a -> io_a
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
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
case acquirePutStr_fromCmdsList cmds of
Nothing -> return ()
Just (PutStrLn_CUISC s) -> cuisUIOutput cuis s
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
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 ()
False -> _cycle new_i
in E.finally (_cycle 0) (cuisFinalizer cuis)
return ()
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
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)