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 Control.Exception (Exception, SomeException(..))
import Control.Monad.Catch
( MonadMask
, bracket
, handle
, throwM
, finally
)
import Data.Word
import Control.Exception (fromException, AsyncException(..))
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, MonadIO m, MonadMask 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 m . (MonadIO m, MonadMask m) => m a -> m 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 . (MonadIO m, MonadMask 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, MonadIO m, MonadMask m)
=> CommandMonad m where
runCompletion :: (String,String) -> m (String,[Completion])
instance (MonadTrans t, CommandMonad m, MonadReader Prefs (t m),
MonadIO (t m), MonadMask (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 :: (MonadIO m, MonadMask m) => Handle -> m a -> m a
hWithBinaryMode h = bracket (liftIO $ hGetEncoding h)
(maybe (return ()) (liftIO . hSetEncoding h))
. const . (liftIO (hSetBinaryMode h True) >>)
bracketSet :: (MonadMask m, MonadIO 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 :: MonadMask m => a -> m a -> m a
returnOnEOF x = handle $ \e -> if isEOFError e
then return x
else throwM 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