{-
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)