module System.Console.Haskeline.Term where
import System.Console.Haskeline.Monads
import System.Console.Haskeline.LineState
import System.Console.Haskeline.Key
import System.Console.Haskeline.Prefs(Prefs)
import Control.Concurrent
import Control.Concurrent.Chan
import Data.Typeable
import Data.ByteString (ByteString)
import Control.Exception.Extensible (fromException, AsyncException(..),bracket_)
class (MonadReader Layout m, MonadException m) => Term m where
reposition :: Layout -> LineChars -> m ()
moveToNextLine :: LineChars -> m ()
printLines :: [String] -> m ()
drawLineDiff :: LineChars -> LineChars -> m ()
clearLayout :: m ()
ringBell :: Bool -> m ()
data RunTerm = RunTerm {
putStrOut :: String -> IO (),
encodeForTerm :: String -> IO ByteString,
decodeForTerm :: ByteString -> IO String,
getLocaleChar :: IO Char,
termOps :: Maybe TermOps,
wrapInterrupt :: MonadException m => m a -> m a,
closeTerm :: IO ()
}
data TermOps = TermOps {runTerm :: RunTermType,
getLayout :: IO Layout}
type RunTermType = forall m a . (MonadLayout m, MonadException m, MonadReader Prefs m)
=> (forall t . (MonadTrans t, Term (t m), MonadException (t m))
=> (t m Event -> t m a)) -> m a
matchInit :: Eq a => [a] -> [a] -> ([a],[a])
matchInit (x:xs) (y:ys) | x == y = matchInit xs ys
matchInit xs ys = (xs,ys)
data Event = WindowResize | KeyInput Key | ErrorEvent SomeException
deriving Show
keyEventLoop :: IO [Event] -> Chan Event -> IO Event
keyEventLoop readEvents eventChan = do
isEmpty <- isEmptyChan eventChan
if not isEmpty
then readChan eventChan
else do
lock <- newEmptyMVar
tid <- forkIO $ handleErrorEvent (readerLoop lock)
readChan eventChan `finally` do
putMVar lock ()
killThread tid
where
readerLoop lock = do
es <- readEvents
if null es
then readerLoop lock
else
bracket_ (putMVar lock ()) (takeMVar lock) $
writeList2Chan eventChan es
handleErrorEvent = handle $ \e -> case fromException e of
Just ThreadKilled -> return ()
_ -> writeChan eventChan (ErrorEvent e)
class (MonadReader Layout m, MonadIO m) => MonadLayout m where
data Interrupt = Interrupt
deriving (Show,Typeable,Eq)
instance Exception Interrupt where
data Layout = Layout {width, height :: Int}
deriving (Show,Eq)