{-|
 - Module: Reflex.Process.Repl
 - Description: Run repl-like processes in a reflex application.
-}

{-# Language BangPatterns #-}
{-# Language FlexibleContexts #-}
{-# Language FlexibleInstances #-}
{-# Language LambdaCase #-}
{-# Language MultiParamTypeClasses #-}
{-# Language MultiWayIf #-}
{-# Language OverloadedStrings #-}
{-# Language RecursiveDo #-}
{-# Language ScopedTypeVariables #-}
{-# Language StandaloneDeriving #-}
{-# Language TupleSections #-}
module Reflex.Process.Repl
  ( Repl(..)
  , Cmd(..)
  , Accum(..)
  , accumHandle
  , accumHandles
  , flushAccum
  , repl
  , Lines(..)
  , emptyLines
  , addLines
  , linesFromBS
  , unLines
  , lastWholeLine
  , splitLinesOn
  , Command
  , unsafeCommand
  , command
  , commands
  , displayCommand
  , sendCommands
  , testRepl
  , mkTestCommands
  , assertStdoutEq
  , assertStderrEq
  , assertStderr
  , assertStdout
  , assertHandleEq
  , assertHandle
  , assertCmd
  ) where

import Control.Concurrent (forkIO)
import Control.Monad
import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Align (align)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as C8
import Data.Foldable (toList)
import Data.IORef
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe (fromMaybe)
import qualified Data.Sequence as Seq
import Data.Sequence (Seq)
import Data.These (These(..))
import Reflex
import Reflex.Host.Headless
import Reflex.Process
import System.Exit (ExitCode)
import qualified System.Posix.Signals as Signals
import qualified System.Process as P

-- * REPL

-- | Output of a 'repl' session
data Repl t = Repl
  { Repl t -> Process t ByteString ByteString
_repl_process :: Process t ByteString ByteString
  -- ^ The underlying repl process, which can be used to access the process handle, the raw output, and so on.
  , Repl t -> Event t (Map Int Cmd)
_repl_finished :: Event t (Map Int Cmd)
  -- ^ An event of commands that the repl has finished executing and their
  -- associated output. The 'Int' here represents the order in which commands
  -- were submitted to the repl.
  , Repl t -> Dynamic t (Int, Maybe Cmd)
_repl_started :: Dynamic t (Int, Maybe Cmd)
  -- ^ A dynamic of the currently running command, if any, and its output. The
  -- 'Int' here represents the ordering of this command relative to the ones in
  -- '_repl_finished'.
  , Repl t -> Event t ExitCode
_repl_exited :: Event t ExitCode
  -- ^ An event that fires when the repl exits
  }

-- | An individual command submitted to the repl, and its output
data Cmd = Cmd
  { Cmd -> Command
_cmd_stdin :: Command
  , Cmd -> Lines
_cmd_stdout :: Lines
  , Cmd -> Lines
_cmd_stderr :: Lines
  }
  deriving (Cmd -> Cmd -> Bool
(Cmd -> Cmd -> Bool) -> (Cmd -> Cmd -> Bool) -> Eq Cmd
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cmd -> Cmd -> Bool
$c/= :: Cmd -> Cmd -> Bool
== :: Cmd -> Cmd -> Bool
$c== :: Cmd -> Cmd -> Bool
Eq, Eq Cmd
Eq Cmd
-> (Cmd -> Cmd -> Ordering)
-> (Cmd -> Cmd -> Bool)
-> (Cmd -> Cmd -> Bool)
-> (Cmd -> Cmd -> Bool)
-> (Cmd -> Cmd -> Bool)
-> (Cmd -> Cmd -> Cmd)
-> (Cmd -> Cmd -> Cmd)
-> Ord Cmd
Cmd -> Cmd -> Bool
Cmd -> Cmd -> Ordering
Cmd -> Cmd -> Cmd
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Cmd -> Cmd -> Cmd
$cmin :: Cmd -> Cmd -> Cmd
max :: Cmd -> Cmd -> Cmd
$cmax :: Cmd -> Cmd -> Cmd
>= :: Cmd -> Cmd -> Bool
$c>= :: Cmd -> Cmd -> Bool
> :: Cmd -> Cmd -> Bool
$c> :: Cmd -> Cmd -> Bool
<= :: Cmd -> Cmd -> Bool
$c<= :: Cmd -> Cmd -> Bool
< :: Cmd -> Cmd -> Bool
$c< :: Cmd -> Cmd -> Bool
compare :: Cmd -> Cmd -> Ordering
$ccompare :: Cmd -> Cmd -> Ordering
$cp1Ord :: Eq Cmd
Ord, Int -> Cmd -> ShowS
[Cmd] -> ShowS
Cmd -> String
(Int -> Cmd -> ShowS)
-> (Cmd -> String) -> ([Cmd] -> ShowS) -> Show Cmd
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Cmd] -> ShowS
$cshowList :: [Cmd] -> ShowS
show :: Cmd -> String
$cshow :: Cmd -> String
showsPrec :: Int -> Cmd -> ShowS
$cshowsPrec :: Int -> Cmd -> ShowS
Show)

-- | An accumulator used to track and combine the repl's output streams 
data Accum = Accum
  { Accum -> (Map Int Lines, Int, Lines)
_accum_stdout :: (Map Int Lines, Int, Lines)
  , Accum -> (Map Int Lines, Int, Lines)
_accum_stderr :: (Map Int Lines, Int, Lines)
  }

-- | Accumulate a handle, grouping its output by prompts
accumHandle
  :: (Int -> ByteString -> Bool)
  -> ByteString
  -> (Map Int Lines, Int, Lines)
  -> (Map Int Lines, Int, Lines)
accumHandle :: (Int -> ByteString -> Bool)
-> ByteString
-> (Map Int Lines, Int, Lines)
-> (Map Int Lines, Int, Lines)
accumHandle Int -> ByteString -> Bool
isPrompt ByteString
new (Map Int Lines
done, Int
cur, Lines
l) =
  let l' :: Lines
l' = ByteString -> Lines -> Lines
addLines ByteString
new Lines
l
  in case (ByteString -> Bool) -> Lines -> Maybe (Lines, Lines)
splitLinesOn (Int -> ByteString -> Bool
isPrompt (Int
cur Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) Lines
l' of
        Maybe (Lines, Lines)
Nothing -> (Map Int Lines
done, Int
cur, Lines
l')
        Just (Lines
before, Lines
after) ->
          let (Map Int Lines
newMap, Int
newCur, Lines
newLines) = (Int -> ByteString -> Bool)
-> ByteString
-> (Map Int Lines, Int, Lines)
-> (Map Int Lines, Int, Lines)
accumHandle Int -> ByteString -> Bool
isPrompt (Lines -> ByteString
unLines Lines
after) (Int -> Lines -> Map Int Lines -> Map Int Lines
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
cur Lines
before Map Int Lines
done, Int
curInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, Lines
forall a. Monoid a => a
mempty)
          in (Map Int Lines -> Map Int Lines -> Map Int Lines
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Int Lines
newMap Map Int Lines
done, Int
newCur, Lines
newLines)

-- | Accumulate the output of stdout and stderr, grouping the output lines of both by prompt
accumHandles
  :: (Int -> ByteString -> Bool)
  -> These ByteString ByteString
  -> Accum
  -> Accum
accumHandles :: (Int -> ByteString -> Bool)
-> These ByteString ByteString -> Accum -> Accum
accumHandles Int -> ByteString -> Bool
isPrompt These ByteString ByteString
new Accum
acc =
  let acc' :: Accum
acc' = case These ByteString ByteString
new of
        This ByteString
a -> Accum
acc
          { _accum_stdout :: (Map Int Lines, Int, Lines)
_accum_stdout = (Int -> ByteString -> Bool)
-> ByteString
-> (Map Int Lines, Int, Lines)
-> (Map Int Lines, Int, Lines)
accumHandle Int -> ByteString -> Bool
isPrompt ByteString
a ((Map Int Lines, Int, Lines) -> (Map Int Lines, Int, Lines))
-> (Map Int Lines, Int, Lines) -> (Map Int Lines, Int, Lines)
forall a b. (a -> b) -> a -> b
$ Accum -> (Map Int Lines, Int, Lines)
_accum_stdout Accum
acc
          }
        That ByteString
a -> Accum
acc
          { _accum_stderr :: (Map Int Lines, Int, Lines)
_accum_stderr = (Int -> ByteString -> Bool)
-> ByteString
-> (Map Int Lines, Int, Lines)
-> (Map Int Lines, Int, Lines)
accumHandle Int -> ByteString -> Bool
isPrompt ByteString
a ((Map Int Lines, Int, Lines) -> (Map Int Lines, Int, Lines))
-> (Map Int Lines, Int, Lines) -> (Map Int Lines, Int, Lines)
forall a b. (a -> b) -> a -> b
$ Accum -> (Map Int Lines, Int, Lines)
_accum_stderr Accum
acc
          }
        These ByteString
a ByteString
b -> Accum
acc
          { _accum_stdout :: (Map Int Lines, Int, Lines)
_accum_stdout = (Int -> ByteString -> Bool)
-> ByteString
-> (Map Int Lines, Int, Lines)
-> (Map Int Lines, Int, Lines)
accumHandle Int -> ByteString -> Bool
isPrompt ByteString
a ((Map Int Lines, Int, Lines) -> (Map Int Lines, Int, Lines))
-> (Map Int Lines, Int, Lines) -> (Map Int Lines, Int, Lines)
forall a b. (a -> b) -> a -> b
$ Accum -> (Map Int Lines, Int, Lines)
_accum_stdout Accum
acc
          , _accum_stderr :: (Map Int Lines, Int, Lines)
_accum_stderr = (Int -> ByteString -> Bool)
-> ByteString
-> (Map Int Lines, Int, Lines)
-> (Map Int Lines, Int, Lines)
accumHandle Int -> ByteString -> Bool
isPrompt ByteString
b ((Map Int Lines, Int, Lines) -> (Map Int Lines, Int, Lines))
-> (Map Int Lines, Int, Lines) -> (Map Int Lines, Int, Lines)
forall a b. (a -> b) -> a -> b
$ Accum -> (Map Int Lines, Int, Lines)
_accum_stderr Accum
acc
          }
      -- This intersection represents the commands/output that we've already had the opportunity to report. Those commands can now be removed.
      oldIntersection :: Map Int Lines
oldIntersection = Map Int Lines -> Map Int Lines -> Map Int Lines
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.intersection ((Map Int Lines, Int, Lines) -> Map Int Lines
forall a b c. (a, b, c) -> a
fst3 ((Map Int Lines, Int, Lines) -> Map Int Lines)
-> (Map Int Lines, Int, Lines) -> Map Int Lines
forall a b. (a -> b) -> a -> b
$ Accum -> (Map Int Lines, Int, Lines)
_accum_stdout Accum
acc) ((Map Int Lines, Int, Lines) -> Map Int Lines
forall a b c. (a, b, c) -> a
fst3 ((Map Int Lines, Int, Lines) -> Map Int Lines)
-> (Map Int Lines, Int, Lines) -> Map Int Lines
forall a b. (a -> b) -> a -> b
$ Accum -> (Map Int Lines, Int, Lines)
_accum_stderr Accum
acc)
  in Accum :: (Map Int Lines, Int, Lines) -> (Map Int Lines, Int, Lines) -> Accum
Accum
      { _accum_stdout :: (Map Int Lines, Int, Lines)
_accum_stdout =
          ( ((Map Int Lines, Int, Lines) -> Map Int Lines
forall a b c. (a, b, c) -> a
fst3 ((Map Int Lines, Int, Lines) -> Map Int Lines)
-> (Map Int Lines, Int, Lines) -> Map Int Lines
forall a b. (a -> b) -> a -> b
$ Accum -> (Map Int Lines, Int, Lines)
_accum_stdout Accum
acc') Map Int Lines -> Map Int Lines -> Map Int Lines
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` Map Int Lines
oldIntersection -- Only include output of commands we haven't previously declared "done"
          , (Map Int Lines, Int, Lines) -> Int
forall a b c. (a, b, c) -> b
snd3 ((Map Int Lines, Int, Lines) -> Int)
-> (Map Int Lines, Int, Lines) -> Int
forall a b. (a -> b) -> a -> b
$ Accum -> (Map Int Lines, Int, Lines)
_accum_stdout Accum
acc'
          , (Map Int Lines, Int, Lines) -> Lines
forall a b c. (a, b, c) -> c
thd3 ((Map Int Lines, Int, Lines) -> Lines)
-> (Map Int Lines, Int, Lines) -> Lines
forall a b. (a -> b) -> a -> b
$ Accum -> (Map Int Lines, Int, Lines)
_accum_stdout Accum
acc'
          )
      , _accum_stderr :: (Map Int Lines, Int, Lines)
_accum_stderr =
          ( ((Map Int Lines, Int, Lines) -> Map Int Lines
forall a b c. (a, b, c) -> a
fst3 ((Map Int Lines, Int, Lines) -> Map Int Lines)
-> (Map Int Lines, Int, Lines) -> Map Int Lines
forall a b. (a -> b) -> a -> b
$ Accum -> (Map Int Lines, Int, Lines)
_accum_stderr Accum
acc') Map Int Lines -> Map Int Lines -> Map Int Lines
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` Map Int Lines
oldIntersection -- Only include output of commands we haven't previously declared "done"
          , (Map Int Lines, Int, Lines) -> Int
forall a b c. (a, b, c) -> b
snd3 ((Map Int Lines, Int, Lines) -> Int)
-> (Map Int Lines, Int, Lines) -> Int
forall a b. (a -> b) -> a -> b
$ Accum -> (Map Int Lines, Int, Lines)
_accum_stderr Accum
acc'
          , (Map Int Lines, Int, Lines) -> Lines
forall a b c. (a, b, c) -> c
thd3 ((Map Int Lines, Int, Lines) -> Lines)
-> (Map Int Lines, Int, Lines) -> Lines
forall a b. (a -> b) -> a -> b
$ Accum -> (Map Int Lines, Int, Lines)
_accum_stderr Accum
acc'
          )
      }

-- | Take all the pending output and consider it complete.
flushAccum :: Accum -> Accum
flushAccum :: Accum -> Accum
flushAccum (Accum (Map Int Lines
stdout, Int
curout, Lines
stdoutLeftovers) (Map Int Lines
stderr, Int
curerr, Lines
stderrLeftovers)) =
  (Map Int Lines, Int, Lines) -> (Map Int Lines, Int, Lines) -> Accum
Accum (Int -> Lines -> Map Int Lines -> Map Int Lines
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
curout Lines
stdoutLeftovers Map Int Lines
stdout, Int
curoutInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, Lines
forall a. Monoid a => a
mempty) (Int -> Lines -> Map Int Lines -> Map Int Lines
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
curerr Lines
stderrLeftovers Map Int Lines
stderr, Int
curerrInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, Lines
forall a. Monoid a => a
mempty)

-- | Run a repl, feed it commands, and produce output grouped by those
-- commands. The repl in question must be able to print its prompt on both
-- stdout and stderr.
repl
  :: forall t m.
     ( Adjustable t m
     , MonadFix m
     , MonadHold t m
     , MonadIO (Performable m)
     , MonadIO m
     , NotReady t m
     , PerformEvent t m
     , PostBuild t m
     , TriggerEvent t m
     )
  => P.CreateProcess
  -- ^ Command to run to enter repl
  -> Event t [Command]
  -- ^ Commands to send to the repl
  -> (Int -> ByteString -> Bool)
  -- ^ Test for determining whether a line is the prompt we're waiting or
  -> m (Repl t)
repl :: CreateProcess
-> Event t [Command] -> (Int -> ByteString -> Bool) -> m (Repl t)
repl CreateProcess
runRepl Event t [Command]
cmds Int -> ByteString -> Bool
isPrompt = do
  let ix0 :: Int
ix0 = Int
1
  IORef Int
n <- IO (IORef Int) -> m (IORef Int)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Int) -> m (IORef Int))
-> IO (IORef Int) -> m (IORef Int)
forall a b. (a -> b) -> a -> b
$ Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
ix0
  Event t (Map Int Command)
newIxedInput <- Event t (Performable m (Map Int Command))
-> m (Event t (Map Int Command))
forall t (m :: * -> *) a.
PerformEvent t m =>
Event t (Performable m a) -> m (Event t a)
performEvent (Event t (Performable m (Map Int Command))
 -> m (Event t (Map Int Command)))
-> Event t (Performable m (Map Int Command))
-> m (Event t (Map Int Command))
forall a b. (a -> b) -> a -> b
$ Event t [Command]
-> ([Command] -> Performable m (Map Int Command))
-> Event t (Performable m (Map Int Command))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor Event t [Command]
cmds (([Command] -> Performable m (Map Int Command))
 -> Event t (Performable m (Map Int Command)))
-> ([Command] -> Performable m (Map Int Command))
-> Event t (Performable m (Map Int Command))
forall a b. (a -> b) -> a -> b
$ \[Command]
inputs -> do
    ([(Int, Command)] -> Map Int Command)
-> Performable m [(Int, Command)]
-> Performable m (Map Int Command)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Int, Command)] -> Map Int Command
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (Performable m [(Int, Command)] -> Performable m (Map Int Command))
-> Performable m [(Int, Command)]
-> Performable m (Map Int Command)
forall a b. (a -> b) -> a -> b
$ [Command]
-> (Command -> Performable m (Int, Command))
-> Performable m [(Int, Command)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Command]
inputs ((Command -> Performable m (Int, Command))
 -> Performable m [(Int, Command)])
-> (Command -> Performable m (Int, Command))
-> Performable m [(Int, Command)]
forall a b. (a -> b) -> a -> b
$ \Command
input' -> do
      Int
new_n <- IO Int -> Performable m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> Performable m Int) -> IO Int -> Performable m Int
forall a b. (a -> b) -> a -> b
$ IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
n ((Int -> (Int, Int)) -> IO Int) -> (Int -> (Int, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Int
n' -> (Int -> Int
forall a. Enum a => a -> a
succ Int
n', Int
n')
      (Int, Command) -> Performable m (Int, Command)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int, Command) -> Performable m (Int, Command))
-> (Int, Command) -> Performable m (Int, Command)
forall a b. (a -> b) -> a -> b
$ (Int
new_n, Command
input')
  Dynamic t (Map Int Command)
ixedInput <- (Map Int Command -> Map Int Command -> Map Int Command)
-> Map Int Command
-> Event t (Map Int Command)
-> m (Dynamic t (Map Int Command))
forall k (t :: k) (m :: * -> *) a b.
(Reflex t, MonadHold t m, MonadFix m) =>
(a -> b -> b) -> b -> Event t a -> m (Dynamic t b)
foldDyn Map Int Command -> Map Int Command -> Map Int Command
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Int Command
forall k a. Map k a
Map.empty Event t (Map Int Command)
newIxedInput
  Process t ByteString ByteString
proc <- CreateProcess
-> ProcessConfig t (SendPipe ByteString)
-> m (Process t ByteString ByteString)
forall (m :: * -> *) t.
(MonadIO m, TriggerEvent t m, PerformEvent t m,
 MonadIO (Performable m), MonadFix m) =>
CreateProcess
-> ProcessConfig t (SendPipe ByteString)
-> m (Process t ByteString ByteString)
createProcess CreateProcess
runRepl (ProcessConfig t (SendPipe ByteString)
 -> m (Process t ByteString ByteString))
-> ProcessConfig t (SendPipe ByteString)
-> m (Process t ByteString ByteString)
forall a b. (a -> b) -> a -> b
$ ProcessConfig :: forall t i. Event t i -> Event t Signal -> ProcessConfig t i
ProcessConfig
    { _processConfig_stdin :: Event t (SendPipe ByteString)
_processConfig_stdin = ([Command] -> Maybe (SendPipe ByteString))
-> Event t [Command] -> Event t (SendPipe ByteString)
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
fmapMaybe [Command] -> Maybe (SendPipe ByteString)
sendCommands Event t [Command]
cmds
    , _processConfig_signal :: Event t Signal
_processConfig_signal = Event t Signal
forall k (t :: k) a. Reflex t => Event t a
never
    }
  Event t ()
pb <- m (Event t ())
forall t (m :: * -> *). PostBuild t m => m (Event t ())
getPostBuild
  Event t ExitCode
exited <- Event t ((ExitCode -> IO ()) -> Performable m ())
-> m (Event t ExitCode)
forall t (m :: * -> *) a.
(TriggerEvent t m, PerformEvent t m) =>
Event t ((a -> IO ()) -> Performable m ()) -> m (Event t a)
performEventAsync (Event t ((ExitCode -> IO ()) -> Performable m ())
 -> m (Event t ExitCode))
-> Event t ((ExitCode -> IO ()) -> Performable m ())
-> m (Event t ExitCode)
forall a b. (a -> b) -> a -> b
$ Event t ()
-> (() -> (ExitCode -> IO ()) -> Performable m ())
-> Event t ((ExitCode -> IO ()) -> Performable m ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor Event t ()
pb ((() -> (ExitCode -> IO ()) -> Performable m ())
 -> Event t ((ExitCode -> IO ()) -> Performable m ()))
-> (() -> (ExitCode -> IO ()) -> Performable m ())
-> Event t ((ExitCode -> IO ()) -> Performable m ())
forall a b. (a -> b) -> a -> b
$ \()
_ ExitCode -> IO ()
cb ->
    IO () -> Performable m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Performable m ()) -> IO () -> Performable m ()
forall a b. (a -> b) -> a -> b
$ IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO ()
cb (ExitCode -> IO ())
-> (ProcessHandle -> IO ExitCode) -> ProcessHandle -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ProcessHandle -> IO ExitCode
P.waitForProcess (ProcessHandle -> IO ()) -> ProcessHandle -> IO ()
forall a b. (a -> b) -> a -> b
$ Process t ByteString ByteString -> ProcessHandle
forall t o e. Process t o e -> ProcessHandle
_process_handle Process t ByteString ByteString
proc
  Dynamic t Accum
results <- ((Accum -> Accum) -> Accum -> Accum)
-> Accum -> Event t (Accum -> Accum) -> m (Dynamic t Accum)
forall k (t :: k) (m :: * -> *) a b.
(Reflex t, MonadHold t m, MonadFix m) =>
(a -> b -> b) -> b -> Event t a -> m (Dynamic t b)
foldDyn (Accum -> Accum) -> Accum -> Accum
forall a b. (a -> b) -> a -> b
($) ((Map Int Lines, Int, Lines) -> (Map Int Lines, Int, Lines) -> Accum
Accum (Map Int Lines
forall k a. Map k a
Map.empty, Int
ix0, Lines
forall a. Monoid a => a
mempty) (Map Int Lines
forall k a. Map k a
Map.empty, Int
ix0, Lines
forall a. Monoid a => a
mempty)) (Event t (Accum -> Accum) -> m (Dynamic t Accum))
-> Event t (Accum -> Accum) -> m (Dynamic t Accum)
forall a b. (a -> b) -> a -> b
$ [Event t (Accum -> Accum)] -> Event t (Accum -> Accum)
forall k (t :: k) a. Reflex t => [Event t a] -> Event t a
leftmost
    [ (Int -> ByteString -> Bool)
-> These ByteString ByteString -> Accum -> Accum
accumHandles Int -> ByteString -> Bool
isPrompt (These ByteString ByteString -> Accum -> Accum)
-> Event t (These ByteString ByteString)
-> Event t (Accum -> Accum)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event t ByteString
-> Event t ByteString -> Event t (These ByteString ByteString)
forall (f :: * -> *) a b.
Semialign f =>
f a -> f b -> f (These a b)
align (Process t ByteString ByteString -> Event t ByteString
forall t o e. Process t o e -> Event t o
_process_stdout Process t ByteString ByteString
proc) (Process t ByteString ByteString -> Event t ByteString
forall t o e. Process t o e -> Event t e
_process_stderr Process t ByteString ByteString
proc)
    , Accum -> Accum
flushAccum (Accum -> Accum) -> Event t ExitCode -> Event t (Accum -> Accum)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ExitCode
exited
    ]
  let outerr :: Dynamic t (Map Int (Lines, Lines))
outerr = Dynamic t Accum
-> (Accum -> Map Int (Lines, Lines))
-> Dynamic t (Map Int (Lines, Lines))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor Dynamic t Accum
results ((Accum -> Map Int (Lines, Lines))
 -> Dynamic t (Map Int (Lines, Lines)))
-> (Accum -> Map Int (Lines, Lines))
-> Dynamic t (Map Int (Lines, Lines))
forall a b. (a -> b) -> a -> b
$ \(Accum (Map Int Lines, Int, Lines)
o (Map Int Lines, Int, Lines)
e) -> (Lines -> Lines -> (Lines, Lines))
-> Map Int Lines -> Map Int Lines -> Map Int (Lines, Lines)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith (,) ((Map Int Lines, Int, Lines) -> Map Int Lines
forall a b c. (a, b, c) -> a
fst3 (Map Int Lines, Int, Lines)
o) ((Map Int Lines, Int, Lines) -> Map Int Lines
forall a b c. (a, b, c) -> a
fst3 (Map Int Lines, Int, Lines)
e)
  Dynamic t (Map Int Cmd)
finished <- Dynamic t (Map Int Cmd) -> m (Dynamic t (Map Int Cmd))
forall k (t :: k) (m :: * -> *) a.
(Reflex t, MonadHold t m, MonadFix m, Eq a) =>
Dynamic t a -> m (Dynamic t a)
holdUniqDyn (Dynamic t (Map Int Cmd) -> m (Dynamic t (Map Int Cmd)))
-> Dynamic t (Map Int Cmd) -> m (Dynamic t (Map Int Cmd))
forall a b. (a -> b) -> a -> b
$ (Command -> (Lines, Lines) -> Cmd)
-> Map Int Command -> Map Int (Lines, Lines) -> Map Int Cmd
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith (\Command
inp (Lines
o, Lines
e) -> Command -> Lines -> Lines -> Cmd
Cmd Command
inp Lines
o Lines
e) (Map Int Command -> Map Int (Lines, Lines) -> Map Int Cmd)
-> Dynamic t (Map Int Command)
-> Dynamic t (Map Int (Lines, Lines) -> Map Int Cmd)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t (Map Int Command)
ixedInput Dynamic t (Map Int (Lines, Lines) -> Map Int Cmd)
-> Dynamic t (Map Int (Lines, Lines)) -> Dynamic t (Map Int Cmd)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Dynamic t (Map Int (Lines, Lines))
outerr
  let commandInProgress :: Map Int Command -> Accum -> (Int, Maybe Cmd)
commandInProgress Map Int Command
i (Accum (Map Int Lines, Int, Lines)
o (Map Int Lines, Int, Lines)
e) = ((Map Int Lines, Int, Lines) -> Int
forall a b c. (a, b, c) -> b
snd3 (Map Int Lines, Int, Lines)
o,) (Maybe Cmd -> (Int, Maybe Cmd)) -> Maybe Cmd -> (Int, Maybe Cmd)
forall a b. (a -> b) -> a -> b
$ case (Int -> Map Int Command -> Maybe Command
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ((Map Int Lines, Int, Lines) -> Int
forall a b c. (a, b, c) -> b
snd3 (Map Int Lines, Int, Lines)
o) Map Int Command
i) of
        Maybe Command
Nothing -> Maybe Cmd
forall a. Maybe a
Nothing
        Just Command
inp -> Cmd -> Maybe Cmd
forall a. a -> Maybe a
Just (Cmd -> Maybe Cmd) -> Cmd -> Maybe Cmd
forall a b. (a -> b) -> a -> b
$ Command -> Lines -> Lines -> Cmd
Cmd Command
inp ((Map Int Lines, Int, Lines) -> Lines
forall a b c. (a, b, c) -> c
thd3 (Map Int Lines, Int, Lines)
o) ((Map Int Lines, Int, Lines) -> Lines
forall a b c. (a, b, c) -> c
thd3 (Map Int Lines, Int, Lines)
e)
      started :: Dynamic t (Int, Maybe Cmd)
started = Map Int Command -> Accum -> (Int, Maybe Cmd)
commandInProgress (Map Int Command -> Accum -> (Int, Maybe Cmd))
-> Dynamic t (Map Int Command)
-> Dynamic t (Accum -> (Int, Maybe Cmd))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t (Map Int Command)
ixedInput Dynamic t (Accum -> (Int, Maybe Cmd))
-> Dynamic t Accum -> Dynamic t (Int, Maybe Cmd)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Dynamic t Accum
results
  Repl t -> m (Repl t)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Repl t -> m (Repl t)) -> Repl t -> m (Repl t)
forall a b. (a -> b) -> a -> b
$ Repl :: forall t.
Process t ByteString ByteString
-> Event t (Map Int Cmd)
-> Dynamic t (Int, Maybe Cmd)
-> Event t ExitCode
-> Repl t
Repl
    { _repl_process :: Process t ByteString ByteString
_repl_process = Process t ByteString ByteString
proc
    , _repl_finished :: Event t (Map Int Cmd)
_repl_finished = Dynamic t (Map Int Cmd) -> Event t (Map Int Cmd)
forall k (t :: k) a. Reflex t => Dynamic t a -> Event t a
updated Dynamic t (Map Int Cmd)
finished
    , _repl_started :: Dynamic t (Int, Maybe Cmd)
_repl_started = Dynamic t (Int, Maybe Cmd)
started
    , _repl_exited :: Event t ExitCode
_repl_exited = Event t ExitCode
exited
    }

-- * Output lines

-- | Accumulator for line-based output that keeps track of any dangling,
-- unterminated line
data Lines = Lines
  { Lines -> Seq ByteString
_lines_terminated :: Seq C8.ByteString
  , Lines -> Maybe ByteString
_lines_unterminated :: Maybe C8.ByteString
  }
  deriving (Int -> Lines -> ShowS
[Lines] -> ShowS
Lines -> String
(Int -> Lines -> ShowS)
-> (Lines -> String) -> ([Lines] -> ShowS) -> Show Lines
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Lines] -> ShowS
$cshowList :: [Lines] -> ShowS
show :: Lines -> String
$cshow :: Lines -> String
showsPrec :: Int -> Lines -> ShowS
$cshowsPrec :: Int -> Lines -> ShowS
Show, Lines -> Lines -> Bool
(Lines -> Lines -> Bool) -> (Lines -> Lines -> Bool) -> Eq Lines
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Lines -> Lines -> Bool
$c/= :: Lines -> Lines -> Bool
== :: Lines -> Lines -> Bool
$c== :: Lines -> Lines -> Bool
Eq, Eq Lines
Eq Lines
-> (Lines -> Lines -> Ordering)
-> (Lines -> Lines -> Bool)
-> (Lines -> Lines -> Bool)
-> (Lines -> Lines -> Bool)
-> (Lines -> Lines -> Bool)
-> (Lines -> Lines -> Lines)
-> (Lines -> Lines -> Lines)
-> Ord Lines
Lines -> Lines -> Bool
Lines -> Lines -> Ordering
Lines -> Lines -> Lines
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Lines -> Lines -> Lines
$cmin :: Lines -> Lines -> Lines
max :: Lines -> Lines -> Lines
$cmax :: Lines -> Lines -> Lines
>= :: Lines -> Lines -> Bool
$c>= :: Lines -> Lines -> Bool
> :: Lines -> Lines -> Bool
$c> :: Lines -> Lines -> Bool
<= :: Lines -> Lines -> Bool
$c<= :: Lines -> Lines -> Bool
< :: Lines -> Lines -> Bool
$c< :: Lines -> Lines -> Bool
compare :: Lines -> Lines -> Ordering
$ccompare :: Lines -> Lines -> Ordering
$cp1Ord :: Eq Lines
Ord, ReadPrec [Lines]
ReadPrec Lines
Int -> ReadS Lines
ReadS [Lines]
(Int -> ReadS Lines)
-> ReadS [Lines]
-> ReadPrec Lines
-> ReadPrec [Lines]
-> Read Lines
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Lines]
$creadListPrec :: ReadPrec [Lines]
readPrec :: ReadPrec Lines
$creadPrec :: ReadPrec Lines
readList :: ReadS [Lines]
$creadList :: ReadS [Lines]
readsPrec :: Int -> ReadS Lines
$creadsPrec :: Int -> ReadS Lines
Read)

-- | Empty output
emptyLines :: Lines
emptyLines :: Lines
emptyLines = Seq ByteString -> Maybe ByteString -> Lines
Lines Seq ByteString
forall a. Seq a
Seq.empty Maybe ByteString
forall a. Maybe a
Nothing

-- | Add some raw output to a 'Lines'. This will chop the raw output up into lines.
addLines :: ByteString -> Lines -> Lines
addLines :: ByteString -> Lines -> Lines
addLines ByteString
new (Lines Seq ByteString
t Maybe ByteString
u) =
  let newLines :: Seq ByteString
newLines = [ByteString] -> Seq ByteString
forall a. [a] -> Seq a
Seq.fromList ([ByteString] -> Seq ByteString) -> [ByteString] -> Seq ByteString
forall a b. (a -> b) -> a -> b
$ (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ByteString -> Bool) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
C8.null) (ByteString -> [ByteString]
C8.lines ByteString
new)
  in
    case Maybe ByteString
u of
      Maybe ByteString
Nothing -> if ByteString
"\n" ByteString -> ByteString -> Bool
`C8.isSuffixOf` ByteString
new
        then Seq ByteString -> Maybe ByteString -> Lines
Lines (Seq ByteString
t Seq ByteString -> Seq ByteString -> Seq ByteString
forall a. Semigroup a => a -> a -> a
<> Seq ByteString
newLines) Maybe ByteString
forall a. Maybe a
Nothing
        else case Seq ByteString -> ViewR ByteString
forall a. Seq a -> ViewR a
Seq.viewr Seq ByteString
newLines of
                ViewR ByteString
Seq.EmptyR -> Seq ByteString -> Maybe ByteString -> Lines
Lines Seq ByteString
t Maybe ByteString
forall a. Maybe a
Nothing
                (Seq ByteString
t' Seq.:> ByteString
u') -> Seq ByteString -> Maybe ByteString -> Lines
Lines (Seq ByteString
t Seq ByteString -> Seq ByteString -> Seq ByteString
forall a. Semigroup a => a -> a -> a
<> Seq ByteString
t') (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
u')
      Just ByteString
u' -> ByteString -> Lines -> Lines
addLines (ByteString
u' ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
new) (Lines -> Lines) -> Lines -> Lines
forall a b. (a -> b) -> a -> b
$ Seq ByteString -> Maybe ByteString -> Lines
Lines Seq ByteString
t Maybe ByteString
forall a. Maybe a
Nothing

-- | Convert a 'ByteString' into a 'Lines'
linesFromBS :: C8.ByteString -> Lines
linesFromBS :: ByteString -> Lines
linesFromBS = (ByteString -> Lines -> Lines) -> Lines -> ByteString -> Lines
forall a b c. (a -> b -> c) -> b -> a -> c
flip ByteString -> Lines -> Lines
addLines Lines
forall a. Monoid a => a
mempty

instance Semigroup Lines where
  Lines
a <> :: Lines -> Lines -> Lines
<> Lines
b = ByteString -> Lines -> Lines
addLines (Lines -> ByteString
unLines Lines
b) Lines
a

instance Monoid Lines where
  mempty :: Lines
mempty = Lines
emptyLines

-- | Convert a 'Lines' back into a 'ByteString'
unLines :: Lines -> ByteString
unLines :: Lines -> ByteString
unLines (Lines Seq ByteString
t Maybe ByteString
u) =
  [ByteString] -> ByteString
C8.unlines (Seq ByteString -> [ByteString]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq ByteString
t) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" Maybe ByteString
u

-- | Convenience accessor for the last whole line received by a 'Lines'.
-- Ignores any unterminated line that may follow.
lastWholeLine :: Lines -> Maybe C8.ByteString
lastWholeLine :: Lines -> Maybe ByteString
lastWholeLine (Lines Seq ByteString
t Maybe ByteString
_) = case Seq ByteString -> ViewR ByteString
forall a. Seq a -> ViewR a
Seq.viewr Seq ByteString
t of
  ViewR ByteString
Seq.EmptyR -> Maybe ByteString
forall a. Maybe a
Nothing
  Seq ByteString
_ Seq.:> ByteString
x -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
x

-- | Split lines into two. The sequence that satisfies the predicate is
-- consumed and will not appear in either resulting 'Lines'.
splitLinesOn :: (ByteString -> Bool) -> Lines -> Maybe (Lines, Lines)
splitLinesOn :: (ByteString -> Bool) -> Lines -> Maybe (Lines, Lines)
splitLinesOn ByteString -> Bool
test (Lines Seq ByteString
t Maybe ByteString
u) = 
  let (Seq ByteString
before, Seq ByteString
after) = (ByteString -> Bool)
-> Seq ByteString -> (Seq ByteString, Seq ByteString)
forall a. (a -> Bool) -> Seq a -> (Seq a, Seq a)
Seq.breakl ByteString -> Bool
test Seq ByteString
t
  in if Seq ByteString -> Bool
forall a. Seq a -> Bool
Seq.null Seq ByteString
after then Maybe (Lines, Lines)
forall a. Maybe a
Nothing else (Lines, Lines) -> Maybe (Lines, Lines)
forall a. a -> Maybe a
Just (Seq ByteString -> Maybe ByteString -> Lines
Lines Seq ByteString
before Maybe ByteString
forall a. Maybe a
Nothing, Seq ByteString -> Maybe ByteString -> Lines
Lines (Int -> Seq ByteString -> Seq ByteString
forall a. Int -> Seq a -> Seq a
Seq.drop Int
1 Seq ByteString
after) Maybe ByteString
u)

-- * Commands to send to the repl

-- | A string that will be sent to the repl for evaluation. A newline will be
-- appended to the end of the string. 'Command's should not themselves contain newlines.
newtype Command = Command { Command -> ByteString
unCommand :: ByteString }
  deriving (Int -> Command -> ShowS
[Command] -> ShowS
Command -> String
(Int -> Command -> ShowS)
-> (Command -> String) -> ([Command] -> ShowS) -> Show Command
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Command] -> ShowS
$cshowList :: [Command] -> ShowS
show :: Command -> String
$cshow :: Command -> String
showsPrec :: Int -> Command -> ShowS
$cshowsPrec :: Int -> Command -> ShowS
Show, ReadPrec [Command]
ReadPrec Command
Int -> ReadS Command
ReadS [Command]
(Int -> ReadS Command)
-> ReadS [Command]
-> ReadPrec Command
-> ReadPrec [Command]
-> Read Command
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Command]
$creadListPrec :: ReadPrec [Command]
readPrec :: ReadPrec Command
$creadPrec :: ReadPrec Command
readList :: ReadS [Command]
$creadList :: ReadS [Command]
readsPrec :: Int -> ReadS Command
$creadsPrec :: Int -> ReadS Command
Read, Command -> Command -> Bool
(Command -> Command -> Bool)
-> (Command -> Command -> Bool) -> Eq Command
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Command -> Command -> Bool
$c/= :: Command -> Command -> Bool
== :: Command -> Command -> Bool
$c== :: Command -> Command -> Bool
Eq, Eq Command
Eq Command
-> (Command -> Command -> Ordering)
-> (Command -> Command -> Bool)
-> (Command -> Command -> Bool)
-> (Command -> Command -> Bool)
-> (Command -> Command -> Bool)
-> (Command -> Command -> Command)
-> (Command -> Command -> Command)
-> Ord Command
Command -> Command -> Bool
Command -> Command -> Ordering
Command -> Command -> Command
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Command -> Command -> Command
$cmin :: Command -> Command -> Command
max :: Command -> Command -> Command
$cmax :: Command -> Command -> Command
>= :: Command -> Command -> Bool
$c>= :: Command -> Command -> Bool
> :: Command -> Command -> Bool
$c> :: Command -> Command -> Bool
<= :: Command -> Command -> Bool
$c<= :: Command -> Command -> Bool
< :: Command -> Command -> Bool
$c< :: Command -> Command -> Bool
compare :: Command -> Command -> Ordering
$ccompare :: Command -> Command -> Ordering
$cp1Ord :: Eq Command
Ord)

-- | Constructs a 'Command' without checking for newlines. If there are
-- newlines in the input, things will not work properly.
unsafeCommand :: ByteString -> Command
unsafeCommand :: ByteString -> Command
unsafeCommand = ByteString -> Command
Command

-- | Convert a 'ByteString' into a set of 'Command's. Any newlines found in the
-- input are considered 'Command' separators.
command :: ByteString -> [Command]
command :: ByteString -> [Command]
command = (ByteString -> Command) -> [ByteString] -> [Command]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Command
Command ([ByteString] -> [Command])
-> (ByteString -> [ByteString]) -> ByteString -> [Command]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ByteString -> Bool) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
C8.null) ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> [ByteString]
C8.splitWith (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\n')

-- | Convert a 'ByteString' into a set of 'Command's. Any newlines found in the
-- input are considered 'Command' separators.
commands :: [ByteString] -> [Command]
commands :: [ByteString] -> [Command]
commands = (ByteString -> Command) -> [ByteString] -> [Command]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Command
Command ([ByteString] -> [Command])
-> ([ByteString] -> [ByteString]) -> [ByteString] -> [Command]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ByteString -> Bool) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
C8.null) ([ByteString] -> [ByteString])
-> ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> [ByteString]) -> [ByteString] -> [ByteString]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Char -> Bool) -> ByteString -> [ByteString]
C8.splitWith (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\n'))

-- | Turn a command back into a 'ByteString'.
displayCommand :: Command -> ByteString
displayCommand :: Command -> ByteString
displayCommand = Command -> ByteString
unCommand

-- | Convert commands to a format that can be sent over stdin
sendCommands :: [Command] -> Maybe (SendPipe ByteString)
sendCommands :: [Command] -> Maybe (SendPipe ByteString)
sendCommands [Command]
cmds = case [Command]
cmds of
  [] -> Maybe (SendPipe ByteString)
forall a. Maybe a
Nothing
  [Command]
xs -> SendPipe ByteString -> Maybe (SendPipe ByteString)
forall a. a -> Maybe a
Just (SendPipe ByteString -> Maybe (SendPipe ByteString))
-> SendPipe ByteString -> Maybe (SendPipe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> SendPipe ByteString
forall i. i -> SendPipe i
SendPipe_Message (ByteString -> [ByteString] -> ByteString
C8.intercalate ByteString
"\n" (Command -> ByteString
unCommand (Command -> ByteString) -> [Command] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Command]
xs) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n")

-- * Misc

fst3 :: (a, b, c) -> a
fst3 :: (a, b, c) -> a
fst3 (a
a, b
_, c
_) = a
a

snd3 :: (a, b, c) -> b
snd3 :: (a, b, c) -> b
snd3 (a
_, b
b, c
_) = b
b

thd3 :: (a, b, c) -> c
thd3 :: (a, b, c) -> c
thd3 (a
_, b
_, c
c) = c
c

-- * Testing

-- | A headless repl test that runs ghci, executes some commands, and checks that the output is as expected.
testRepl :: IO ()
testRepl :: IO ()
testRepl = (forall t (m :: * -> *). MonadHeadlessApp t m => m (Event t ()))
-> IO ()
runHeadlessApp ((forall t (m :: * -> *). MonadHeadlessApp t m => m (Event t ()))
 -> IO ())
-> (forall t (m :: * -> *). MonadHeadlessApp t m => m (Event t ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Handler
_ <- IO Handler -> m Handler
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handler -> m Handler) -> IO Handler -> m Handler
forall a b. (a -> b) -> a -> b
$ Signal -> Handler -> Maybe SignalSet -> IO Handler
Signals.installHandler Signal
Signals.sigINT (IO () -> Handler
Signals.Catch (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())) Maybe SignalSet
forall a. Maybe a
Nothing
  Event t ()
pb <- m (Event t ())
forall t (m :: * -> *). PostBuild t m => m (Event t ())
getPostBuild
  Event t [Command]
testCommands <- m (Event t [Command])
forall t (m :: * -> *).
(PerformEvent t m, PostBuild t m, TriggerEvent t m,
 MonadIO (Performable m)) =>
m (Event t [Command])
mkTestCommands
  let cmds :: Event t [Command]
cmds = ([Command] -> [Command] -> [Command])
-> [Event t [Command]] -> Event t [Command]
forall k (t :: k) a.
Reflex t =>
(a -> a -> a) -> [Event t a] -> Event t a
mergeWith (\[Command]
a [Command]
b -> [Command]
a [Command] -> [Command] -> [Command]
forall a. Semigroup a => a -> a -> a
<> [Command]
b)
        [ ByteString -> [Command]
command (ByteString -> [ByteString] -> ByteString
C8.intercalate ByteString
"\n"
            [ ByteString
":set prompt-function \\_ x -> let s = \"\\n\" <> show x <> \"" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
promptPostfix ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\\n\" in System.IO.hPutStr System.IO.stderr s >> pure s"
            , ByteString
":set -fno-break-on-exception"
            , ByteString
":set -fno-break-on-error"
            , ByteString
":set -v1"
            , ByteString
":set -fno-hide-source-paths"
            , ByteString
":set -ferror-spans"
            , ByteString
":set -fdiagnostics-color=never"
            , ByteString
":r"
            ]) [Command] -> Event t () -> Event t [Command]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
pb
        , Event t [Command]
testCommands
        ]
  rec (Repl Process t ByteString ByteString
_ Event t (Map Int Cmd)
finished Dynamic t (Int, Maybe Cmd)
_ Event t ExitCode
exit) <- CreateProcess
-> Event t [Command] -> (Int -> ByteString -> Bool) -> m (Repl t)
forall t (m :: * -> *).
(Adjustable t m, MonadFix m, MonadHold t m,
 MonadIO (Performable m), MonadIO m, NotReady t m, PerformEvent t m,
 PostBuild t m, TriggerEvent t m) =>
CreateProcess
-> Event t [Command] -> (Int -> ByteString -> Bool) -> m (Repl t)
repl (String -> CreateProcess
P.shell String
"ghci") Event t [Command]
cmds ((Int -> ByteString -> Bool) -> m (Repl t))
-> (Int -> ByteString -> Bool) -> m (Repl t)
forall a b. (a -> b) -> a -> b
$ \Int
cur ByteString
line -> (String -> ByteString
C8.pack (Int -> String
forall a. Show a => a -> String
show Int
cur) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
promptPostfix) ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
line
  Dynamic t (Map Int Cmd)
output <- (Map Int Cmd -> Map Int Cmd -> Map Int Cmd)
-> Map Int Cmd
-> Event t (Map Int Cmd)
-> m (Dynamic t (Map Int Cmd))
forall k (t :: k) (m :: * -> *) a b.
(Reflex t, MonadHold t m, MonadFix m) =>
(a -> b -> b) -> b -> Event t a -> m (Dynamic t b)
foldDyn Map Int Cmd -> Map Int Cmd -> Map Int Cmd
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Int Cmd
forall k a. Map k a
Map.empty Event t (Map Int Cmd)
finished
  Event t Bool
passed <- Event t (Performable m Bool) -> m (Event t Bool)
forall t (m :: * -> *) a.
PerformEvent t m =>
Event t (Performable m a) -> m (Event t a)
performEvent (Event t (Performable m Bool) -> m (Event t Bool))
-> Event t (Performable m Bool) -> m (Event t Bool)
forall a b. (a -> b) -> a -> b
$ Event t (Map Int Cmd)
-> (Map Int Cmd -> Performable m Bool)
-> Event t (Performable m Bool)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor (Dynamic t (Map Int Cmd)
-> Event t ExitCode -> Event t (Map Int Cmd)
forall k (t :: k) a b.
Reflex t =>
Dynamic t a -> Event t b -> Event t a
tagPromptlyDyn Dynamic t (Map Int Cmd)
output Event t ExitCode
exit) ((Map Int Cmd -> Performable m Bool)
 -> Event t (Performable m Bool))
-> (Map Int Cmd -> Performable m Bool)
-> Event t (Performable m Bool)
forall a b. (a -> b) -> a -> b
$ \Map Int Cmd
o -> do
    IO () -> Performable m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Performable m ()) -> IO () -> Performable m ()
forall a b. (a -> b) -> a -> b
$ Map Int Cmd -> IO ()
forall a. Show a => a -> IO ()
print Map Int Cmd
o
    IO () -> Performable m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Performable m ()) -> IO () -> Performable m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"testRepl:"
    Bool
r1 <- String -> Maybe Cmd -> ByteString -> Performable m Bool
forall (m :: * -> *).
MonadIO m =>
String -> Maybe Cmd -> ByteString -> m Bool
assertStdoutEq String
"Simple command (1+1)" (Int -> Map Int Cmd -> Maybe Cmd
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
9 Map Int Cmd
o) ByteString
"2"
    Bool
r2 <- String -> Maybe Cmd -> ByteString -> Performable m Bool
forall (m :: * -> *).
MonadIO m =>
String -> Maybe Cmd -> ByteString -> m Bool
assertStdoutEq String
"IO action (putStrLn)" (Int -> Map Int Cmd -> Maybe Cmd
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
10 Map Int Cmd
o) ByteString
"hello"
    Bool
r3 <- String -> Maybe Cmd -> (Lines -> Bool) -> Performable m Bool
forall (m :: * -> *).
MonadIO m =>
String -> Maybe Cmd -> (Lines -> Bool) -> m Bool
assertStderr String
"Not in scope error" (Int -> Map Int Cmd -> Maybe Cmd
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
11 Map Int Cmd
o) (ByteString -> ByteString -> Bool
C8.isInfixOf ByteString
"Variable not in scope: oops" (ByteString -> Bool) -> (Lines -> ByteString) -> Lines -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lines -> ByteString
unLines)
    Bool
r4 <- String -> Maybe Cmd -> ByteString -> Performable m Bool
forall (m :: * -> *).
MonadIO m =>
String -> Maybe Cmd -> ByteString -> m Bool
assertStdoutEq String
"Simple command (2+2)" (Int -> Map Int Cmd -> Maybe Cmd
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
12 Map Int Cmd
o) ByteString
"4"
    Bool
r5 <- String -> Maybe Cmd -> ByteString -> Performable m Bool
forall (m :: * -> *).
MonadIO m =>
String -> Maybe Cmd -> ByteString -> m Bool
assertStdoutEq String
"Simple command (3+4)" (Int -> Map Int Cmd -> Maybe Cmd
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
13 Map Int Cmd
o) ByteString
"7"
    Bool
r6 <- String -> Maybe Cmd -> (Lines -> Bool) -> Performable m Bool
forall (m :: * -> *).
MonadIO m =>
String -> Maybe Cmd -> (Lines -> Bool) -> m Bool
assertStderr String
"Exception" (Int -> Map Int Cmd -> Maybe Cmd
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
14 Map Int Cmd
o) (ByteString -> ByteString -> Bool
C8.isInfixOf ByteString
"*** Exception" (ByteString -> Bool) -> (Lines -> ByteString) -> Lines -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lines -> ByteString
unLines)
    Bool
r7 <- String -> Maybe Cmd -> ByteString -> Performable m Bool
forall (m :: * -> *).
MonadIO m =>
String -> Maybe Cmd -> ByteString -> m Bool
assertStdoutEq String
"Reload (:r)" (Int -> Map Int Cmd -> Maybe Cmd
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
15 Map Int Cmd
o) ByteString
"Ok, no modules loaded."
    Bool
r8 <- String -> Maybe Cmd -> ByteString -> Performable m Bool
forall (m :: * -> *).
MonadIO m =>
String -> Maybe Cmd -> ByteString -> m Bool
assertStdoutEq String
"Quit (:q)" (Int -> Map Int Cmd -> Maybe Cmd
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
16 Map Int Cmd
o) ByteString
"Leaving GHCi."
    Bool -> Performable m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Performable m Bool) -> Bool -> Performable m Bool
