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
|
{-# LANGUAGE CPP #-}
module TestMode (
testMode,
) where
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
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 :: Maybe LoadedModules
, tmsNextTestNumber :: Int
}
initTestModeState :: TestModeState
initTestModeState = TestModeState
{ tmsModules = Nothing
, 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
Just LoadedModules {..} <- gets tmsModules
mbconfig <- asks tmiConfig
let opts = defaultTestOptions
{ optDefaultTool = fromMaybe "/bin/true" $ configTool =<< mbconfig
, optTestDir = ".test" <> show num
, optKeep = True
}
liftIO (runTest out opts lmGlobalDefs 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 )
]
showError :: Text -> CustomTestError -> Command
showError prefix = \case
ModuleNotFound moduleName -> do
cmdOut $ prefix <> " module-not-found" <> textModuleName moduleName
FileNotFound notFoundPath -> do
cmdOut $ prefix <> " file-not-found " <> T.pack notFoundPath
ImportModuleError bundle -> do
#if MIN_VERSION_megaparsec(9,7,0)
mapM_ (cmdOut . T.pack) $ lines $ errorBundlePrettyWith showParseError bundle
#endif
cmdOut $ prefix <> " parse-error"
where
showParseError _ SourcePos {..} _ = concat
[ "parse-error"
, " ", sourceName
, ":", show $ unPos sourceLine
, ":", show $ unPos sourceColumn
]
cmdLoad :: Command
cmdLoad = do
[ path ] <- asks tmiParams
liftIO (loadModulesErr [ T.unpack path ]) >>= \case
Right modules -> do
modify $ \s -> s { tmsModules = Just modules }
cmdOut "load-done"
Left err -> showError "load-failed" err
cmdLoadConfig :: Command
cmdLoadConfig = do
Just config <- asks tmiConfig
liftIO (getConfigTestFiles config >>= loadModulesErr) >>= \case
Right modules -> do
modify $ \s -> s { tmsModules = Just modules }
cmdOut "load-config-done"
Left err -> showError "load-config-failed" err
cmdRun :: Command
cmdRun = do
[ name ] <- asks tmiParams
Just LoadedModules {..} <- gets tmsModules
case find ((name ==) . testName) $ concatMap moduleTests lmModules of
Nothing -> cmdOut "run-not-found"
Just test -> do
runSingleTest test >>= \case
True -> cmdOut "run-done"
False -> cmdOut "run-failed"
cmdRunAll :: Command
cmdRunAll = do
Just LoadedModules {..} <- gets tmsModules
forM_ (concatMap moduleTests lmModules) $ \test -> do
res <- runSingleTest test
cmdOut $ "run-test-result " <> testName test <> " " <> (if res then "done" else "failed")
cmdOut "run-all-done"
|