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 {
            -- | Write unicode characters to stdout.
            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 ()
    }

-- | Operations needed for terminal-style interaction.
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 ()
    }

-- This hack is needed to grab latest writes from some other thread.
-- Without it, if you are using another thread to process the logging
-- and write on screen via exposed externalPrint, latest writes from
-- this thread are not able to cross the thread boundary in time.
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
                      -- We don't want to raise exceptions when doing cleanup.
                      Event
_ -> IO ()
loopUntilFlushed

-- | Operations needed for file-style interaction.
--
-- Backends can assume that getLocaleLine, getLocaleChar and maybeReadNewline
-- are "wrapped" by wrapFileInput.
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,
            -- ^ Perform an action without echoing input.
            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 ()
        }

-- | Are we using terminal-style interaction?
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

-- Specific, hidden terminal action type
-- Generic terminal actions which are independent of the Term being used.
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

-- Utility function for drawLineDiff instances.
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
    -- first, see if any events are already queued up (from a key/ctrl-c
    -- event or from a previous call to getEvent where we read in multiple
    -- keys)
    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)

-----------------------------------
-- Utility functions for the various backends.

-- | Utility function since we're not using the new IO library yet.
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
>>)

-- | Utility function for changing a property of a terminal for the duration of
-- a computation.
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)

-- | Returns one 8-bit word.  Needs to be wrapped by hWithBinaryMode.
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

-- If another character is immediately available, and it is a newline, consume it.
--
-- Two portability fixes:
--
-- 1) By itself, this (by using hReady) might crash on invalid characters.
-- The handle should be set to binary mode or a TextEncoder that
-- transliterates or ignores invalid input.
--
-- 1) Note that in ghc-6.8.3 and earlier, hReady returns False at an EOF,
-- whereas in ghc-6.10.1 and later it throws an exception.  (GHC trac #1063).
-- This code handles both of those cases.
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

-- | Utility function to correctly get a line of input as an undecoded ByteString.
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
    -- It's more efficient to use B.getLine, but that function throws an
    -- error if the Handle (e.g., stdin) is set to NoBuffering.
    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