forall a b. (a -> b) -> a -> b
$ [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool
r1, Bool
r2, Bool
r3, Bool
r4, Bool
r5, Bool
r6, Bool
r7, Bool
r8]
  Event t (Performable m ()) -> m (Event t ())
forall t (m :: * -> *) a.
PerformEvent t m =>
Event t (Performable m a) -> m (Event t a)
performEvent (Event t (Performable m ()) -> m (Event t ()))
-> Event t (Performable m ()) -> m (Event t ())
forall a b. (a -> b) -> a -> b
$ Event t Bool
-> (Bool -> Performable m ()) -> Event t (Performable m ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor Event t Bool
passed ((Bool -> Performable m ()) -> Event t (Performable m ()))
-> (Bool -> Performable m ()) -> Event t (Performable m ())
forall a b. (a -> b) -> a -> b
$ \case
    Bool
False -> String -> Performable m ()
forall a. HasCallStack => String -> a
error String
"Test failed"
    Bool
True -> () -> Performable m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    promptPostfix :: ByteString
    promptPostfix :: ByteString
promptPostfix = ByteString
"_reflex_ghci_prompt>"

-- | Constructs some testing commands that are fed in on a timer
mkTestCommands :: (PerformEvent t m, PostBuild t m, TriggerEvent t m, MonadIO (Performable m)) => m (Event t [Command])
mkTestCommands :: m (Event t [Command])
mkTestCommands = do
  Event t ()
pb <- m (Event t ())
forall t (m :: * -> *). PostBuild t m => m (Event t ())
getPostBuild
  Event t ()
pb2 <- NominalDiffTime -> Event t () -> m (Event t ())
forall t (m :: * -> *) a.
(PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) =>
NominalDiffTime -> Event t a -> m (Event t a)
delay NominalDiffTime
1 Event t ()
pb
  Event t ()
pb3 <- NominalDiffTime -> Event t () -> m (Event t ())
forall t (m :: * -> *) a.
(PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) =>
NominalDiffTime -> Event t a -> m (Event t a)
delay NominalDiffTime
1.5 Event t ()
pb
  Event t ()
pb4 <- NominalDiffTime -> Event t () -> m (Event t ())
forall t (m :: * -> *) a.
(PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) =>
NominalDiffTime -> Event t a -> m (Event t a)
delay NominalDiffTime
2 Event t ()
pb
  Event t ()
pb5 <- NominalDiffTime -> Event t () -> m (Event t ())
forall t (m :: * -> *) a.
(PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) =>
NominalDiffTime -> Event t a -> m (Event t a)
delay NominalDiffTime
2.5 Event t ()
pb
  Event t ()
pb6 <- NominalDiffTime -> Event t () -> m (Event t ())
forall t (m :: * -> *) a.
(PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) =>
NominalDiffTime -> Event t a -> m (Event t a)
delay NominalDiffTime
3 Event t ()
pb
  Event t [Command] -> m (Event t [Command])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Event t [Command] -> m (Event t [Command]))
