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
|
{-# LANGUAGE CPP #-}
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 Text.Megaparsec.Error
import Text.Megaparsec.Pos
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
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
]
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"
|