1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
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"
|