-> Event t [Command] -> m (Event t [Command])
forall a b. (a -> b) -> a -> b
$ (ByteString -> [Command])
-> Event t ByteString -> Event t [Command]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> [Command]
command (Event t ByteString -> Event t [Command])
-> Event t ByteString -> Event t [Command]
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString -> ByteString)
-> [Event t ByteString] -> Event t ByteString
forall k (t :: k) a.
Reflex t =>
(a -> a -> a) -> [Event t a] -> Event t a
mergeWith (\ByteString
a ByteString
b -> ByteString
a ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
b)
    [ ByteString
"1+1" ByteString -> Event t () -> Event t ByteString
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
pb2
    , ByteString
"putStrLn \"hello\"" ByteString -> Event t () -> Event t ByteString
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
pb3
    , ByteString
"oops" ByteString -> Event t () -> Event t ByteString
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
pb4
    , ByteString
"2+2" ByteString -> Event t () -> Event t ByteString
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
pb5
    , ByteString
"4+3" ByteString -> Event t () -> Event t ByteString
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
pb5
    , ByteString
"let Just x = Nothing in print x" ByteString -> Event t () -> Event t ByteString
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
pb5
    , ByteString
":r" ByteString -> Event t () -> Event t ByteString
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
pb6
    , ByteString
":q" ByteString -> Event t () -> Event t ByteString
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
pb6
    ]

