Test mode

4 files changed, 185 insertions, 19 deletions

diff --git a/erebos-tester.cabal b/erebos-tester.cabal
index 9d4e5ae..06558a8 100644
--- a/erebos-tester.cabal
+++ b/erebos-tester.cabal
@@ -69,6 +69,7 @@ executable erebos-tester
         Script.Var
         Test
         Test.Builtins
+        TestMode
         Util
         Version
         Version.Git
diff --git a/src/Main.hs b/src/Main.hs
index e69c672..64741e4 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -26,6 +26,7 @@ import Process
 import Run
 import Script.Module
 import Test
+import TestMode
 import Util
 import Version
 
@@ -36,6 +37,7 @@ data CmdlineOptions = CmdlineOptions
     , optColor :: Maybe Bool
     , optShowHelp :: Bool
     , optShowVersion :: Bool
+    , optTestMode :: Bool
     }
 
 defaultCmdlineOptions :: CmdlineOptions
@@ -46,9 +48,10 @@ defaultCmdlineOptions = CmdlineOptions
     , optColor = Nothing
     , optShowHelp = False
     , optShowVersion = False
+    , optTestMode = False
     }
 
-options :: [OptDescr (CmdlineOptions -> CmdlineOptions)]
+options :: [ OptDescr (CmdlineOptions -> CmdlineOptions) ]
 options =
     [ Option ['T'] ["tool"]
         (ReqArg (\str -> to $ \opts -> case break (==':') str of
@@ -95,6 +98,13 @@ options =
   where
     to f opts = opts { optTest = f (optTest opts) }
 
+hiddenOptions :: [ OptDescr (CmdlineOptions -> CmdlineOptions) ]
+hiddenOptions =
+    [ Option [] [ "test-mode" ]
+        (NoArg (\opts -> opts { optTestMode = True }))
+        "test mode"
+    ]
+
 main :: IO ()
 main = do
     configPath <- findConfig
@@ -112,7 +122,7 @@ main = do
             }
 
     args <- getArgs
-    (opts, ofiles) <- case getOpt Permute options args of
+    (opts, ofiles) <- case getOpt Permute (options ++ hiddenOptions) args of
         (o, files, []) -> return (foldl (flip id) initOpts o, files)
         (_, _, errs) -> do
             hPutStrLn stderr $ concat errs <> "Try `erebos-tester --help' for more information."
@@ -133,6 +143,10 @@ main = do
         putStrLn versionLine
         exitSuccess
 
+    when (optTestMode opts) $ do
+        testMode
+        exitSuccess
+
     case words $ optDefaultTool $ optTest opts of
         (path : _) -> getPermissions path >>= \perms -> do
             when (not $ executable perms) $ do
@@ -151,7 +165,10 @@ main = do
     useColor <- case optColor opts of
         Just use -> return use
         Nothing -> queryTerminal (Fd 1)
-    out <- startOutput (optVerbose opts) useColor
+    let outputStyle
+            | optVerbose opts = OutputStyleVerbose
+            | otherwise       = OutputStyleQuiet
+    out <- startOutput outputStyle useColor
 
     ( modules, allModules ) <- parseTestFiles $ map fst files
     tests <- forM (zip modules files) $ \( Module {..}, ( filePath, mbTestName )) -> do
diff --git a/src/Output.hs b/src/Output.hs
index 1555e54..7c4a8a5 100644
--- a/src/Output.hs
+++ b/src/Output.hs
@@ -1,5 +1,5 @@
 module Output (
-    Output, OutputType(..),
+    Output, OutputStyle(..), OutputType(..),
     MonadOutput(..),
     startOutput,
     resetOutputTime,
@@ -9,7 +9,6 @@ module Output (
 ) where
 
 import Control.Concurrent.MVar
-import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Reader
 
@@ -18,9 +17,10 @@ import Data.Text qualified as T
 import Data.Text.Lazy qualified as TL
 import Data.Text.Lazy.IO qualified as TL
 
+import System.Clock
 import System.Console.Haskeline
 import System.Console.Haskeline.History
-import System.Clock
+import System.IO
 
 import Text.Printf
 
@@ -31,7 +31,7 @@ data Output = Output
     }
 
 data OutputConfig = OutputConfig
-    { outVerbose :: Bool
+    { outStyle :: OutputStyle
     , outUseColor :: Bool
     }
 
@@ -40,15 +40,23 @@ data OutputState = OutputState
     , outHistory :: History
     }
 
-data OutputType = OutputChildStdout
-                | OutputChildStderr
-                | OutputChildStdin
-                | OutputChildInfo
-                | OutputChildFail
-                | OutputMatch
-                | OutputMatchFail
-                | OutputError
-                | OutputAlways
+data OutputStyle
+    = OutputStyleQuiet
+    | OutputStyleVerbose
+    | OutputStyleTest
+    deriving (Eq)
+
+data OutputType
+    = OutputChildStdout
+    | OutputChildStderr
+    | OutputChildStdin
+    | OutputChildInfo
+    | OutputChildFail
+    | OutputMatch
+    | OutputMatchFail
+    | OutputError
+    | OutputAlways
+    | OutputTestRaw
 
 class MonadIO m => MonadOutput m where
     getOutput :: m Output
@@ -56,11 +64,12 @@ class MonadIO m => MonadOutput m where
 instance MonadIO m => MonadOutput (ReaderT Output m) where
     getOutput = ask
 
-startOutput :: Bool -> Bool -> IO Output
-startOutput outVerbose outUseColor = do
+startOutput :: OutputStyle -> Bool -> IO Output
+startOutput outStyle outUseColor = do
     outState <- newMVar OutputState { outPrint = TL.putStrLn, outHistory = emptyHistory }
     outConfig <- pure OutputConfig {..}
     outStartedAt <- newMVar =<< getTime Monotonic
+    hSetBuffering stdout LineBuffering
     return Output {..}
 
 resetOutputTime :: Output -> IO ()
@@ -77,6 +86,7 @@ outColor OutputMatch = T.pack "32"
 outColor OutputMatchFail = T.pack "31"
 outColor OutputError = T.pack "31"
 outColor OutputAlways = "0"
+outColor OutputTestRaw = "0"
 
 outSign :: OutputType -> Text
 outSign OutputChildStdout = T.empty
@@ -88,11 +98,25 @@ outSign OutputMatch = T.pack "+"
 outSign OutputMatchFail = T.pack "/"
 outSign OutputError = T.pack "!!"
 outSign OutputAlways = T.empty
+outSign OutputTestRaw = T.empty
 
 outArr :: OutputType -> Text
 outArr OutputChildStdin = "<"
 outArr _ = ">"
 
+outTestLabel :: OutputType -> Text
+outTestLabel = \case
+    OutputChildStdout -> "child-stdout"
+    OutputChildStderr -> "child-stderr"
+    OutputChildStdin -> "child-stdin"
+    OutputChildInfo -> "child-info"
+    OutputChildFail -> "child-fail"
+    OutputMatch -> "match"
+    OutputMatchFail -> "match-fail"
+    OutputError -> "error"
+    OutputAlways -> "other"
+    OutputTestRaw -> ""
+
 printWhenQuiet :: OutputType -> Bool
 printWhenQuiet = \case
     OutputChildStderr -> True
@@ -107,7 +131,14 @@ ioWithOutput act = liftIO . act =<< getOutput
 
 outLine :: MonadOutput m => OutputType -> Maybe Text -> Text -> m ()
 outLine otype prompt line = ioWithOutput $ \out ->
-    when (outVerbose (outConfig out) || printWhenQuiet otype) $ do
+    case outStyle (outConfig out) of
+        OutputStyleQuiet
+            | printWhenQuiet otype -> normalOutput out
+            | otherwise -> return ()
+        OutputStyleVerbose -> normalOutput out
+        OutputStyleTest -> testOutput out
+  where
+    normalOutput out = do
         stime <- readMVar (outStartedAt out)
         nsecs <- toNanoSecs . (`diffTimeSpec` stime) <$> getTime Monotonic
         withMVar (outState out) $ \st -> do
@@ -123,6 +154,16 @@ outLine otype prompt line = ioWithOutput $ \out ->
                     else []
                 ]
 
+    testOutput out = do
+        withMVar (outState out) $ \st -> do
+            outPrint st $ case otype of
+                OutputTestRaw -> TL.fromStrict line
+                _ -> TL.fromChunks
+                    [ outTestLabel otype, " "
+                    , maybe "-" id prompt, " "
+                    , line
+                    ]
+
 outPromptGetLine :: MonadOutput m => Text -> m (Maybe Text)
 outPromptGetLine = outPromptGetLineCompletion noCompletion
 
diff --git a/src/TestMode.hs b/src/TestMode.hs
new file mode 100644
index 0000000..90ccdae
--- /dev/null
+++ b/src/TestMode.hs
@@ -0,0 +1,107 @@
+module TestMode (
+    testMode,
+) where
+
+import Control.Monad.Except
+import Control.Monad.Reader
+import Control.Monad.State
+
+import Data.Bifunctor
+import Data.List
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Text.IO qualified as T
+
+import System.IO.Error
+
+import Output
+import Parser
+import Run
+import Script.Expr
+import Script.Module
+import Test
+
+
+data TestModeInput = TestModeInput
+    { tmiOutput :: Output
+    , tmiParams :: [ Text ]
+    }
+
+data TestModeState = TestModeState
+    { tmsModules :: [ Module ]
+    , tmsGlobals :: GlobalDefs
+    }
+
+initTestModeState :: TestModeState
+initTestModeState = TestModeState
+    { tmsModules = mempty
+    , tmsGlobals = mempty
+    }
+
+testMode :: IO ()
+testMode = do
+    out <- startOutput OutputStyleTest False
+    let testLoop = getLineMb >>= \case
+            Just line -> do
+                case T.words line of
+                    cname : params
+                        | Just (CommandM cmd) <- lookup cname commands -> do
+                            runReaderT cmd $ TestModeInput out params
+                        | otherwise -> fail $ "Unknown command '" ++ T.unpack cname ++ "'"
+                    [] -> return ()
+                testLoop
+
+            Nothing -> return ()
+
+    runExceptT (evalStateT testLoop initTestModeState) >>= \case
+        Left err -> flip runReaderT out $ outLine OutputError Nothing $ T.pack err
+        Right () -> return ()
+
+getLineMb :: MonadIO m => m (Maybe Text)
+getLineMb = liftIO $ catchIOError (Just <$> T.getLine) (\e -> if isEOFError e then return Nothing else ioError e)
+
+cmdOut :: Text -> Command
+cmdOut line = do
+    out <- asks tmiOutput
+    flip runReaderT out $ outLine OutputTestRaw Nothing line
+
+
+newtype CommandM a = CommandM (ReaderT TestModeInput (StateT TestModeState (ExceptT String IO)) a)
+    deriving
+    ( Functor, Applicative, Monad, MonadIO
+    , MonadReader TestModeInput, MonadState TestModeState, MonadError String
+    )
+
+instance MonadFail CommandM where
+    fail = throwError
+
+type Command = CommandM ()
+
+commands :: [ ( Text, Command ) ]
+commands =
+    [ ( "load", cmdLoad )
+    , ( "run", cmdRun )
+    ]
+
+cmdLoad :: Command
+cmdLoad = do
+    [ path ] <- asks tmiParams
+    ( modules, allModules ) <- liftIO $ parseTestFiles [ T.unpack path ]
+    let globalDefs = evalGlobalDefs $ concatMap (\m -> map (first ( moduleName m, )) $ moduleDefinitions m) allModules
+    modify $ \s -> s
+        { tmsModules = modules
+        , tmsGlobals = globalDefs
+        }
+    cmdOut "load-done"
+
+cmdRun :: Command
+cmdRun = do
+    [ name ] <- asks tmiParams
+    TestModeState {..} <- get
+    case find ((name ==) . testName) $ concatMap moduleTests tmsModules of
+        Nothing -> cmdOut "run-not-found"
+        Just test -> do
+            out <- asks tmiOutput
+            liftIO (runTest out defaultTestOptions tmsGlobals test) >>= \case
+                True -> cmdOut "run-done"
+                False -> cmdOut "run-failed"