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 System.Console.Haskeline.Completion(Completion)
import Control.Concurrent
import Control.Concurrent.STM
import Data.Word
import Control.Exception (fromException, AsyncException(..),bracket_)
import Data.Typeable
import System.IO
import Control.Monad(liftM,when,guard)
import System.IO.Error (isEOFError)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BC
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 ()
drawLine, clearLine :: Term m => LineChars -> m ()
drawLine = drawLineDiff ([],[])
clearLine = flip drawLineDiff ([],[])
data RunTerm = RunTerm {
putStrOut :: String -> IO (),
termOps :: Either TermOps FileOps,
wrapInterrupt :: forall a . IO a -> IO a,
closeTerm :: IO ()
}
data TermOps = TermOps
{ getLayout :: IO Layout
, withGetEvent :: forall m a . CommandMonad m => (m Event -> m a) -> m a
, evalTerm :: forall m . CommandMonad m => EvalTerm m
, saveUnusedKeys :: [Key] -> IO ()
, externalPrint :: String -> IO ()
}
flushEventQueue :: (String -> IO ()) -> TChan Event -> IO ()
flushEventQueue print' eventChan = yield >> loopUntilFlushed
where loopUntilFlushed = do
flushed <- atomically $ isEmptyTChan eventChan
if flushed then return () else do
event <- atomically $ readTChan eventChan
case event of
ExternalPrint str -> do
print' (str ++ "\n") >> loopUntilFlushed
_ -> loopUntilFlushed
data FileOps = FileOps {
withoutInputEcho :: forall m a . MonadException m => m a -> m a,
wrapFileInput :: forall a . IO a -> IO a,
getLocaleLine :: MaybeT IO String,
getLocaleChar :: MaybeT IO Char,
maybeReadNewline :: IO ()
}
isTerminalStyle :: RunTerm -> Bool
isTerminalStyle r = case termOps r of
Left TermOps{} -> True
_ -> False
data EvalTerm m
= forall n . (Term n, CommandMonad n)
=> EvalTerm (forall a . n a -> m a) (forall a . m a -> n a)
mapEvalTerm :: (forall a . n a -> m a) -> (forall a . m a -> n a)
-> EvalTerm n -> EvalTerm m
mapEvalTerm eval liftE (EvalTerm eval' liftE')
= EvalTerm (eval . eval') (liftE' . liftE)
data Interrupt = Interrupt
deriving (Show,Typeable,Eq)
instance Exception Interrupt where
class (MonadReader Prefs m , MonadReader Layout m, MonadException m)
=> CommandMonad m where
runCompletion :: (String,String) -> m (String,[Completion])
instance (MonadTrans t, CommandMonad m, MonadReader Prefs (t m),
MonadException (t m),
MonadReader Layout (t m))
=> CommandMonad (t m) where
runCompletion = lift . runCompletion
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
| ExternalPrint String
deriving Show
keyEventLoop :: IO [Event] -> TChan Event -> IO Event
keyEventLoop readEvents eventChan = do
isEmpty <- atomically $ isEmptyTChan eventChan
if not isEmpty
then atomically $ readTChan eventChan
else do
tid <- forkIO $ handleErrorEvent readerLoop
atomically (readTChan eventChan) `finally` killThread tid
where
readerLoop = do
es <- readEvents
if null es
then readerLoop
else atomically $ mapM_ (writeTChan eventChan) es
handleErrorEvent = handle $ \e -> case fromException e of
Just ThreadKilled -> return ()
_ -> atomically $ writeTChan eventChan (ErrorEvent e)
saveKeys :: TChan Event -> [Key] -> IO ()
saveKeys ch = atomically . writeTChan ch . KeyInput
data Layout = Layout {width, height :: Int}
deriving (Show,Eq)
hWithBinaryMode :: MonadException m => Handle -> m a -> m a
hWithBinaryMode h = bracket (liftIO $ hGetEncoding h)
(maybe (return ()) (liftIO . hSetEncoding h))
. const . (liftIO (hSetBinaryMode h True) >>)
bracketSet :: (Eq a, MonadException m) => IO a -> (a -> IO ()) -> a -> m b -> m b
bracketSet getState set newState f = bracket (liftIO getState)
(liftIO . set)
(\_ -> liftIO (set newState) >> f)
hGetByte :: Handle -> MaybeT IO Word8
hGetByte = guardedEOF $ liftM (toEnum . fromEnum) . hGetChar
guardedEOF :: (Handle -> IO a) -> Handle -> MaybeT IO a
guardedEOF f h = do
eof <- lift $ hIsEOF h
guard (not eof)
lift $ f h
hMaybeReadNewline :: Handle -> IO ()
hMaybeReadNewline h = returnOnEOF () $ do
ready <- hReady h
when ready $ do
c <- hLookAhead h
when (c == '\n') $ getChar >> return ()
returnOnEOF :: MonadException m => a -> m a -> m a
returnOnEOF x = handle $ \e -> if isEOFError e
then return x
else throwIO e
hGetLocaleLine :: Handle -> MaybeT IO ByteString
hGetLocaleLine = guardedEOF $ \h -> do
buff <- liftIO $ hGetBuffering h
liftIO $ if buff == NoBuffering
then fmap BC.pack $ System.IO.hGetLine h
else BC.hGetLine h