-- | Check that stdout equals the given value
assertStdoutEq :: MonadIO m => String -> Maybe Cmd -> ByteString -> m Bool
assertStdoutEq :: String -> Maybe Cmd -> ByteString -> m Bool
assertStdoutEq String
str Maybe Cmd
cmd ByteString
expectation = (Cmd -> Lines) -> String -> Maybe Cmd -> ByteString -> m Bool
forall (m :: * -> *).
MonadIO m =>
(Cmd -> Lines) -> String -> Maybe Cmd -> ByteString -> m Bool
assertHandleEq Cmd -> Lines
_cmd_stdout String
str Maybe Cmd
cmd ByteString
expectation

-- | Check that stderr equals the given value
assertStderrEq :: MonadIO m => String -> Maybe Cmd -> ByteString -> m Bool
assertStderrEq :: String -> Maybe Cmd -> ByteString -> m Bool
assertStderrEq String
str Maybe Cmd
cmd ByteString
expectation = (Cmd -> Lines) -> String -> Maybe Cmd -> ByteString -> m Bool
forall (m :: * -> *).
MonadIO m =>
(Cmd -> Lines) -> String -> Maybe Cmd -> ByteString -> m Bool
assertHandleEq Cmd -> Lines
_cmd_stderr String
str Maybe Cmd
cmd ByteString
expectation

