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 :: forall (m :: * -> *). Term m => LineChars -> m ()
drawLine = forall (m :: * -> *). Term m => LineChars -> LineChars -> m ()
drawLineDiff ([],[])
clearLine :: forall (m :: * -> *). Term m => LineChars -> m ()
clearLine = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *). Term m => LineChars -> LineChars -> m ()
drawLineDiff ([],[])
data RunTerm = RunTerm {
RunTerm -> String -> IO ()
putStrOut :: String -> IO (),
RunTerm -> Either TermOps FileOps
termOps :: Either TermOps FileOps,
RunTerm
-> forall a (m :: * -> *). (MonadIO m, MonadMask m) => m a -> m a
wrapInterrupt :: forall a m . (MonadIO m, MonadMask m) => m a -> m a,
RunTerm -> IO ()
closeTerm :: IO ()
}
data TermOps = TermOps
{ TermOps -> IO Layout
getLayout :: IO Layout
, TermOps
-> forall (m :: * -> *) a.
CommandMonad m =>
(m Event -> m a) -> m a
withGetEvent :: forall m a . CommandMonad m => (m Event -> m a) -> m a
, TermOps -> forall (m :: * -> *). CommandMonad m => EvalTerm m
evalTerm :: forall m . CommandMonad m => EvalTerm m
, TermOps -> [Key] -> IO ()
saveUnusedKeys :: [Key] -> IO ()
, TermOps -> String -> IO ()
externalPrint :: String -> IO ()
}
flushEventQueue :: (String -> IO ()) -> TChan Event -> IO ()
flushEventQueue :: (String -> IO ()) -> TChan Event -> IO ()
flushEventQueue String -> IO ()
print' TChan Event
eventChan = IO ()
yield forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
loopUntilFlushed
where loopUntilFlushed :: IO ()
loopUntilFlushed = do
Bool
flushed <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> STM Bool
isEmptyTChan TChan Event
eventChan
if Bool
flushed then forall (m :: * -> *) a. Monad m => a -> m a
return () else do
Event
event <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> STM a
readTChan TChan Event
eventChan
case Event
event of
ExternalPrint String
str -> do
String -> IO ()
print' (String
str forall a. [a] -> [a] -> [a]
++ String
"\n") forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
loopUntilFlushed
Event
_ -> IO ()
loopUntilFlushed
data FileOps = FileOps {
FileOps
-> forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
withoutInputEcho :: forall m a . (MonadIO m, MonadMask m) => m a -> m a,
FileOps -> forall a. IO a -> IO a
wrapFileInput :: forall a . IO a -> IO a,
FileOps -> MaybeT IO String
getLocaleLine :: MaybeT IO String,
FileOps -> MaybeT IO Char
getLocaleChar :: MaybeT IO Char,
FileOps -> IO ()
maybeReadNewline :: IO ()
}
isTerminalStyle :: RunTerm -> Bool
isTerminalStyle :: RunTerm -> Bool
isTerminalStyle RunTerm
r = case RunTerm -> Either TermOps FileOps
termOps RunTerm
r of
Left TermOps{} -> Bool
True
Either TermOps FileOps
_ -> Bool
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 :: forall (n :: * -> *) (m :: * -> *).
(forall a. n a -> m a)
-> (forall a. m a -> n a) -> EvalTerm n -> EvalTerm m
mapEvalTerm forall a. n a -> m a
eval forall a. m a -> n a
liftE (EvalTerm forall a. n a -> n a
eval' forall a. n a -> n a
liftE')
= forall (m :: * -> *) (n :: * -> *).
(Term n, CommandMonad n) =>
(forall a. n a -> m a) -> (forall a. m a -> n a) -> EvalTerm m
EvalTerm (forall a. n a -> m a
eval forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. n a -> n a
eval') (forall a. n a -> n a
liftE' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. m a -> n a
liftE)
data Interrupt = Interrupt
deriving (Int -> Interrupt -> ShowS
[Interrupt] -> ShowS
Interrupt -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Interrupt] -> ShowS
$cshowList :: [Interrupt] -> ShowS
show :: Interrupt -> String
$cshow :: Interrupt -> String
showsPrec :: Int -> Interrupt -> ShowS
$cshowsPrec :: Int -> Interrupt -> ShowS
Show,Typeable,Interrupt -> Interrupt -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Interrupt -> Interrupt -> Bool
$c/= :: Interrupt -> Interrupt -> Bool
== :: Interrupt -> Interrupt -> Bool
$c== :: Interrupt -> Interrupt -> Bool
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 {-# OVERLAPPABLE #-} (MonadTrans t, CommandMonad m, MonadReader Prefs (t m),
MonadIO (t m), MonadMask (t m),
MonadReader Layout (t m))
=> CommandMonad (t m) where
runCompletion :: (String, String) -> t m (String, [Completion])
runCompletion = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
CommandMonad m =>
(String, String) -> m (String, [Completion])
runCompletion
matchInit :: Eq a => [a] -> [a] -> ([a],[a])
matchInit :: forall a. Eq a => [a] -> [a] -> ([a], [a])
matchInit (a
x:[a]
xs) (a
y:[a]
ys) | a
x forall a. Eq a => a -> a -> Bool
== a
y = forall a. Eq a => [a] -> [a] -> ([a], [a])
matchInit [a]
xs [a]
ys
matchInit [a]
xs [a]
ys = ([a]
xs,[a]
ys)
data Event
= WindowResize
| KeyInput [Key]
| ErrorEvent SomeException
| ExternalPrint String
deriving Int -> Event -> ShowS
[Event] -> ShowS
Event -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Event] -> ShowS
$cshowList :: [Event] -> ShowS
show :: Event -> String
$cshow :: Event -> String
showsPrec :: Int -> Event -> ShowS
$cshowsPrec :: Int -> Event -> ShowS
Show
keyEventLoop :: IO [Event] -> TChan Event -> IO Event
keyEventLoop :: IO [Event] -> TChan Event -> IO Event
keyEventLoop IO [Event]
readEvents TChan Event
eventChan = do
Bool
isEmpty <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> STM Bool
isEmptyTChan TChan Event
eventChan
if Bool -> Bool
not Bool
isEmpty
then forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> STM a
readTChan TChan Event
eventChan
else do
ThreadId
tid <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
handleErrorEvent IO ()
readerLoop
forall a. STM a -> IO a
atomically (forall a. TChan a -> STM a
readTChan TChan Event
eventChan) forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` ThreadId -> IO ()
killThread ThreadId
tid
where
readerLoop :: IO ()
readerLoop = do
[Event]
es <- IO [Event]
readEvents
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Event]
es
then IO ()
readerLoop
else forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a. TChan a -> a -> STM ()
writeTChan TChan Event
eventChan) [Event]
es
handleErrorEvent :: IO () -> IO ()
handleErrorEvent = forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle forall a b. (a -> b) -> a -> b
$ \SomeException
e -> case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
Just AsyncException
ThreadKilled -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe AsyncException
_ -> forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> a -> STM ()
writeTChan TChan Event
eventChan (SomeException -> Event
ErrorEvent SomeException
e)
saveKeys :: TChan Event -> [Key] -> IO ()
saveKeys :: TChan Event -> [Key] -> IO ()
saveKeys TChan Event
ch = forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TChan a -> a -> STM ()
writeTChan TChan Event
ch forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> Event
KeyInput
data Layout = Layout {Layout -> Int
width, Layout -> Int
height :: Int}
deriving (Int -> Layout -> ShowS
[Layout] -> ShowS
Layout -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Layout] -> ShowS
$cshowList :: [Layout] -> ShowS
show :: Layout -> String
$cshow :: Layout -> String
showsPrec :: Int -> Layout -> ShowS
$cshowsPrec :: Int -> Layout -> ShowS
Show,Layout -> Layout -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Layout -> Layout -> Bool
$c/= :: Layout -> Layout -> Bool
== :: Layout -> Layout -> Bool
$c== :: Layout -> Layout -> Bool
Eq)
hWithBinaryMode :: (MonadIO m, MonadMask m) => Handle -> m a -> m a
hWithBinaryMode :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Handle -> m a -> m a
hWithBinaryMode Handle
h = forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> IO (Maybe TextEncoding)
hGetEncoding Handle
h)
(forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> Bool -> IO ()
hSetBinaryMode Handle
h Bool
True) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>)
bracketSet :: (MonadMask m, MonadIO m) => IO a -> (a -> IO ()) -> a -> m b -> m b
bracketSet :: forall (m :: * -> *) a b.
(MonadMask m, MonadIO m) =>
IO a -> (a -> IO ()) -> a -> m b -> m b
bracketSet IO a
getState a -> IO ()
set a
newState m b
f = forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
getState)
(forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO ()
set)
(\a
_ -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (a -> IO ()
set a
newState) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m b
f)
hGetByte :: Handle -> MaybeT IO Word8
hGetByte :: Handle -> MaybeT IO Word8
hGetByte = forall a. (Handle -> IO a) -> Handle -> MaybeT IO a
guardedEOF forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a. Enum a => Int -> a
toEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO Char
hGetChar
guardedEOF :: (Handle -> IO a) -> Handle -> MaybeT IO a
guardedEOF :: forall a. (Handle -> IO a) -> Handle -> MaybeT IO a
guardedEOF Handle -> IO a
f Handle
h = do
Bool
eof <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
hIsEOF Handle
h
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not Bool
eof)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Handle -> IO a
f Handle
h
hMaybeReadNewline :: Handle -> IO ()
hMaybeReadNewline :: Handle -> IO ()
hMaybeReadNewline Handle
h = forall (m :: * -> *) a. MonadMask m => a -> m a -> m a
returnOnEOF () forall a b. (a -> b) -> a -> b
$ do
Bool
ready <- Handle -> IO Bool
hReady Handle
h
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ready forall a b. (a -> b) -> a -> b
$ do
Char
c <- Handle -> IO Char
hLookAhead Handle
h
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char
c forall a. Eq a => a -> a -> Bool
== Char
'\n') forall a b. (a -> b) -> a -> b
$ IO Char
getChar forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
returnOnEOF :: MonadMask m => a -> m a -> m a
returnOnEOF :: forall (m :: * -> *) a. MonadMask m => a -> m a -> m a
returnOnEOF a
x = forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle forall a b. (a -> b) -> a -> b
$ \IOError
e -> if IOError -> Bool
isEOFError IOError
e
then forall (m :: * -> *) a. Monad m => a -> m a
return a
x
else forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM IOError
e
hGetLocaleLine :: Handle -> MaybeT IO ByteString
hGetLocaleLine :: Handle -> MaybeT IO ByteString
hGetLocaleLine = forall a. (Handle -> IO a) -> Handle -> MaybeT IO a
guardedEOF forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
BufferMode
buff <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> IO BufferMode
hGetBuffering Handle
h
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ if BufferMode
buff forall a. Eq a => a -> a -> Bool
== BufferMode
NoBuffering
then forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> ByteString
BC.pack forall a b. (a -> b) -> a -> b
$ Handle -> IO String
System.IO.hGetLine Handle
h
else Handle -> IO ByteString
BC.hGetLine Handle
h