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
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
|
{-# LANGUAGE CPP #-}
module TestMode (
testMode,
) where
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Data.Bifunctor
import Data.List
import Data.Maybe
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.IO qualified as T
import System.IO.Error
import Text.Megaparsec.Error
import Text.Megaparsec.Pos
import Config
import Output
import Parser
import Run
import Script.Expr
import Script.Module
import Test
data TestModeInput = TestModeInput
{ tmiOutput :: Output
, tmiConfig :: Maybe Config
, tmiParams :: [ Text ]
}
data TestModeState = TestModeState
{ tmsModules :: [ Module ]
, tmsGlobals :: GlobalDefs
, tmsNextTestNumber :: Int
}
initTestModeState :: TestModeState
initTestModeState = TestModeState
{ tmsModules = mempty
, tmsGlobals = mempty
, tmsNextTestNumber = 1
}
testMode :: Maybe Config -> IO ()
testMode tmiConfig = do
tmiOutput <- startOutput OutputStyleTest False
let testLoop = getLineMb >>= \case
Just line -> do
case T.words line of
cname : tmiParams
| Just (CommandM cmd) <- lookup cname commands -> do
runReaderT cmd $ TestModeInput {..}
| otherwise -> fail $ "Unknown command '" ++ T.unpack cname ++ "'"
[] -> return ()
testLoop
Nothing -> return ()
runExceptT (evalStateT testLoop initTestModeState) >>= \case
Left err -> flip runReaderT tmiOutput $ 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
getNextTestNumber :: CommandM Int
getNextTestNumber = do
num <- gets tmsNextTestNumber
modify $ \s -> s { tmsNextTestNumber = num + 1 }
return num
runSingleTest :: Test -> CommandM Bool
runSingleTest test = do
out <- asks tmiOutput
num <- getNextTestNumber
globals <- gets tmsGlobals
mbconfig <- asks tmiConfig
let opts = defaultTestOptions
{ optDefaultTool = fromMaybe "" $ configTool =<< mbconfig
, optTestDir = ".test" <> show num
, optKeep = True
}
liftIO (runTest out opts globals test)
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 )
, ( "load-config", cmdLoadConfig )
, ( "run", cmdRun )
, ( "run-all", cmdRunAll )
]
cmdLoad :: Command
cmdLoad = do
[ path ] <- asks tmiParams
liftIO (parseTestFiles [ T.unpack path ]) >>= \case
Right ( modules, allModules ) -> do
let globalDefs = evalGlobalDefs $ concatMap (\m -> map (first ( moduleName m, )) $ moduleDefinitions m) allModules
modify $ \s -> s
{ tmsModules = modules
, tmsGlobals = globalDefs
}
cmdOut "load-done"
Left (ModuleNotFound moduleName) -> do
cmdOut $ "load-failed module-not-found" <> textModuleName moduleName
Left (FileNotFound notFoundPath) -> do
cmdOut $ "load-failed file-not-found " <> T.pack notFoundPath
Left (ImportModuleError bundle) -> do
#if MIN_VERSION_megaparsec(9,7,0)
mapM_ (cmdOut . T.pack) $ lines $ errorBundlePrettyWith showParseError bundle
#endif
cmdOut $ "load-failed parse-error"
where
showParseError _ SourcePos {..} _ = concat
[ "parse-error"
, " ", sourceName
, ":", show $ unPos sourceLine
, ":", show $ unPos sourceColumn
]
cmdLoadConfig :: Command
cmdLoadConfig = do
Just config <- asks tmiConfig
( modules, globalDefs ) <- liftIO $ loadModules =<< getConfigTestFiles config
modify $ \s -> s
{ tmsModules = modules
, tmsGlobals = globalDefs
}
cmdOut "load-config-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
runSingleTest test >>= \case
True -> cmdOut "run-done"
False -> cmdOut "run-failed"
cmdRunAll :: Command
cmdRunAll = do
TestModeState {..} <- get
forM_ (concatMap moduleTests tmsModules) $ \test -> do
res <- runSingleTest test
cmdOut $ "run-test-result " <> testName test <> " " <> (if res then "done" else "failed")
cmdOut "run-all-done"
|