-- | Test the contents of stderr
assertStderr :: MonadIO m => String -> Maybe Cmd -> (Lines -> Bool) -> m Bool
assertStderr :: String -> Maybe Cmd -> (Lines -> Bool) -> m Bool
assertStderr = (Cmd -> Lines) -> String -> Maybe Cmd -> (Lines -> Bool) -> m Bool
forall (m :: * -> *).
MonadIO m =>
(Cmd -> Lines) -> String -> Maybe Cmd -> (Lines -> Bool) -> m Bool
assertHandle Cmd -> Lines
_cmd_stderr

-- | Test the contents of stdout
assertStdout :: MonadIO m => String -> Maybe Cmd -> (Lines -> Bool) -> m Bool
assertStdout :: String -> Maybe Cmd -> (Lines -> Bool) -> m Bool
assertStdout = (Cmd -> Lines) -> String -> Maybe Cmd -> (Lines -> Bool) -> m Bool
forall (m :: * -> *).
MonadIO m =>
(Cmd -> Lines) -> String -> Maybe Cmd -> (Lines -> Bool) -> m Bool
assertHandle Cmd -> Lines
_cmd_stdout

-- | Check that a handle equals the given value
assertHandleEq :: MonadIO m => (Cmd -> Lines) -> String -> Maybe Cmd -> ByteString -> m Bool
assertHandleEq :: (Cmd -> Lines) -> String -> Maybe Cmd -> ByteString -> m Bool
assertHandleEq Cmd -> Lines
h String
str Maybe Cmd
cmd ByteString
expectation = (Cmd -> Lines) -> String -> Maybe Cmd -> (Lines -> Bool) -> m Bool
forall (m :: * -> *).
MonadIO m =>
(Cmd -> Lines) -> String -> Maybe Cmd -> (Lines -> Bool) -> m Bool
assertHandle Cmd -> Lines
h String
str Maybe Cmd
cmd (Lines -> Lines -> Bool
forall a. Eq a => a -> a -> Bool
== Seq ByteString -> Maybe ByteString -> Lines
Lines (ByteString -> Seq ByteString
forall a. a -> Seq a
Seq.singleton ByteString
expectation) Maybe ByteString
forall a. Maybe a
Nothing)

