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