-- | Test the contents of a handle
assertHandle :: MonadIO m => (Cmd -> Lines) -> String -> Maybe Cmd -> (Lines -> Bool) -> m Bool
assertHandle :: (Cmd -> Lines) -> String -> Maybe Cmd -> (Lines -> Bool) -> m Bool
assertHandle Cmd -> Lines
h String
str Maybe Cmd
cmd Lines -> Bool
expectation = String -> Maybe Cmd -> (Cmd -> Bool) -> m Bool
forall (m :: * -> *).
MonadIO m =>
String -> Maybe Cmd -> (Cmd -> Bool) -> m Bool
assertCmd String
str Maybe Cmd
cmd (Lines -> Bool
expectation (Lines -> Bool) -> (Cmd -> Lines) -> Cmd -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cmd -> Lines
h)

-- | Test that a repl command and its output satisfy the predicate
assertCmd :: MonadIO m => String -> Maybe Cmd -> (Cmd -> Bool) -> m Bool
assertCmd :: String -> Maybe Cmd -> (Cmd -> Bool) -> m Bool
assertCmd String
str Maybe Cmd
cmd Cmd -> Bool
expectation = IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Testing: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
str
  if ((Cmd -> Bool
expectation (Cmd -> Bool) -> Maybe Cmd -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Cmd
cmd) Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)
    then do
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"PASSED: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
str
      Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    else do
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"FAILED: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
str
      Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False