summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Asset.hs33
-rw-r--r--src/Config.hs43
-rw-r--r--src/GDB.hs4
-rw-r--r--src/Main.hs91
-rw-r--r--src/Network.hs8
-rw-r--r--src/Network.hs-boot5
-rw-r--r--src/Network/Ip.hs40
-rw-r--r--src/Output.hs91
-rw-r--r--src/Parser.hs164
-rw-r--r--src/Parser/Core.hs99
-rw-r--r--src/Parser/Expr.hs82
-rw-r--r--src/Parser/Shell.hs81
-rw-r--r--src/Parser/Statement.hs128
-rw-r--r--src/Process.hs62
-rw-r--r--src/Run.hs134
-rw-r--r--src/Run/Monad.hs42
-rw-r--r--src/Script/Expr.hs452
-rw-r--r--src/Script/Expr/Class.hs77
-rw-r--r--src/Script/Module.hs20
-rw-r--r--src/Script/Object.hs42
-rw-r--r--src/Script/Shell.hs94
-rw-r--r--src/Script/Var.hs56
-rw-r--r--src/Test.hs562
-rw-r--r--src/Test/Builtins.hs34
-rw-r--r--src/TestMode.hs174
25 files changed, 1811 insertions, 807 deletions
diff --git a/src/Asset.hs b/src/Asset.hs
new file mode 100644
index 0000000..72ffd54
--- /dev/null
+++ b/src/Asset.hs
@@ -0,0 +1,33 @@
+module Asset (
+ Asset(..),
+ AssetPath(..),
+) where
+
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Typeable
+
+import Script.Expr.Class
+
+data Asset = Asset
+ { assetPath :: AssetPath
+ }
+
+newtype AssetPath = AssetPath FilePath
+
+textAssetPath :: AssetPath -> Text
+textAssetPath (AssetPath path) = T.pack path
+
+instance ExprType Asset where
+ textExprType _ = "asset"
+ textExprValue asset = "asset:" <> textAssetPath (assetPath asset)
+
+ recordMembers =
+ [ ( "path", RecordSelector $ assetPath )
+ ]
+
+instance ExprType AssetPath where
+ textExprType _ = "filepath"
+ textExprValue = ("filepath:" <>) . textAssetPath
+
+ exprExpansionConvTo = cast textAssetPath
diff --git a/src/Config.hs b/src/Config.hs
index 7f5895c..adf0321 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -2,11 +2,13 @@ module Config (
Config(..),
findConfig,
parseConfig,
+ getConfigTestFiles,
) where
import Control.Monad.Combinators
import Data.ByteString.Lazy qualified as BS
+import Data.Scientific
import Data.Text qualified as T
import Data.YAML
@@ -16,31 +18,31 @@ import System.FilePath
import System.FilePath.Glob
data Config = Config
- { configTool :: Maybe FilePath
- , configTests :: [Pattern]
+ { configDir :: FilePath
+ , configTool :: Maybe FilePath
+ , configTests :: [ Pattern ]
+ , configTimeout :: Maybe Scientific
}
deriving (Show)
-instance Semigroup Config where
- a <> b = Config
- { configTool = maybe (configTool b) Just (configTool a)
- , configTests = configTests a ++ configTests b
- }
-
-instance Monoid Config where
- mempty = Config
- { configTool = Nothing
- , configTests = []
- }
-
-instance FromYAML Config where
- parseYAML = withMap "Config" $ \m -> Config
- <$> (fmap T.unpack <$> m .:? "tool")
- <*> (map (compile . T.unpack) <$> foldr1 (<|>)
+instance FromYAML (FilePath -> Config) where
+ parseYAML = withMap "Config" $ \m -> do
+ configTool <- (fmap T.unpack <$> m .:? "tool")
+ configTests <- (map (compile . T.unpack) <$> foldr1 (<|>)
[ fmap (:[]) (m .: "tests") -- single pattern
, m .:? "tests" .!= [] -- list of patterns
]
)
+ configTimeout <- fmap fromNumber <$> m .:! "timeout"
+ return $ \configDir -> Config {..}
+
+newtype Number = Number { fromNumber :: Scientific }
+
+instance FromYAML Number where
+ parseYAML = \case
+ Scalar _ (SFloat x) -> return $ Number $ realToFrac x
+ Scalar _ (SInt x) -> return $ Number $ fromIntegral x
+ node -> typeMismatch "int or float" node
findConfig :: IO (Maybe FilePath)
findConfig = go "."
@@ -63,4 +65,7 @@ parseConfig path = do
Left (pos, err) -> do
putStr $ prettyPosWithSource pos contents err
exitFailure
- Right conf -> return conf
+ Right conf -> return $ conf $ takeDirectory path
+
+getConfigTestFiles :: Config -> IO [ FilePath ]
+getConfigTestFiles config = concat <$> mapM (flip globDir1 $ configDir config) (configTests config)
diff --git a/src/GDB.hs b/src/GDB.hs
index 2862065..0819600 100644
--- a/src/GDB.hs
+++ b/src/GDB.hs
@@ -75,7 +75,7 @@ gdbStart onCrash = do
let process = Process
{ procName = ProcNameGDB
- , procHandle = handle
+ , procHandle = Left handle
, procStdin = hin
, procOutput = pout
, procKillWith = Nothing
@@ -144,7 +144,7 @@ gdbLine gdb rline = either (outProc OutputError (gdbProcess gdb) . T.pack . erro
addInferior :: MonadOutput m => GDB -> Process -> m ()
addInferior gdb process = do
- liftIO (getPid $ procHandle process) >>= \case
+ liftIO (either getPid (\_ -> return Nothing) $ procHandle process) >>= \case
Nothing -> outProc OutputError process $ "failed to get PID"
Just pid -> do
tgid <- liftIO (atomically $ tryReadTChan $ gdbThreadGroups gdb) >>= \case
diff --git a/src/Main.hs b/src/Main.hs
index 01bb766..b3f7a2a 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -2,8 +2,10 @@ module Main (main) where
import Control.Monad
+import Data.List
import Data.Maybe
-import qualified Data.Text as T
+import Data.Text (Text)
+import Data.Text qualified as T
import Text.Read (readMaybe)
@@ -12,40 +14,44 @@ import System.Directory
import System.Environment
import System.Exit
import System.FilePath
-import System.FilePath.Glob
import System.IO
import System.Posix.Terminal
import System.Posix.Types
import Config
import Output
-import Parser
import Process
import Run
+import Script.Module
import Test
+import TestMode
import Util
import Version
data CmdlineOptions = CmdlineOptions
{ optTest :: TestOptions
, optRepeat :: Int
+ , optExclude :: [ Text ]
, optVerbose :: Bool
, optColor :: Maybe Bool
, optShowHelp :: Bool
, optShowVersion :: Bool
+ , optTestMode :: Bool
}
defaultCmdlineOptions :: CmdlineOptions
defaultCmdlineOptions = CmdlineOptions
{ optTest = defaultTestOptions
, optRepeat = 1
+ , optExclude = []
, optVerbose = False
, 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
@@ -79,6 +85,9 @@ options =
, Option ['r'] ["repeat"]
(ReqArg (\str opts -> opts { optRepeat = read str }) "<count>")
"number of times to repeat the test(s)"
+ , Option [ 'e' ] [ "exclude" ]
+ (ReqArg (\str opts -> opts { optExclude = T.pack str : optExclude opts }) "<test>")
+ "exclude given test from execution"
, Option [] ["wait"]
(NoArg $ to $ \opts -> opts { optWait = True })
"wait at the end of each test"
@@ -92,11 +101,17 @@ 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
- config <- mapM parseConfig configPath
- let baseDir = maybe "." dropFileName configPath
+ config <- mapM parseConfig =<< findConfig
+ let baseDir = maybe "." configDir config
envtool <- lookupEnv "EREBOS_TEST_TOOL" >>= \mbtool ->
return $ fromMaybe (error "No test tool defined") $ mbtool `mplus` (return . (baseDir </>) =<< configTool =<< config)
@@ -105,19 +120,26 @@ main = do
{ optTest = defaultTestOptions
{ optDefaultTool = envtool
, optTestDir = normalise $ baseDir </> optTestDir defaultTestOptions
+ , optTimeout = fromMaybe (optTimeout defaultTestOptions) $ configTimeout =<< config
}
}
args <- getArgs
- (opts, ofiles) <- case getOpt Permute options args of
+ (opts, oselection) <- 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."
exitFailure
+ let ( ofiles, otests )
+ | any (any isPathSeparator) oselection = ( oselection, [] )
+ | otherwise = ( [], map T.pack oselection )
+
when (optShowHelp opts) $ do
let header = unlines
- [ "Usage: erebos-tester [<option>...] [<script>[:<test>]...]"
+ [ "Usage: erebos-tester [<option>...] [<test-name>...]"
+ , " or: erebos-tester [<option>...] <script>[:<test>]..."
+ , " <test-name> name of a test from project configuration"
, " <script> path to test script file"
, " <test> name of the test to run"
, ""
@@ -130,32 +152,55 @@ main = do
putStrLn versionLine
exitSuccess
- getPermissions (head $ words $ optDefaultTool $ optTest opts) >>= \perms -> do
- when (not $ executable perms) $ do
- fail $ optDefaultTool (optTest opts) <> " is not executable"
+ when (optTestMode opts) $ do
+ testMode config
+ exitSuccess
+
+ case words $ optDefaultTool $ optTest opts of
+ (path : _) -> getPermissions path >>= \perms -> do
+ when (not $ executable perms) $ do
+ fail $ "‘" <> path <> "’ is not executable"
+ _ -> fail $ "invalid tool argument: ‘" <> optDefaultTool (optTest opts) <> "’"
files <- if not (null ofiles)
then return $ flip map ofiles $ \ofile ->
case span (/= ':') ofile of
(path, ':':test) -> (path, Just $ T.pack test)
(path, _) -> (path, Nothing)
- else map (, Nothing) . concat <$> mapM (flip globDir1 baseDir) (maybe [] configTests config)
+ else map (, Nothing) <$> maybe (return []) (getConfigTestFiles) config
when (null files) $ fail $ "No test files"
useColor <- case optColor opts of
Just use -> return use
Nothing -> queryTerminal (Fd 1)
- out <- startOutput (optVerbose opts) useColor
-
- tests <- forM files $ \(path, mbTestName) -> do
- Module {..} <- parseTestFile path
- return $ map ( , moduleDefinitions ) $ case mbTestName of
- Nothing -> moduleTests
- Just name -> filter ((==name) . testName) moduleTests
-
- ok <- allM (uncurry $ runTest out $ optTest opts) $
- concat $ replicate (optRepeat opts) $ concat tests
+ let outputStyle
+ | optVerbose opts = OutputStyleVerbose
+ | otherwise = OutputStyleQuiet
+ out <- startOutput outputStyle useColor
+
+ ( modules, globalDefs ) <- loadModules (map fst files)
+ tests <- filter ((`notElem` optExclude opts) . testName) <$> if null otests
+ then fmap concat $ forM (zip modules files) $ \( Module {..}, ( filePath, mbTestName )) -> do
+ case mbTestName of
+ Nothing -> return moduleTests
+ Just name
+ | Just test <- find ((name ==) . testName) moduleTests
+ -> return [ test ]
+ | otherwise
+ -> do
+ hPutStrLn stderr $ "Test ‘" <> T.unpack name <> "’ not found in ‘" <> filePath <> "’"
+ exitFailure
+ else forM otests $ \name -> if
+ | Just test <- find ((name ==) . testName) $ concatMap moduleTests modules
+ -> return test
+ | otherwise
+ -> do
+ hPutStrLn stderr $ "Test ‘" <> T.unpack name <> "’ not found"
+ exitFailure
+
+ ok <- allM (runTest out (optTest opts) globalDefs) $
+ concat $ replicate (optRepeat opts) tests
when (not ok) exitFailure
foreign export ccall testerMain :: IO ()
diff --git a/src/Network.hs b/src/Network.hs
index c841acb..e12231d 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -26,7 +26,8 @@ import System.FilePath
import System.Process
import Network.Ip
-import Test
+import Script.Expr
+import Script.Expr.Class
{-
NETWORK STRUCTURE
@@ -108,8 +109,9 @@ instance ExprType Node where
textExprValue n = T.pack "n:" <> textNodeName (nodeName n)
recordMembers = map (first T.pack)
- [ ("ip", RecordSelector $ textIpAddress . nodeIp)
- , ("network", RecordSelector $ nodeNetwork)
+ [ ( "ifname", RecordSelector $ const ("veth0" :: Text) )
+ , ( "ip", RecordSelector $ textIpAddress . nodeIp )
+ , ( "network", RecordSelector $ nodeNetwork )
]
diff --git a/src/Network.hs-boot b/src/Network.hs-boot
deleted file mode 100644
index 1b5e9c4..0000000
--- a/src/Network.hs-boot
+++ /dev/null
@@ -1,5 +0,0 @@
-module Network where
-
-data Network
-data Node
-data NodeName
diff --git a/src/Network/Ip.hs b/src/Network/Ip.hs
index 8f0887a..69a6b43 100644
--- a/src/Network/Ip.hs
+++ b/src/Network/Ip.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
module Network.Ip (
IpPrefix(..),
textIpNetwork,
@@ -17,7 +19,9 @@ module Network.Ip (
NetworkNamespace,
HasNetns(..),
addNetworkNamespace,
+ setNetworkNamespace,
textNetnsName,
+ runInNetworkNamespace,
callOn,
Link(..),
@@ -32,7 +36,9 @@ module Network.Ip (
addRoute,
) where
+import Control.Concurrent
import Control.Concurrent.STM
+import Control.Exception
import Control.Monad
import Control.Monad.Writer
@@ -42,6 +48,11 @@ import Data.Text qualified as T
import Data.Typeable
import Data.Word
+import Foreign.C.Error
+import Foreign.C.Types
+
+import System.Posix.IO
+import System.Posix.Types
import System.Process
newtype IpPrefix = IpPrefix [Word8]
@@ -122,12 +133,37 @@ addNetworkNamespace netnsName = do
netnsRoutesActive <- liftSTM $ newTVar []
return $ NetworkNamespace {..}
+setNetworkNamespace :: MonadIO m => NetworkNamespace -> m ()
+setNetworkNamespace netns = liftIO $ do
+ let path = "/var/run/netns/" <> T.unpack (textNetnsName netns)
+#if MIN_VERSION_unix(2,8,0)
+ open = openFd path ReadOnly defaultFileFlags { cloexec = True }
+#else
+ open = openFd path ReadOnly Nothing defaultFileFlags
+#endif
+ res <- bracket open closeFd $ \(Fd fd) -> do
+ c_setns fd c_CLONE_NEWNET
+ when (res /= 0) $ do
+ throwErrno "setns failed"
+
+foreign import ccall unsafe "sched.h setns" c_setns :: CInt -> CInt -> IO CInt
+c_CLONE_NEWNET :: CInt
+c_CLONE_NEWNET = 0x40000000
+
+runInNetworkNamespace :: NetworkNamespace -> IO a -> IO a
+runInNetworkNamespace netns act = do
+ mvar <- newEmptyMVar
+ void $ forkOS $ do
+ setNetworkNamespace netns
+ putMVar mvar =<< act
+ takeMVar mvar
+
+
textNetnsName :: NetworkNamespace -> Text
textNetnsName = netnsName
callOn :: HasNetns a => a -> Text -> IO ()
-callOn n cmd = callCommand $ T.unpack $ "ip netns exec \"" <> ns <> "\" " <> cmd
- where ns = textNetnsName $ getNetns n
+callOn n cmd = runInNetworkNamespace (getNetns n) $ callCommand $ T.unpack cmd
data Link a = Link
diff --git a/src/Output.hs b/src/Output.hs
index 135e6e0..7c4a8a5 100644
--- a/src/Output.hs
+++ b/src/Output.hs
@@ -1,14 +1,14 @@
module Output (
- Output, OutputType(..),
+ Output, OutputStyle(..), OutputType(..),
MonadOutput(..),
startOutput,
+ resetOutputTime,
outLine,
outPromptGetLine,
outPromptGetLineCompletion,
) where
import Control.Concurrent.MVar
-import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
@@ -17,16 +17,21 @@ 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.IO
+
+import Text.Printf
data Output = Output
{ outState :: MVar OutputState
, outConfig :: OutputConfig
+ , outStartedAt :: MVar TimeSpec
}
data OutputConfig = OutputConfig
- { outVerbose :: Bool
+ { outStyle :: OutputStyle
, outUseColor :: Bool
}
@@ -35,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
@@ -51,10 +64,17 @@ class MonadIO m => MonadOutput m where
instance MonadIO m => MonadOutput (ReaderT Output m) where
getOutput = ask
-startOutput :: Bool -> Bool -> IO Output
-startOutput outVerbose outUseColor = Output
- <$> newMVar OutputState { outPrint = TL.putStrLn, outHistory = emptyHistory }
- <*> pure OutputConfig { .. }
+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 ()
+resetOutputTime Output {..} = do
+ modifyMVar_ outStartedAt . const $ getTime Monotonic
outColor :: OutputType -> Text
outColor OutputChildStdout = T.pack "0"
@@ -66,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
@@ -77,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
@@ -96,10 +131,20 @@ 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
outPrint st $ TL.fromChunks $ concat
- [ if outUseColor (outConfig out)
+ [ [ T.pack $ printf "[% 2d.%03d] " (nsecs `quot` 1000000000) ((nsecs `quot` 1000000) `rem` 1000) ]
+ , if outUseColor (outConfig out)
then [ T.pack "\ESC[", outColor otype, T.pack "m" ]
else []
, [ maybe "" (<> outSign otype <> outArr otype <> " ") prompt ]
@@ -109,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/Parser.hs b/src/Parser.hs
index e23b277..9f1a0e3 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -1,12 +1,15 @@
{-# OPTIONS_GHC -Wno-orphans #-}
module Parser (
- parseTestFile,
+ parseTestFiles,
+ CustomTestError(..),
) where
import Control.Monad
+import Control.Monad.Except
import Control.Monad.State
+import Data.IORef
import Data.Map qualified as M
import Data.Maybe
import Data.Proxy
@@ -21,13 +24,16 @@ import Text.Megaparsec.Char
import Text.Megaparsec.Char.Lexer qualified as L
import System.Directory
-import System.Exit
import System.FilePath
+import System.IO.Error
+import Asset
import Network
import Parser.Core
import Parser.Expr
import Parser.Statement
+import Script.Expr
+import Script.Module
import Test
import Test.Builtins
@@ -37,36 +43,37 @@ parseTestDefinition = label "test definition" $ toplevel ToplevelTest $ do
modify $ \s -> s
{ testContext = SomeExpr $ varExpr SourceLineBuiltin rootNetworkVar
}
- block (\name steps -> return $ Test name $ mconcat steps) header testStep
+ block (\name steps -> return $ Test name $ Scope <$> mconcat steps) header testStep
where
header = do
wsymbol "test"
lexeme $ TL.toStrict <$> takeWhileP (Just "test name") (/=':')
-parseDefinition :: TestParser Toplevel
-parseDefinition = label "symbol definition" $ toplevel ToplevelDefinition $ do
- def <- localState $ L.indentBlock scn $ do
+parseDefinition :: Pos -> TestParser ( VarName, SomeExpr )
+parseDefinition href = label "symbol definition" $ do
+ def@( name, expr ) <- localState $ do
wsymbol "def"
name <- varName
argsDecl <- functionArguments (\off _ -> return . ( off, )) varName mzero (\_ -> return . VarName)
atypes <- forM argsDecl $ \( off, vname :: VarName ) -> do
tvar <- newTypeVar
- modify $ \s -> s { testVars = ( vname, ExprTypeVar tvar ) : testVars s }
+ modify $ \s -> s { testVars = ( vname, ( LocalVarName vname, ExprTypeVar tvar )) : testVars s }
return ( off, vname, tvar )
- choice
+ SomeExpr expr <- choice
[ do
osymbol ":"
- let finish steps = do
- atypes' <- getInferredTypes atypes
- ( name, ) . SomeExpr . ArgsReq atypes' . FunctionAbstraction <$> replaceDynArgs (mconcat steps)
- return $ L.IndentSome Nothing finish testStep
+ scn
+ ref <- L.indentGuard scn GT href
+ SomeExpr <$> testBlock ref
, do
osymbol "="
- SomeExpr (expr :: Expr e) <- someExpr
- atypes' <- getInferredTypes atypes
- L.IndentNone . ( name, ) . SomeExpr . ArgsReq atypes' . FunctionAbstraction <$> replaceDynArgs expr
+ someExpr <* eol
]
- modify $ \s -> s { testVars = fmap someExprType def : testVars s }
+ scn
+ atypes' <- getInferredTypes atypes
+ sexpr <- SomeExpr . ArgsReq atypes' . FunctionAbstraction <$> replaceDynArgs expr
+ return ( name, sexpr )
+ modify $ \s -> s { testVars = ( name, ( GlobalVarName (testCurrentModuleName s) name, someExprType expr )) : testVars s }
return def
where
getInferredTypes atypes = forM atypes $ \( off, vname, tvar@(TypeVar tvarname) ) -> do
@@ -94,45 +101,124 @@ parseDefinition = label "symbol definition" $ toplevel ToplevelDefinition $ do
replaceArgs (SomeExpr e) = SomeExpr (go unif e)
e -> e
+parseAsset :: Pos -> TestParser ( VarName, SomeExpr )
+parseAsset href = label "asset definition" $ do
+ wsymbol "asset"
+ name <- varName
+ osymbol ":"
+ void eol
+ ref <- L.indentGuard scn GT href
+
+ wsymbol "path"
+ osymbol ":"
+ off <- stateOffset <$> getParserState
+ path <- TL.unpack <$> takeWhile1P Nothing (/= '\n')
+ dir <- takeDirectory <$> gets testSourcePath
+ absPath <- liftIO (makeAbsolute $ dir </> path)
+ let assetPath = AssetPath absPath
+ liftIO (doesPathExist absPath) >>= \case
+ True -> return ()
+ False -> registerParseError $ FancyError off $ S.singleton $ ErrorCustom $ FileNotFound absPath
+
+ void $ L.indentGuard scn LT ref
+ let expr = SomeExpr $ Pure Asset {..}
+ modify $ \s -> s { testVars = ( name, ( GlobalVarName (testCurrentModuleName s) name, someExprType expr )) : testVars s }
+ return ( name, expr )
+
+parseExport :: TestParser [ Toplevel ]
+parseExport = label "export declaration" $ toplevel id $ do
+ ref <- L.indentLevel
+ wsymbol "export"
+ choice
+ [ do
+ def@( name, _ ) <- parseDefinition ref <|> parseAsset ref
+ return [ ToplevelDefinition def, ToplevelExport name ]
+ , do
+ names <- listOf varName
+ eol >> scn
+ return $ map ToplevelExport names
+ ]
+
+parseImport :: TestParser [ Toplevel ]
+parseImport = label "import declaration" $ toplevel (\() -> []) $ do
+ wsymbol "import"
+ modName <- parseModuleName
+ importedModule <- getOrParseModule modName
+ modify $ \s -> s { testVars = map (fmap (fmap someExprType)) (moduleExportedDefinitions importedModule) ++ testVars s }
+ eol >> scn
+
parseTestModule :: FilePath -> TestParser Module
parseTestModule absPath = do
+ scn
moduleName <- choice
[ label "module declaration" $ do
wsymbol "module"
off <- stateOffset <$> getParserState
- x <- identifier
- name <- (x:) <$> many (symbol "." >> identifier)
- when (or (zipWith (/=) (reverse name) (reverse $ map T.pack $ splitDirectories $ dropExtension $ absPath))) $ do
+ name@(ModuleName tname) <- parseModuleName
+ when (or (zipWith (/=) (reverse tname) (reverse $ map T.pack $ splitDirectories $ dropExtension $ absPath))) $ do
registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
"module name does not match file path"
eol >> scn
return name
, do
- return $ [ T.pack $ takeBaseName absPath ]
+ return $ ModuleName [ T.pack $ takeBaseName absPath ]
]
- toplevels <- many $ choice
- [ parseTestDefinition
- , parseDefinition
+ modify $ \s -> s { testCurrentModuleName = moduleName }
+ toplevels <- fmap concat $ many $ choice
+ [ (: []) <$> parseTestDefinition
+ , (: []) <$> toplevel ToplevelDefinition (parseDefinition pos1)
+ , (: []) <$> toplevel ToplevelDefinition (parseAsset pos1)
+ , parseExport
+ , parseImport
]
let moduleTests = catMaybes $ map (\case ToplevelTest x -> Just x; _ -> Nothing) toplevels
moduleDefinitions = catMaybes $ map (\case ToplevelDefinition x -> Just x; _ -> Nothing) toplevels
+ moduleExports = catMaybes $ map (\case ToplevelExport x -> Just x; _ -> Nothing) toplevels
eof
return Module {..}
-parseTestFile :: FilePath -> IO Module
-parseTestFile path = do
- content <- TL.readFile path
- absPath <- makeAbsolute path
- let initState = TestParserState
- { testVars = concat
- [ map (fmap someVarValueType) builtins
- ]
- , testContext = SomeExpr (Undefined "void" :: Expr Void)
- , testNextTypeVar = 0
- , testTypeUnif = M.empty
- }
- res = runTestParser path content initState $ parseTestModule absPath
+parseTestFiles :: [ FilePath ] -> IO (Either CustomTestError ( [ Module ], [ Module ] ))
+parseTestFiles paths = do
+ parsedModules <- newIORef []
+ runExceptT $ do
+ requestedModules <- reverse <$> foldM (go parsedModules) [] paths
+ allModules <- map snd <$> liftIO (readIORef parsedModules)
+ return ( requestedModules, allModules )
+ where
+ go parsedModules res path = do
+ liftIO (parseTestFile parsedModules Nothing path) >>= \case
+ Left err -> do
+ throwError err
+ Right cur -> do
+ return $ cur : res
- case res of
- Left err -> putStr (errorBundlePretty err) >> exitFailure
- Right testModule -> return testModule
+parseTestFile :: IORef [ ( FilePath, Module ) ] -> Maybe ModuleName -> FilePath -> IO (Either CustomTestError Module)
+parseTestFile parsedModules mbModuleName path = do
+ absPath <- makeAbsolute path
+ (lookup absPath <$> readIORef parsedModules) >>= \case
+ Just found -> return $ Right found
+ Nothing -> do
+ let initState = TestParserState
+ { testSourcePath = path
+ , testVars = concat
+ [ map (\(( mname, name ), value ) -> ( name, ( GlobalVarName mname name, someVarValueType value ))) $ M.toList builtins
+ ]
+ , testContext = SomeExpr (Undefined "void" :: Expr Void)
+ , testNextTypeVar = 0
+ , testTypeUnif = M.empty
+ , testCurrentModuleName = fromMaybe (error "current module name should be set at the beginning of parseTestModule") mbModuleName
+ , testParseModule = \(ModuleName current) mname@(ModuleName imported) -> do
+ let projectRoot = iterate takeDirectory absPath !! length current
+ parseTestFile parsedModules (Just mname) $ projectRoot </> foldr (</>) "" (map T.unpack imported) <.> takeExtension absPath
+ }
+ mbContent <- (Just <$> TL.readFile path) `catchIOError` \e ->
+ if isDoesNotExistError e then return Nothing else ioError e
+ case mbContent of
+ Just content -> do
+ runTestParser content initState (parseTestModule absPath) >>= \case
+ Left bundle -> do
+ return $ Left $ ImportModuleError bundle
+ Right testModule -> do
+ modifyIORef parsedModules (( absPath, testModule ) : )
+ return $ Right testModule
+ Nothing -> return $ Left $ maybe (FileNotFound path) ModuleNotFound mbModuleName
diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs
index 5fb4c5f..132dbc8 100644
--- a/src/Parser/Core.hs
+++ b/src/Parser/Core.hs
@@ -2,7 +2,6 @@ module Parser.Core where
import Control.Applicative
import Control.Monad
-import Control.Monad.Identity
import Control.Monad.State
import Data.Map (Map)
@@ -12,40 +11,72 @@ import Data.Set qualified as S
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Data.Typeable
-import Data.Void
import Text.Megaparsec hiding (State)
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L
import Network ()
+import Script.Expr
+import Script.Module
import Test
-newtype TestParser a = TestParser (StateT TestParserState (ParsecT Void TestStream Identity) a)
+newtype TestParser a = TestParser (StateT TestParserState (ParsecT CustomTestError TestStream IO) a)
deriving
( Functor, Applicative, Alternative, Monad
, MonadState TestParserState
, MonadPlus
, MonadFail
- , MonadParsec Void TestStream
+ , MonadIO
+ , MonadParsec CustomTestError TestStream
)
type TestStream = TL.Text
-type TestParseError = ParseError TestStream Void
+type TestParseError = ParseError TestStream CustomTestError
-runTestParser :: String -> TestStream -> TestParserState -> TestParser a -> Either (ParseErrorBundle TestStream Void) a
-runTestParser path content initState (TestParser parser) = runIdentity . flip (flip runParserT path) content . flip evalStateT initState $ parser
+data CustomTestError
+ = ModuleNotFound ModuleName
+ | FileNotFound FilePath
+ | ImportModuleError (ParseErrorBundle TestStream CustomTestError)
+ deriving (Eq)
+
+instance Ord CustomTestError where
+ compare (ModuleNotFound a) (ModuleNotFound b) = compare a b
+ compare (ModuleNotFound _) _ = LT
+ compare _ (ModuleNotFound _) = GT
+
+ compare (FileNotFound a) (FileNotFound b) = compare a b
+ compare (FileNotFound _) _ = LT
+ compare _ (FileNotFound _) = GT
+
+ -- Ord instance is required to store errors in Set, but there shouldn't be
+ -- two ImportModuleErrors at the same possition, so "dummy" comparison
+ -- should be ok.
+ compare (ImportModuleError _) (ImportModuleError _) = EQ
+
+instance ShowErrorComponent CustomTestError where
+ showErrorComponent (ModuleNotFound name) = "module ‘" <> T.unpack (textModuleName name) <> "’ not found"
+ showErrorComponent (FileNotFound path) = "file ‘" <> path <> "’ not found"
+ showErrorComponent (ImportModuleError bundle) = "error parsing imported module:\n" <> errorBundlePretty bundle
+
+runTestParser :: TestStream -> TestParserState -> TestParser a -> IO (Either (ParseErrorBundle TestStream CustomTestError) a)
+runTestParser content initState (TestParser parser) = flip (flip runParserT (testSourcePath initState)) content . flip evalStateT initState $ parser
data Toplevel
= ToplevelTest Test
| ToplevelDefinition ( VarName, SomeExpr )
+ | ToplevelExport VarName
+ | ToplevelImport ( ModuleName, VarName )
data TestParserState = TestParserState
- { testVars :: [ ( VarName, SomeExprType ) ]
+ { testSourcePath :: FilePath
+ , testVars :: [ ( VarName, ( FqVarName, SomeExprType )) ]
, testContext :: SomeExpr
, testNextTypeVar :: Int
, testTypeUnif :: Map TypeVar SomeExprType
+ , testCurrentModuleName :: ModuleName
+ , testParseModule :: ModuleName -> ModuleName -> IO (Either CustomTestError Module)
}
newTypeVar :: TestParser TypeVar
@@ -54,25 +85,36 @@ newTypeVar = do
modify $ \s -> s { testNextTypeVar = idx + 1 }
return $ TypeVar $ T.pack $ 'a' : show idx
-lookupVarType :: Int -> VarName -> TestParser SomeExprType
+lookupVarType :: Int -> VarName -> TestParser ( FqVarName, SomeExprType )
lookupVarType off name = do
gets (lookup name . testVars) >>= \case
Nothing -> do
registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
"variable not in scope: `" <> textVarName name <> "'"
vtype <- ExprTypeVar <$> newTypeVar
- modify $ \s -> s { testVars = ( name, vtype ) : testVars s }
- return vtype
- Just t@(ExprTypeVar tvar) -> do
- gets (fromMaybe t . M.lookup tvar . testTypeUnif)
+ let fqName = LocalVarName name
+ modify $ \s -> s { testVars = ( name, ( fqName, vtype )) : testVars s }
+ return ( fqName, vtype )
+ Just ( fqName, t@(ExprTypeVar tvar) ) -> do
+ ( fqName, ) <$> gets (fromMaybe t . M.lookup tvar . testTypeUnif)
Just x -> return x
lookupVarExpr :: Int -> SourceLine -> VarName -> TestParser SomeExpr
lookupVarExpr off sline name = do
- lookupVarType off name >>= \case
- ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable sline name :: Expr a)
- ExprTypeVar tvar -> return $ SomeExpr $ DynVariable tvar sline name
- ExprTypeFunction args (_ :: Proxy a) -> return $ SomeExpr $ (FunVariable args sline name :: Expr (FunctionType a))
+ ( fqn, etype ) <- lookupVarType off name
+ case etype of
+ ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable sline fqn :: Expr a)
+ ExprTypeVar tvar -> return $ SomeExpr $ DynVariable tvar sline fqn
+ ExprTypeFunction args (_ :: Proxy a) -> return $ SomeExpr $ (FunVariable args sline fqn :: Expr (FunctionType a))
+
+lookupScalarVarExpr :: Int -> SourceLine -> VarName -> TestParser SomeExpr
+lookupScalarVarExpr off sline name = do
+ ( fqn, etype ) <- lookupVarType off name
+ case etype of
+ ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable sline fqn :: Expr a)
+ ExprTypeVar tvar -> return $ SomeExpr $ DynVariable tvar sline fqn
+ ExprTypeFunction args (pa :: Proxy a) -> do
+ SomeExpr <$> unifyExpr off pa (FunVariable args sline fqn :: Expr (FunctionType a))
unify :: Int -> SomeExprType -> SomeExprType -> TestParser SomeExprType
unify _ (ExprTypeVar aname) (ExprTypeVar bname) | aname == bname = do
@@ -204,7 +246,7 @@ localState inner = do
put s { testNextTypeVar = testNextTypeVar s', testTypeUnif = testTypeUnif s' }
return x
-toplevel :: (a -> Toplevel) -> TestParser a -> TestParser Toplevel
+toplevel :: (a -> b) -> TestParser a -> TestParser b
toplevel f = return . f <=< L.nonIndented scn
block :: (a -> [b] -> TestParser c) -> TestParser a -> TestParser b -> TestParser c
@@ -221,6 +263,18 @@ listOf item = do
x <- item
(x:) <$> choice [ symbol "," >> listOf item, return [] ]
+blockOf :: Monoid a => Pos -> TestParser a -> TestParser a
+blockOf indent step = go
+ where
+ go = do
+ scn
+ pos <- L.indentLevel
+ optional eof >>= \case
+ Just _ -> return mempty
+ _ | pos < indent -> return mempty
+ | pos == indent -> mappend <$> step <*> go
+ | otherwise -> L.incorrectIndent EQ indent pos
+
getSourceLine :: TestParser SourceLine
getSourceLine = do
@@ -230,3 +284,12 @@ getSourceLine = do
, T.pack ": "
, TL.toStrict $ TL.takeWhile (/='\n') $ pstateInput pstate
]
+
+
+getOrParseModule :: ModuleName -> TestParser Module
+getOrParseModule name = do
+ current <- gets testCurrentModuleName
+ parseModule <- gets testParseModule
+ (TestParser $ lift $ lift $ parseModule current name) >>= \case
+ Right parsed -> return parsed
+ Left err -> customFailure err
diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs
index 5ff3f15..b9b5f01 100644
--- a/src/Parser/Expr.hs
+++ b/src/Parser/Expr.hs
@@ -1,5 +1,6 @@
module Parser.Expr (
identifier,
+ parseModuleName,
varName,
newVarName,
@@ -10,6 +11,8 @@ module Parser.Expr (
literal,
variable,
+ stringExpansion,
+
checkFunctionArguments,
functionArguments,
) where
@@ -34,11 +37,10 @@ import Text.Megaparsec hiding (State)
import Text.Megaparsec.Char
import Text.Megaparsec.Char.Lexer qualified as L
import Text.Megaparsec.Error.Builder qualified as Err
-import Text.Regex.TDFA qualified as RE
-import Text.Regex.TDFA.Text qualified as RE
import Parser.Core
-import Test
+import Script.Expr
+import Script.Expr.Class
reservedWords :: [ Text ]
reservedWords =
@@ -58,6 +60,11 @@ identifier = label "identifier" $ do
]
return ident
+parseModuleName :: TestParser ModuleName
+parseModuleName = do
+ x <- identifier
+ ModuleName . (x :) <$> many (symbol "." >> identifier)
+
varName :: TestParser VarName
varName = label "variable name" $ VarName <$> identifier
@@ -74,7 +81,7 @@ addVarName off (TypedVarName name) = do
Just _ -> registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
T.pack "variable '" <> textVarName name <> T.pack "' already exists"
Nothing -> return ()
- modify $ \s -> s { testVars = ( name, ExprTypePrim @a Proxy ) : testVars s }
+ modify $ \s -> s { testVars = ( name, ( LocalVarName name, ExprTypePrim @a Proxy )) : testVars s }
someExpansion :: TestParser SomeExpr
someExpansion = do
@@ -83,12 +90,12 @@ someExpansion = do
[do off <- stateOffset <$> getParserState
sline <- getSourceLine
name <- VarName . TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_')
- lookupVarExpr off sline name
+ lookupScalarVarExpr off sline name
, between (char '{') (char '}') someExpr
]
-stringExpansion :: ExprType a => Text -> (forall b. ExprType b => Expr b -> [Maybe (Expr a)]) -> TestParser (Expr a)
-stringExpansion tname conv = do
+expressionExpansion :: forall a. ExprType a => Text -> TestParser (Expr a)
+expressionExpansion tname = do
off <- stateOffset <$> getParserState
SomeExpr e <- someExpansion
let err = do
@@ -96,7 +103,10 @@ stringExpansion tname conv = do
[ tname, T.pack " expansion not defined for '", textExprType e, T.pack "'" ]
return $ Undefined "expansion not defined for type"
- maybe err return $ listToMaybe $ catMaybes $ conv e
+ maybe err (return . (<$> e)) $ listToMaybe $ catMaybes [ cast (id :: a -> a), exprExpansionConvTo, exprExpansionConvFrom ]
+
+stringExpansion :: TestParser (Expr Text)
+stringExpansion = expressionExpansion "string"
numberLiteral :: TestParser SomeExpr
numberLiteral = label "number" $ lexeme $ do
@@ -108,6 +118,13 @@ numberLiteral = label "number" $ lexeme $ do
else return $ SomeExpr $ Pure x
]
+boolLiteral :: TestParser SomeExpr
+boolLiteral = label "bool" $ lexeme $ do
+ SomeExpr . Pure <$> choice
+ [ wsymbol "True" *> return True
+ , wsymbol "False" *> return False
+ ]
+
quotedString :: TestParser (Expr Text)
quotedString = label "string" $ lexeme $ do
void $ char '"'
@@ -124,11 +141,7 @@ quotedString = label "string" $ lexeme $ do
, char 't' >> return '\t'
]
(Pure (T.singleton c) :) <$> inner
- ,do e <- stringExpansion (T.pack "string") $ \e ->
- [ cast e
- , fmap (T.pack . show @Integer) <$> cast e
- , fmap (T.pack . show @Scientific) <$> cast e
- ]
+ ,do e <- stringExpansion
(e:) <$> inner
]
Concat <$> inner
@@ -146,19 +159,14 @@ regex = label "regular expression" $ lexeme $ do
, anySingle >>= \c -> return (Pure $ RegexPart $ T.pack ['\\', c])
]
(s:) <$> inner
- ,do e <- stringExpansion (T.pack "regex") $ \e ->
- [ cast e
- , fmap RegexString <$> cast e
- , fmap (RegexString . T.pack . show @Integer) <$> cast e
- , fmap (RegexString . T.pack . show @Scientific) <$> cast e
- ]
+ ,do e <- expressionExpansion (T.pack "regex")
(e:) <$> inner
]
parts <- inner
let testEval = \case
Pure (RegexPart p) -> p
_ -> ""
- case RE.compile RE.defaultCompOpt RE.defaultExecOpt $ T.concat $ map testEval parts of
+ case regexCompile $ T.concat $ map testEval parts of
Left err -> registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat
[ "failed to parse regular expression: ", T.pack err ]
Right _ -> return ()
@@ -260,11 +268,13 @@ someExpr = join inner <?> "expression"
[ SomeBinOp ((==) @Integer)
, SomeBinOp ((==) @Scientific)
, SomeBinOp ((==) @Text)
+ , SomeBinOp ((==) @Bool)
]
, binary' "/=" (\op xs ys -> length xs /= length ys || or (zipWith op xs ys)) $
[ SomeBinOp ((/=) @Integer)
, SomeBinOp ((/=) @Scientific)
, SomeBinOp ((/=) @Text)
+ , SomeBinOp ((/=) @Bool)
]
, binary ">" $
[ SomeBinOp ((>) @Integer)
@@ -346,6 +356,7 @@ typedExpr = do
literal :: TestParser SomeExpr
literal = label "literal" $ choice
[ numberLiteral
+ , boolLiteral
, SomeExpr <$> quotedString
, SomeExpr <$> regex
, list
@@ -385,18 +396,17 @@ recordSelector (SomeExpr expr) = do
checkFunctionArguments :: FunctionArguments SomeArgumentType
-> Int -> Maybe ArgumentKeyword -> SomeExpr -> TestParser SomeExpr
-checkFunctionArguments (FunctionArguments argTypes) poff kw expr = do
+checkFunctionArguments (FunctionArguments argTypes) poff kw sexpr@(SomeExpr expr) = do
case M.lookup kw argTypes of
Just (SomeArgumentType (_ :: ArgumentType expected)) -> do
- withRecovery registerParseError $ do
- void $ unify poff (ExprTypePrim (Proxy @expected)) (someExprType expr)
- return expr
+ withRecovery (\e -> registerParseError e >> return sexpr) $ do
+ SomeExpr <$> unifyExpr poff (Proxy @expected) expr
Nothing -> do
registerParseError $ FancyError poff $ S.singleton $ ErrorFail $ T.unpack $
case kw of
- Just (ArgumentKeyword tkw) -> "unexpected parameter with keyword `" <> tkw <> "'"
+ Just (ArgumentKeyword tkw) -> "unexpected parameter with keyword ‘" <> tkw <> "’"
Nothing -> "unexpected parameter"
- return expr
+ return sexpr
functionArguments :: (Int -> Maybe ArgumentKeyword -> a -> TestParser b) -> TestParser a -> TestParser a -> (Int -> Text -> TestParser a) -> TestParser (FunctionArguments b)
@@ -415,22 +425,10 @@ functionArguments check param lit promote = do
[ T.pack "multiple unnamed parameters" ]
parseArgs False
- ,do off <- stateOffset <$> getParserState
- x <- identifier
- choice
- [do off' <- stateOffset <$> getParserState
- y <- pparam <|> (promote off' =<< identifier)
- checkAndInsert off' (Just (ArgumentKeyword x)) y $ parseArgs allowUnnamed
-
- ,if allowUnnamed
- then do
- y <- promote off x
- checkAndInsert off Nothing y $ return M.empty
- else do
- registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat
- [ T.pack "multiple unnamed parameters" ]
- return M.empty
- ]
+ ,do x <- identifier
+ off <- stateOffset <$> getParserState
+ y <- pparam <|> (promote off =<< identifier)
+ checkAndInsert off (Just (ArgumentKeyword x)) y $ parseArgs allowUnnamed
,do return M.empty
]
diff --git a/src/Parser/Shell.hs b/src/Parser/Shell.hs
new file mode 100644
index 0000000..89595e8
--- /dev/null
+++ b/src/Parser/Shell.hs
@@ -0,0 +1,81 @@
+module Parser.Shell (
+ ShellScript,
+ shellScript,
+) where
+
+import Control.Applicative (liftA2)
+import Control.Monad
+
+import Data.Char
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Text.Lazy qualified as TL
+
+import Text.Megaparsec
+import Text.Megaparsec.Char
+import Text.Megaparsec.Char.Lexer qualified as L
+
+import Parser.Core
+import Parser.Expr
+import Script.Expr
+import Script.Shell
+
+parseArgument :: TestParser (Expr Text)
+parseArgument = lexeme $ fmap (App AnnNone (Pure T.concat) <$> foldr (liftA2 (:)) (Pure [])) $ some $ choice
+ [ doubleQuotedString
+ , singleQuotedString
+ , escapedChar
+ , stringExpansion
+ , unquotedString
+ ]
+ where
+ specialChars = [ '\"', '\\', '$' ]
+
+ unquotedString :: TestParser (Expr Text)
+ unquotedString = do
+ Pure . TL.toStrict <$> takeWhile1P Nothing (\c -> not (isSpace c) && c `notElem` specialChars)
+
+ doubleQuotedString :: TestParser (Expr Text)
+ doubleQuotedString = do
+ void $ char '"'
+ let inner = choice
+ [ char '"' >> return []
+ , (:) <$> (Pure . TL.toStrict <$> takeWhile1P Nothing (`notElem` specialChars)) <*> inner
+ , (:) <$> escapedChar <*> inner
+ , (:) <$> stringExpansion <*> inner
+ ]
+ App AnnNone (Pure T.concat) . foldr (liftA2 (:)) (Pure []) <$> inner
+
+ singleQuotedString :: TestParser (Expr Text)
+ singleQuotedString = do
+ Pure . TL.toStrict <$> (char '\'' *> takeWhileP Nothing (/= '\'') <* char '\'')
+
+ escapedChar :: TestParser (Expr Text)
+ escapedChar = do
+ void $ char '\\'
+ Pure <$> choice
+ [ char '\\' >> return "\\"
+ , char '"' >> return "\""
+ , char '$' >> return "$"
+ , char 'n' >> return "\n"
+ , char 'r' >> return "\r"
+ , char 't' >> return "\t"
+ ]
+
+parseArguments :: TestParser (Expr [ Text ])
+parseArguments = foldr (liftA2 (:)) (Pure []) <$> many parseArgument
+
+shellStatement :: TestParser (Expr [ ShellStatement ])
+shellStatement = label "shell statement" $ do
+ line <- getSourceLine
+ command <- parseArgument
+ args <- parseArguments
+ return $ fmap (: []) $ ShellStatement
+ <$> command
+ <*> args
+ <*> pure line
+
+shellScript :: TestParser (Expr ShellScript)
+shellScript = do
+ indent <- L.indentLevel
+ fmap ShellScript <$> blockOf indent shellStatement
diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs
index 4bed1ef..474fa03 100644
--- a/src/Parser/Statement.hs
+++ b/src/Parser/Statement.hs
@@ -1,5 +1,6 @@
module Parser.Statement (
testStep,
+ testBlock,
) where
import Control.Monad
@@ -21,11 +22,14 @@ import qualified Text.Megaparsec.Char.Lexer as L
import Network (Network, Node)
import Parser.Core
import Parser.Expr
+import Parser.Shell
import Process (Process)
+import Script.Expr
+import Script.Expr.Class
import Test
import Util
-letStatement :: TestParser (Expr TestBlock)
+letStatement :: TestParser (Expr (TestBlock ()))
letStatement = do
line <- getSourceLine
indent <- L.indentLevel
@@ -40,9 +44,9 @@ letStatement = do
addVarName off tname
void $ eol
body <- testBlock indent
- return $ Let line tname e body
+ return $ Let line tname e (TestBlockStep EmptyTestBlock . Scope <$> body)
-forStatement :: TestParser (Expr TestBlock)
+forStatement :: TestParser (Expr (TestBlock ()))
forStatement = do
ref <- L.indentLevel
wsymbol "for"
@@ -65,9 +69,54 @@ forStatement = do
body <- testBlock indent
return $ (\xs f -> mconcat $ map f xs)
<$> (unpack <$> e)
- <*> LambdaAbstraction tname body
+ <*> LambdaAbstraction tname (TestBlockStep EmptyTestBlock . Scope <$> body)
-exprStatement :: TestParser (Expr TestBlock)
+shellStatement :: TestParser (Expr (TestBlock ()))
+shellStatement = do
+ ref <- L.indentLevel
+ wsymbol "shell"
+ parseParams ref Nothing Nothing
+
+ where
+ parseParamKeyword kw prev = do
+ off <- stateOffset <$> getParserState
+ wsymbol kw
+ when (isJust prev) $ do
+ registerParseError $ FancyError off $ S.singleton $ ErrorFail $
+ "unexpected parameter with keyword ‘" <> kw <> "’"
+
+ parseParams ref mbpname mbnode = choice
+ [ do
+ parseParamKeyword "as" mbpname
+ pname <- newVarName
+ parseParams ref (Just pname) mbnode
+
+ , do
+ parseParamKeyword "on" mbnode
+ node <- typedExpr
+ parseParams ref mbpname (Just node)
+
+ , do
+ off <- stateOffset <$> getParserState
+ symbol ":"
+ node <- case mbnode of
+ Just node -> return node
+ Nothing -> do
+ registerParseError $ FancyError off $ S.singleton $ ErrorFail $
+ "missing parameter with keyword ‘on’"
+ return $ Undefined ""
+
+ void eol
+ void $ L.indentGuard scn GT ref
+ script <- shellScript
+ cont <- fmap Scope <$> testBlock ref
+ let expr | Just pname <- mbpname = LambdaAbstraction pname cont
+ | otherwise = const <$> cont
+ return $ TestBlockStep EmptyTestBlock <$>
+ (SpawnShell mbpname <$> node <*> script <*> expr)
+ ]
+
+exprStatement :: TestParser (Expr (TestBlock ()))
exprStatement = do
ref <- L.indentLevel
off <- stateOffset <$> getParserState
@@ -77,11 +126,11 @@ exprStatement = do
, unifyExpr off Proxy expr
]
where
- continuePartial :: ExprType a => Int -> Pos -> Expr a -> TestParser (Expr TestBlock)
+ continuePartial :: ExprType a => Int -> Pos -> Expr a -> TestParser (Expr (TestBlock ()))
continuePartial off ref expr = do
symbol ":"
void eol
- (fun :: Expr (FunctionType TestBlock)) <- unifyExpr off Proxy expr
+ (fun :: Expr (FunctionType (TestBlock ()))) <- unifyExpr off Proxy expr
scn
indent <- L.indentGuard scn GT ref
blockOf indent $ do
@@ -129,7 +178,7 @@ instance ExprType a => ParamType (TypedVarName a) where
instance ExprType a => ParamType (Expr a) where
parseParam _ = do
off <- stateOffset <$> getParserState
- SomeExpr e <- literal <|> variable <|> between (symbol "(") (symbol ")") someExpr
+ SomeExpr e <- literal <|> between (symbol "(") (symbol ")") someExpr
unifyExpr off Proxy e
showParamType _ = "<" ++ T.unpack (textExprType @a Proxy) ++ ">"
@@ -227,10 +276,10 @@ paramOrContext name = fromParamOrContext <$> param name
cmdLine :: CommandDef SourceLine
cmdLine = param ""
-newtype InnerBlock a = InnerBlock { fromInnerBlock :: [ a ] -> TestBlock }
+newtype InnerBlock a = InnerBlock { fromInnerBlock :: [ a ] -> TestBlock () }
instance ExprType a => ParamType (InnerBlock a) where
- type ParamRep (InnerBlock a) = ( [ TypedVarName a ], Expr TestBlock )
+ type ParamRep (InnerBlock a) = ( [ TypedVarName a ], Expr (TestBlock ()) )
parseParam _ = mzero
showParamType _ = "<code block>"
paramExpr ( vars, expr ) = fmap InnerBlock $ helper vars $ const <$> expr
@@ -242,14 +291,14 @@ instance ExprType a => ParamType (InnerBlock a) where
combine f (x : xs) = f x xs
combine _ [] = error "inner block parameter count mismatch"
-innerBlock :: CommandDef TestBlock
+innerBlock :: CommandDef (TestStep ())
innerBlock = ($ ([] :: [ Void ])) <$> innerBlockFun
-innerBlockFun :: ExprType a => CommandDef (a -> TestBlock)
+innerBlockFun :: ExprType a => CommandDef (a -> TestStep ())
innerBlockFun = (\f x -> f [ x ]) <$> innerBlockFunList
-innerBlockFunList :: ExprType a => CommandDef ([ a ] -> TestBlock)
-innerBlockFunList = fromInnerBlock <$> param ""
+innerBlockFunList :: ExprType a => CommandDef ([ a ] -> TestStep ())
+innerBlockFunList = (\ib -> Scope . fromInnerBlock ib) <$> param ""
newtype ExprParam a = ExprParam { fromExprParam :: a }
deriving (Functor, Foldable, Traversable)
@@ -263,7 +312,7 @@ instance ExprType a => ParamType (ExprParam a) where
showParamType _ = "<" ++ T.unpack (textExprType @a Proxy) ++ ">"
paramExpr = fmap ExprParam
-command :: String -> CommandDef TestStep -> TestParser (Expr TestBlock)
+command :: String -> CommandDef (TestStep ()) -> TestParser (Expr (TestBlock ()))
command name (CommandDef types ctor) = do
indent <- L.indentLevel
line <- getSourceLine
@@ -271,7 +320,7 @@ command name (CommandDef types ctor) = do
localState $ do
restOfLine indent [] line $ map (fmap $ \(SomeParam p@(_ :: Proxy p) Proxy) -> SomeParam p $ Nothing @(ParamRep p)) types
where
- restOfLine :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> SourceLine -> [(String, SomeParam Maybe)] -> TestParser (Expr TestBlock)
+ restOfLine :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> SourceLine -> [(String, SomeParam Maybe)] -> TestParser (Expr (TestBlock ()))
restOfLine cmdi partials line params = choice
[do void $ lookAhead eol
let definedVariables = mconcat $ map (someParamVars . snd) params
@@ -288,7 +337,7 @@ command name (CommandDef types ctor) = do
, fail $ "missing " ++ (if null sym then "" else "'" ++ sym ++ "' ") ++ showParamType p
]
(_, SomeParam (p :: Proxy p) (Just x)) -> return $ SomeParam p $ Identity x
- return $ (TestBlock . (: [])) <$> ctor iparams
+ return $ (TestBlockStep EmptyTestBlock) <$> ctor iparams
,do symbol ":"
scn
@@ -298,7 +347,7 @@ command name (CommandDef types ctor) = do
,do tryParams cmdi partials line [] params
]
- restOfParts :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> TestParser (Expr TestBlock)
+ restOfParts :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> TestParser (Expr (TestBlock ()))
restOfParts cmdi [] = testBlock cmdi
restOfParts cmdi partials@((partIndent, params) : rest) = do
scn
@@ -324,7 +373,7 @@ command name (CommandDef types ctor) = do
]
tryParams _ _ _ _ [] = mzero
-testLocal :: TestParser (Expr TestBlock)
+testLocal :: TestParser (Expr (TestBlock ()))
testLocal = do
ref <- L.indentLevel
wsymbol "local"
@@ -332,9 +381,10 @@ testLocal = do
void $ eol
indent <- L.indentGuard scn GT ref
- localState $ testBlock indent
+ localState $ do
+ fmap (TestBlockStep EmptyTestBlock . Scope) <$> testBlock indent
-testWith :: TestParser (Expr TestBlock)
+testWith :: TestParser (Expr (TestBlock ()))
testWith = do
ref <- L.indentLevel
wsymbol "with"
@@ -358,27 +408,28 @@ testWith = do
indent <- L.indentGuard scn GT ref
localState $ do
modify $ \s -> s { testContext = ctx }
- testBlock indent
+ fmap (TestBlockStep EmptyTestBlock . Scope) <$> testBlock indent
-testSubnet :: TestParser (Expr TestBlock)
+testSubnet :: TestParser (Expr (TestBlock ()))
testSubnet = command "subnet" $ Subnet
<$> param ""
<*> (fromExprParam <$> paramOrContext "of")
<*> innerBlockFun
-testNode :: TestParser (Expr TestBlock)
+testNode :: TestParser (Expr (TestBlock ()))
testNode = command "node" $ DeclNode
<$> param ""
<*> (fromExprParam <$> paramOrContext "on")
<*> innerBlockFun
-testSpawn :: TestParser (Expr TestBlock)
+testSpawn :: TestParser (Expr (TestBlock ()))
testSpawn = command "spawn" $ Spawn
<$> param "as"
<*> (bimap fromExprParam fromExprParam <$> paramOrContext "on")
+ <*> (maybe [] fromExprParam <$> param "args")
<*> innerBlockFun
-testExpect :: TestParser (Expr TestBlock)
+testExpect :: TestParser (Expr (TestBlock ()))
testExpect = command "expect" $ Expect
<$> cmdLine
<*> (fromExprParam <$> paramOrContext "from")
@@ -386,47 +437,36 @@ testExpect = command "expect" $ Expect
<*> param "capture"
<*> innerBlockFunList
-testDisconnectNode :: TestParser (Expr TestBlock)
+testDisconnectNode :: TestParser (Expr (TestBlock ()))
testDisconnectNode = command "disconnect_node" $ DisconnectNode
<$> (fromExprParam <$> paramOrContext "")
<*> innerBlock
-testDisconnectNodes :: TestParser (Expr TestBlock)
+testDisconnectNodes :: TestParser (Expr (TestBlock ()))
testDisconnectNodes = command "disconnect_nodes" $ DisconnectNodes
<$> (fromExprParam <$> paramOrContext "")
<*> innerBlock
-testDisconnectUpstream :: TestParser (Expr TestBlock)
+testDisconnectUpstream :: TestParser (Expr (TestBlock ()))
testDisconnectUpstream = command "disconnect_upstream" $ DisconnectUpstream
<$> (fromExprParam <$> paramOrContext "")
<*> innerBlock
-testPacketLoss :: TestParser (Expr TestBlock)
+testPacketLoss :: TestParser (Expr (TestBlock ()))
testPacketLoss = command "packet_loss" $ PacketLoss
<$> (fromExprParam <$> paramOrContext "")
<*> (fromExprParam <$> paramOrContext "on")
<*> innerBlock
-testBlock :: Pos -> TestParser (Expr TestBlock)
+testBlock :: Pos -> TestParser (Expr (TestBlock ()))
testBlock indent = blockOf indent testStep
-blockOf :: Monoid a => Pos -> TestParser a -> TestParser a
-blockOf indent step = go
- where
- go = do
- scn
- pos <- L.indentLevel
- optional eof >>= \case
- Just _ -> return mempty
- _ | pos < indent -> return mempty
- | pos == indent -> mappend <$> step <*> go
- | otherwise -> L.incorrectIndent EQ indent pos
-
-testStep :: TestParser (Expr TestBlock)
+testStep :: TestParser (Expr (TestBlock ()))
testStep = choice
[ letStatement
, forStatement
+ , shellStatement
, testLocal
, testWith
, testSubnet
diff --git a/src/Process.hs b/src/Process.hs
index 376b1ba..31641c9 100644
--- a/src/Process.hs
+++ b/src/Process.hs
@@ -7,6 +7,7 @@ module Process (
lineReadingLoop,
spawnOn,
closeProcess,
+ closeTestProcess,
withProcess,
) where
@@ -18,11 +19,15 @@ import Control.Monad.Except
import Control.Monad.Reader
import Data.Function
+import Data.Scientific
import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Text.IO as T
+import Data.Text qualified as T
+import Data.Text.IO qualified as T
+import System.Directory
+import System.Environment
import System.Exit
+import System.FilePath
import System.IO
import System.IO.Error
import System.Posix.Signals
@@ -33,11 +38,11 @@ import Network
import Network.Ip
import Output
import Run.Monad
-import Test
+import Script.Expr.Class
data Process = Process
{ procName :: ProcName
- , procHandle :: ProcessHandle
+ , procHandle :: Either ProcessHandle ( ThreadId, MVar ExitCode )
, procStdin :: Handle
, procOutput :: TVar [Text]
, procKillWith :: Maybe Signal
@@ -89,28 +94,40 @@ lineReadingLoop process h act =
spawnOn :: Either Network Node -> ProcName -> Maybe Signal -> String -> TestRun Process
spawnOn target pname killWith cmd = do
+ -- When executing command given with relative path, turn it to absolute one,
+ -- because working directory will be changed for the shell wrapper.
+ cmd' <- liftIO $ do
+ case span (/= ' ') cmd of
+ ( path, rest )
+ | any isPathSeparator path && isRelative path
+ -> do
+ path' <- makeAbsolute path
+ return (path' ++ rest)
+ _ -> return cmd
+
let netns = either getNetns getNetns target
- let prefix = T.unpack $ "ip netns exec \"" <> textNetnsName netns <> "\" "
- (Just hin, Just hout, Just herr, handle) <- liftIO $ createProcess (shell $ prefix ++ cmd)
- { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe
- , cwd = Just (either netDir nodeDir target)
- , env = Just [ ( "EREBOS_DIR", "." ) ]
- }
+ currentEnv <- liftIO $ getEnvironment
+ (Just hin, Just hout, Just herr, handle) <- liftIO $ do
+ runInNetworkNamespace netns $ createProcess (shell cmd')
+ { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe
+ , cwd = Just (either netDir nodeDir target)
+ , env = Just $ ( "EREBOS_DIR", "." ) : currentEnv
+ }
pout <- liftIO $ newTVarIO []
let process = Process
{ procName = pname
- , procHandle = handle
+ , procHandle = Left handle
, procStdin = hin
, procOutput = pout
, procKillWith = killWith
, procNode = either (const undefined) id target
}
- forkTest $ lineReadingLoop process hout $ \line -> do
+ void $ forkTest $ lineReadingLoop process hout $ \line -> do
outProc OutputChildStdout process line
liftIO $ atomically $ modifyTVar pout (++[line])
- forkTest $ lineReadingLoop process herr $ \line -> do
+ void $ forkTest $ lineReadingLoop process herr $ \line -> do
case pname of
ProcNameTcpdump -> return ()
_ -> outProc OutputChildStderr process line
@@ -121,24 +138,29 @@ spawnOn target pname killWith cmd = do
return process
-closeProcess :: (MonadIO m, MonadOutput m, MonadError Failed m) => Process -> m ()
-closeProcess p = do
+closeProcess :: (MonadIO m, MonadOutput m, MonadError Failed m) => Scientific -> Process -> m ()
+closeProcess timeout p = do
liftIO $ hClose $ procStdin p
case procKillWith p of
Nothing -> return ()
- Just sig -> liftIO $ getPid (procHandle p) >>= \case
+ Just sig -> liftIO $ either getPid (\_ -> return Nothing) (procHandle p) >>= \case
Nothing -> return ()
Just pid -> signalProcess sig pid
liftIO $ void $ forkIO $ do
- threadDelay 1000000
- terminateProcess $ procHandle p
- liftIO (waitForProcess (procHandle p)) >>= \case
+ threadDelay $ floor $ 1000000 * timeout
+ either terminateProcess (killThread . fst) $ procHandle p
+ liftIO (either waitForProcess (takeMVar . snd) (procHandle p)) >>= \case
ExitSuccess -> return ()
ExitFailure code -> do
outProc OutputChildFail p $ T.pack $ "exit code: " ++ show code
throwError Failed
+closeTestProcess :: Process -> TestRun ()
+closeTestProcess process = do
+ timeout <- liftIO . readMVar =<< asks (teTimeout . fst)
+ closeProcess timeout process
+
withProcess :: Either Network Node -> ProcName -> Maybe Signal -> String -> (Process -> TestRun a) -> TestRun a
withProcess target pname killWith cmd inner = do
procVar <- asks $ teProcesses . fst
@@ -148,5 +170,5 @@ withProcess target pname killWith cmd inner = do
inner process `finally` do
ps <- liftIO $ takeMVar procVar
- closeProcess process `finally` do
+ closeTestProcess process `finally` do
liftIO $ putMVar procVar $ filter (/=process) ps
diff --git a/src/Run.hs b/src/Run.hs
index 001d887..d5b0d29 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -1,6 +1,8 @@
module Run (
module Run.Monad,
runTest,
+ loadModules,
+ evalGlobalDefs,
) where
import Control.Applicative
@@ -8,14 +10,18 @@ import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad
import Control.Monad.Except
+import Control.Monad.Fix
import Control.Monad.Reader
+import Control.Monad.Writer
+import Data.Bifunctor
import Data.Map qualified as M
import Data.Maybe
-import Data.Set qualified as S
+import Data.Proxy
import Data.Scientific
+import Data.Set qualified as S
import Data.Text (Text)
-import qualified Data.Text as T
+import Data.Text qualified as T
import System.Directory
import System.Exit
@@ -24,17 +30,25 @@ import System.Posix.Process
import System.Posix.Signals
import System.Process
+import Text.Megaparsec (errorBundlePretty, showErrorComponent)
+
import GDB
import Network
import Network.Ip
import Output
+import Parser
import Process
import Run.Monad
+import Script.Expr
+import Script.Module
+import Script.Object
+import Script.Shell
import Test
import Test.Builtins
-runTest :: Output -> TestOptions -> Test -> [ ( VarName, SomeExpr ) ] -> IO Bool
-runTest out opts test variables = do
+
+runTest :: Output -> TestOptions -> GlobalDefs -> Test -> IO Bool
+runTest out opts gdefs test = do
let testDir = optTestDir opts
when (optForce opts) $ removeDirectoryRecursive testDir `catchIOError` \e ->
if isDoesNotExistError e then return () else ioError e
@@ -43,7 +57,9 @@ runTest out opts test variables = do
createDirectoryIfMissing True testDir
failedVar <- newTVarIO Nothing
+ objIdVar <- newMVar 1
procVar <- newMVar []
+ timeoutVar <- newMVar $ optTimeout opts
mgdb <- if optGDB opts
then flip runReaderT out $ do
@@ -55,11 +71,14 @@ runTest out opts test variables = do
{ teOutput = out
, teFailed = failedVar
, teOptions = opts
+ , teNextObjId = objIdVar
, teProcesses = procVar
+ , teTimeout = timeoutVar
, teGDB = fst <$> mgdb
}
tstate = TestState
- { tsVars = builtins
+ { tsGlobals = gdefs
+ , tsLocals = []
, tsNodePacketLoss = M.empty
, tsDisconnectedUp = S.empty
, tsDisconnectedBridge = S.empty
@@ -68,7 +87,7 @@ runTest out opts test variables = do
let sigHandler SignalInfo { siginfoSpecific = chld } = do
processes <- readMVar procVar
forM_ processes $ \p -> do
- mbpid <- getPid (procHandle p)
+ mbpid <- either getPid (\_ -> return Nothing) (procHandle p)
when (mbpid == Just (siginfoPid chld)) $ flip runReaderT out $ do
let err detail = outProc OutputChildFail p detail
case siginfoStatus chld of
@@ -82,23 +101,17 @@ runTest out opts test variables = do
Stopped sig -> err $ T.pack $ "child stopped with signal " ++ show sig
oldHandler <- installHandler processStatusChanged (CatchInfo sigHandler) Nothing
- let withVarExprList (( name, expr ) : rest) act = do
- value <- evalSome expr
- local (fmap $ \s -> s { tsVars = ( name, value ) : tsVars s }) $ do
- withVarExprList rest act
- withVarExprList [] act = act
-
- res <- runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do
- withVarExprList variables $ do
- withInternet $ \_ -> do
- evalBlock =<< eval (testSteps test)
- when (optWait opts) $ do
- void $ outPromptGetLine $ "Test '" <> testName test <> "' completed, waiting..."
+ resetOutputTime out
+ ( res, [] ) <- runWriterT $ runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do
+ withInternet $ \_ -> do
+ runStep =<< eval (testSteps test)
+ when (optWait opts) $ do
+ void $ outPromptGetLine $ "Test '" <> testName test <> "' completed, waiting..."
void $ installHandler processStatusChanged oldHandler Nothing
Right () <- runExceptT $ flip runReaderT out $ do
- maybe (return ()) (closeProcess . snd) mgdb
+ maybe (return ()) (closeProcess 1 . snd) mgdb
[] <- readMVar procVar
failed <- atomically $ readTVar (teFailed tenv)
@@ -106,17 +119,56 @@ runTest out opts test variables = do
(Right (), Nothing) -> do
when (not $ optKeep opts) $ removeDirectoryRecursive testDir
return True
- _ -> return False
+ _ -> do
+ flip runReaderT out $ do
+ void $ outLine OutputError Nothing $ "Test ‘" <> testName test <> "’ failed."
+ return False
+
+
+loadModules :: [ FilePath ] -> IO ( [ Module ], GlobalDefs )
+loadModules files = do
+ ( modules, allModules ) <- parseTestFiles files >>= \case
+ Right res -> do
+ return res
+ Left err -> do
+ case err of
+ ImportModuleError bundle ->
+ putStr (errorBundlePretty bundle)
+ _ -> do
+ putStrLn (showErrorComponent err)
+ exitFailure
+ let globalDefs = evalGlobalDefs $ concatMap (\m -> map (first ( moduleName m, )) $ moduleDefinitions m) allModules
+ return ( modules, globalDefs )
+
+
+evalGlobalDefs :: [ (( ModuleName, VarName ), SomeExpr ) ] -> GlobalDefs
+evalGlobalDefs exprs = fix $ \gdefs ->
+ builtins `M.union` M.fromList (map (fmap (evalSomeWith gdefs)) exprs)
+
+runBlock :: TestBlock () -> TestRun ()
+runBlock EmptyTestBlock = return ()
+runBlock (TestBlockStep prev step) = runBlock prev >> runStep step
+
+runStep :: TestStep () -> TestRun ()
+runStep = \case
+ Scope block -> do
+ ( x, objs ) <- censor (const []) $ listen $ catchError (Right <$> runBlock block) (return . Left)
+ mapM_ destroySomeObject (reverse objs)
+ either throwError return x
+
+ CreateObject (Proxy :: Proxy o) cargs -> do
+ objIdVar <- asks (teNextObjId . fst)
+ oid <- liftIO $ modifyMVar objIdVar (\x -> return ( x + 1, x ))
+ obj <- createObject @TestRun @o (ObjectId oid) cargs
+ tell [ toSomeObject obj ]
-evalBlock :: TestBlock -> TestRun ()
-evalBlock (TestBlock steps) = forM_ steps $ \case
Subnet name parent inner -> do
- withSubnet parent (Just name) $ evalBlock . inner
+ withSubnet parent (Just name) $ runStep . inner
DeclNode name net inner -> do
- withNode net (Left name) $ evalBlock . inner
+ withNode net (Left name) $ runStep . inner
- Spawn tvname@(TypedVarName (VarName tname)) target inner -> do
+ Spawn tvname@(TypedVarName (VarName tname)) target args inner -> do
case target of
Left net -> withNode net (Right tvname) go
Right node -> go node
@@ -125,14 +177,22 @@ evalBlock (TestBlock steps) = forM_ steps $ \case
opts <- asks $ teOptions . fst
let pname = ProcName tname
tool = fromMaybe (optDefaultTool opts) (lookup pname $ optProcTools opts)
- withProcess (Right node) pname Nothing tool $ evalBlock . inner
+ cmd = unwords $ tool : map (T.unpack . escape) args
+ escape = ("'" <>) . (<> "'") . T.replace "'" "'\\''"
+ withProcess (Right node) pname Nothing cmd $ runStep . inner
+
+ SpawnShell mbname node script inner -> do
+ let tname | Just (TypedVarName (VarName name)) <- mbname = name
+ | otherwise = "shell"
+ let pname = ProcName tname
+ withShellProcess node pname script $ runStep . inner
Send p line -> do
outProc OutputChildStdin p line
send p line
Expect line p expr captures inner -> do
- expect line p expr captures $ evalBlock . inner
+ expect line p expr captures $ runStep . inner
Flush p regex -> do
flush p regex
@@ -141,18 +201,18 @@ evalBlock (TestBlock steps) = forM_ steps $ \case
testStepGuard line vars expr
DisconnectNode node inner -> do
- withDisconnectedUp (nodeUpstream node) $ evalBlock inner
+ withDisconnectedUp (nodeUpstream node) $ runStep inner
DisconnectNodes net inner -> do
- withDisconnectedBridge (netBridge net) $ evalBlock inner
+ withDisconnectedBridge (netBridge net) $ runStep inner
DisconnectUpstream net inner -> do
case netUpstream net of
- Just link -> withDisconnectedUp link $ evalBlock inner
- Nothing -> evalBlock inner
+ Just link -> withDisconnectedUp link $ runStep inner
+ Nothing -> runStep inner
PacketLoss loss node inner -> do
- withNodePacketLoss node loss $ evalBlock inner
+ withNodePacketLoss node loss $ runStep inner
Wait -> do
void $ outPromptGetLine "Waiting..."
@@ -248,14 +308,14 @@ exprFailed desc sline pname exprVars = do
outLine OutputMatchFail (Just prompt) $ T.concat [desc, T.pack " failed on ", textSourceLine sline]
forM_ exprVars $ \((name, sel), value) ->
outLine OutputMatchFail (Just prompt) $ T.concat
- [ " ", textVarName name, T.concat (map ("."<>) sel)
+ [ " ", textFqVarName name, T.concat (map ("."<>) sel)
, " = ", textSomeVarValue sline value
]
throwError Failed
expect :: SourceLine -> Process -> Traced Regex -> [TypedVarName Text] -> ([ Text ] -> TestRun ()) -> TestRun ()
expect sline p (Traced trace re) tvars inner = do
- timeout <- asks $ optTimeout . teOptions . fst
+ timeout <- liftIO . readMVar =<< asks (teTimeout . fst)
delay <- liftIO $ registerDelay $ ceiling $ 1000000 * timeout
mbmatch <- atomicallyTest $ (Nothing <$ (check =<< readTVar delay)) <|> do
line <- readTVar (procOutput p)
@@ -272,12 +332,6 @@ expect sline p (Traced trace re) tvars inner = do
outProc OutputMatchFail p $ T.pack "mismatched number of capture variables on " `T.append` textSourceLine sline
throwError Failed
- forM_ vars $ \name -> do
- cur <- asks (lookup name . tsVars . snd)
- when (isJust cur) $ do
- outProc OutputError p $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` textSourceLine sline
- throwError Failed
-
outProc OutputMatch p line
inner capture
diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs
index 3739e2e..f681e99 100644
--- a/src/Run/Monad.hs
+++ b/src/Run/Monad.hs
@@ -7,6 +7,7 @@ module Run.Monad (
finally,
forkTest,
+ forkTestUsing,
) where
import Control.Concurrent
@@ -14,31 +15,41 @@ import Control.Concurrent.STM
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
+import Control.Monad.Writer
import Data.Map (Map)
-import Data.Set (Set)
import Data.Scientific
-import qualified Data.Text as T
+import Data.Set (Set)
+import Data.Text qualified as T
import {-# SOURCE #-} GDB
import Network.Ip
import Output
import {-# SOURCE #-} Process
-import Test
+import Script.Expr
+import Script.Object
-newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT Failed IO) a }
- deriving (Functor, Applicative, Monad, MonadReader (TestEnv, TestState), MonadIO)
+newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT Failed (WriterT [ SomeObject TestRun ] IO)) a }
+ deriving
+ ( Functor, Applicative, Monad
+ , MonadReader ( TestEnv, TestState )
+ , MonadWriter [ SomeObject TestRun ]
+ , MonadIO
+ )
data TestEnv = TestEnv
{ teOutput :: Output
, teFailed :: TVar (Maybe Failed)
, teOptions :: TestOptions
- , teProcesses :: MVar [Process]
+ , teNextObjId :: MVar Int
+ , teProcesses :: MVar [ Process ]
+ , teTimeout :: MVar Scientific
, teGDB :: Maybe (MVar GDB)
}
data TestState = TestState
- { tsVars :: [(VarName, SomeVarValue)]
+ { tsGlobals :: GlobalDefs
+ , tsLocals :: [ ( VarName, SomeVarValue ) ]
, tsDisconnectedUp :: Set NetworkNamespace
, tsDisconnectedBridge :: Set NetworkNamespace
, tsNodePacketLoss :: Map NetworkNamespace Scientific
@@ -91,8 +102,9 @@ instance MonadError Failed TestRun where
catchError (TestRun act) handler = TestRun $ catchError act $ fromTestRun . handler
instance MonadEval TestRun where
- askDictionary = asks (tsVars . snd)
- withDictionary f = local (fmap $ \s -> s { tsVars = f (tsVars s) })
+ askGlobalDefs = asks (tsGlobals . snd)
+ askDictionary = asks (tsLocals . snd)
+ withDictionary f = local (fmap $ \s -> s { tsLocals = f (tsLocals s) })
instance MonadOutput TestRun where
getOutput = asks $ teOutput . fst
@@ -107,10 +119,14 @@ finally act handler = do
void handler
return x
-forkTest :: TestRun () -> TestRun ()
-forkTest act = do
+forkTest :: TestRun () -> TestRun ThreadId
+forkTest = forkTestUsing forkIO
+
+forkTestUsing :: (IO () -> IO ThreadId) -> TestRun () -> TestRun ThreadId
+forkTestUsing fork act = do
tenv <- ask
- void $ liftIO $ forkIO $ do
- runExceptT (flip runReaderT tenv $ fromTestRun act) >>= \case
+ liftIO $ fork $ do
+ ( res, [] ) <- runWriterT (runExceptT $ flip runReaderT tenv $ fromTestRun act)
+ case res of
Left e -> atomically $ writeTVar (teFailed $ fst tenv) (Just e)
Right () -> return ()
diff --git a/src/Script/Expr.hs b/src/Script/Expr.hs
new file mode 100644
index 0000000..ced807c
--- /dev/null
+++ b/src/Script/Expr.hs
@@ -0,0 +1,452 @@
+module Script.Expr (
+ Expr(..), varExpr, mapExpr,
+
+ MonadEval(..), VariableDictionary, GlobalDefs,
+ lookupVar, tryLookupVar, withVar, withTypedVar,
+ eval, evalSome, evalSomeWith,
+
+ FunctionType, DynamicType,
+ ExprType(..), SomeExpr(..),
+ TypeVar(..), SomeExprType(..), someExprType, textSomeExprType,
+
+ VarValue(..), SomeVarValue(..),
+ svvVariables, svvArguments,
+ someConstValue, fromConstValue,
+ fromSomeVarValue, textSomeVarValue, someVarValueType,
+
+ ArgumentKeyword(..), FunctionArguments(..),
+ anull, exprArgs,
+ SomeArgumentType(..), ArgumentType(..),
+
+ Traced(..), EvalTrace, VarNameSelectors, gatherVars,
+ AppAnnotation(..),
+
+ module Script.Var,
+
+ Regex(RegexPart, RegexString),
+ regexCompile, regexMatch,
+) where
+
+import Control.Monad
+import Control.Monad.Reader
+
+import Data.Char
+import Data.Foldable
+import Data.List
+import Data.Map (Map)
+import Data.Map qualified as M
+import Data.Maybe
+import Data.Scientific
+import Data.String
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Typeable
+
+import Text.Regex.TDFA qualified as RE
+import Text.Regex.TDFA.Text qualified as RE
+
+import Script.Expr.Class
+import Script.Var
+import Util
+
+
+data Expr a where
+ Let :: forall a b. ExprType b => SourceLine -> TypedVarName b -> Expr b -> Expr a -> Expr a
+ Variable :: ExprType a => SourceLine -> FqVarName -> Expr a
+ DynVariable :: TypeVar -> SourceLine -> FqVarName -> Expr DynamicType
+ FunVariable :: ExprType a => FunctionArguments SomeArgumentType -> SourceLine -> FqVarName -> Expr (FunctionType a)
+ ArgsReq :: ExprType a => FunctionArguments ( VarName, SomeArgumentType ) -> Expr (FunctionType a) -> Expr (FunctionType a)
+ ArgsApp :: ExprType a => FunctionArguments SomeExpr -> Expr (FunctionType a) -> Expr (FunctionType a)
+ FunctionAbstraction :: ExprType a => Expr a -> Expr (FunctionType a)
+ FunctionEval :: ExprType a => Expr (FunctionType a) -> Expr a
+ LambdaAbstraction :: ExprType a => TypedVarName a -> Expr b -> Expr (a -> b)
+ Pure :: a -> Expr a
+ App :: AppAnnotation b -> Expr (a -> b) -> Expr a -> Expr b
+ Concat :: [ Expr Text ] -> Expr Text
+ Regex :: [ Expr Regex ] -> Expr Regex
+ Undefined :: String -> Expr a
+ Trace :: Expr a -> Expr (Traced a)
+
+data AppAnnotation b = AnnNone
+ | ExprType b => AnnRecord Text
+
+instance Functor Expr where
+ fmap f x = Pure f <*> x
+
+instance Applicative Expr where
+ pure = Pure
+ (<*>) = App AnnNone
+
+instance Semigroup a => Semigroup (Expr a) where
+ e <> f = (<>) <$> e <*> f
+
+instance Monoid a => Monoid (Expr a) where
+ mempty = Pure mempty
+
+varExpr :: ExprType a => SourceLine -> TypedVarName a -> Expr a
+varExpr sline (TypedVarName name) = Variable sline (LocalVarName name)
+
+mapExpr :: forall a. (forall b. Expr b -> Expr b) -> Expr a -> Expr a
+mapExpr f = go
+ where
+ go :: forall c. Expr c -> Expr c
+ go = \case
+ Let sline vname vval expr -> f $ Let sline vname (go vval) (go expr)
+ e@Variable {} -> f e
+ e@DynVariable {} -> f e
+ e@FunVariable {} -> f e
+ ArgsReq args expr -> f $ ArgsReq args (go expr)
+ ArgsApp args expr -> f $ ArgsApp (fmap (\(SomeExpr e) -> SomeExpr (go e)) args) (go expr)
+ FunctionAbstraction expr -> f $ FunctionAbstraction (go expr)
+ FunctionEval expr -> f $ FunctionEval (go expr)
+ LambdaAbstraction tvar expr -> f $ LambdaAbstraction tvar (go expr)
+ e@Pure {} -> f e
+ App ann efun earg -> f $ App ann (go efun) (go earg)
+ e@Concat {} -> f e
+ e@Regex {} -> f e
+ e@Undefined {} -> f e
+ Trace expr -> f $ Trace (go expr)
+
+
+
+class MonadFail m => MonadEval m where
+ askGlobalDefs :: m GlobalDefs
+ askDictionary :: m VariableDictionary
+ withDictionary :: (VariableDictionary -> VariableDictionary) -> m a -> m a
+
+type GlobalDefs = Map ( ModuleName, VarName ) SomeVarValue
+
+type VariableDictionary = [ ( VarName, SomeVarValue ) ]
+
+lookupVar :: MonadEval m => FqVarName -> m SomeVarValue
+lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackFqVarName name ++ "'") return =<< tryLookupVar name
+
+tryLookupVar :: MonadEval m => FqVarName -> m (Maybe SomeVarValue)
+tryLookupVar (LocalVarName name) = lookup name <$> askDictionary
+tryLookupVar (GlobalVarName mname var) = M.lookup ( mname, var ) <$> askGlobalDefs
+
+withVar :: (MonadEval m, ExprType e) => VarName -> e -> m a -> m a
+withVar name value = withDictionary (( name, someConstValue value ) : )
+
+withTypedVar :: (MonadEval m, ExprType e) => TypedVarName e -> e -> m a -> m a
+withTypedVar (TypedVarName name) = withVar name
+
+isInternalVar :: FqVarName -> Bool
+isInternalVar (GlobalVarName {}) = False
+isInternalVar (LocalVarName (VarName name))
+ | Just ( '$', _ ) <- T.uncons name = True
+ | otherwise = False
+
+
+newtype SimpleEval a = SimpleEval (Reader ( GlobalDefs, VariableDictionary ) a)
+ deriving (Functor, Applicative, Monad)
+
+runSimpleEval :: SimpleEval a -> GlobalDefs -> VariableDictionary -> a
+runSimpleEval (SimpleEval x) = curry $ runReader x
+
+instance MonadFail SimpleEval where
+ fail = error . ("eval failed: " <>)
+
+instance MonadEval SimpleEval where
+ askGlobalDefs = SimpleEval (asks fst)
+ askDictionary = SimpleEval (asks snd)
+ withDictionary f (SimpleEval inner) = SimpleEval (local (fmap f) inner)
+
+eval :: forall m a. MonadEval m => Expr a -> m a
+eval = \case
+ Let _ (TypedVarName name) valExpr expr -> do
+ val <- eval valExpr
+ withVar name val $ eval expr
+ Variable sline name -> fromSomeVarValue sline name =<< lookupVar name
+ DynVariable _ _ name -> fail $ "ambiguous type of ‘" <> unpackFqVarName name <> "’"
+ FunVariable _ sline name -> funFromSomeVarValue sline name =<< lookupVar name
+ ArgsReq (FunctionArguments req) efun -> do
+ gdefs <- askGlobalDefs
+ dict <- askDictionary
+ return $ FunctionType $ \(FunctionArguments args) ->
+ let used = M.intersectionWith (\value ( vname, _ ) -> ( vname, value )) args req
+ FunctionType fun = runSimpleEval (eval efun) gdefs (toList used ++ dict)
+ in fun $ FunctionArguments $ args `M.difference` req
+ ArgsApp eargs efun -> do
+ FunctionType fun <- eval efun
+ args <- mapM evalSome eargs
+ return $ FunctionType $ \args' -> fun (args <> args')
+ FunctionAbstraction expr -> do
+ val <- eval expr
+ return $ FunctionType $ const val
+ FunctionEval efun -> do
+ FunctionType fun <- eval efun
+ return $ fun mempty
+ LambdaAbstraction (TypedVarName name) expr -> do
+ gdefs <- askGlobalDefs
+ dict <- askDictionary
+ return $ \x -> runSimpleEval (eval expr) gdefs (( name, someConstValue x ) : dict)
+ Pure value -> return value
+ App _ f x -> eval f <*> eval x
+ Concat xs -> T.concat <$> mapM eval xs
+ Regex xs -> mapM eval xs >>= \case
+ [ re@RegexCompiled {} ] -> return re
+ parts -> case regexCompile $ T.concat $ map regexSource parts of
+ Left err -> fail err
+ Right re -> return re
+ Undefined err -> fail err
+ Trace expr -> Traced <$> gatherVars expr <*> eval expr
+
+evalToVarValue :: MonadEval m => Expr a -> m (VarValue a)
+evalToVarValue expr = do
+ VarValue
+ <$> gatherVars expr
+ <*> pure mempty
+ <*> (const . const <$> eval expr)
+
+evalFunToVarValue :: MonadEval m => Expr (FunctionType a) -> m (VarValue a)
+evalFunToVarValue expr = do
+ FunctionType fun <- eval expr
+ VarValue
+ <$> gatherVars expr
+ <*> pure (exprArgs expr)
+ <*> pure (const fun)
+
+evalSome :: MonadEval m => SomeExpr -> m SomeVarValue
+evalSome (SomeExpr expr)
+ | IsFunType <- asFunType expr = SomeVarValue <$> evalFunToVarValue expr
+ | otherwise = SomeVarValue <$> evalToVarValue expr
+
+evalSomeWith :: GlobalDefs -> SomeExpr -> SomeVarValue
+evalSomeWith gdefs sexpr = runSimpleEval (evalSome sexpr) gdefs []
+
+
+data FunctionType a = FunctionType (FunctionArguments SomeVarValue -> a)
+
+instance ExprType a => ExprType (FunctionType a) where
+ textExprType _ = "function type"
+ textExprValue _ = "<function type>"
+
+data DynamicType
+
+instance ExprType DynamicType where
+ textExprType _ = "ambiguous type"
+ textExprValue _ = "<dynamic type>"
+
+
+data SomeExpr = forall a. ExprType a => SomeExpr (Expr a)
+
+newtype TypeVar = TypeVar Text
+ deriving (Eq, Ord)
+
+data SomeExprType
+ = forall a. ExprType a => ExprTypePrim (Proxy a)
+ | ExprTypeVar TypeVar
+ | forall a. ExprType a => ExprTypeFunction (FunctionArguments SomeArgumentType) (Proxy a)
+
+someExprType :: SomeExpr -> SomeExprType
+someExprType (SomeExpr expr) = go expr
+ where
+ go :: forall e. ExprType e => Expr e -> SomeExprType
+ go = \case
+ DynVariable tvar _ _ -> ExprTypeVar tvar
+ (e :: Expr a)
+ | IsFunType <- asFunType e -> ExprTypeFunction (gof e) (proxyOfFunctionType e)
+ | otherwise -> ExprTypePrim (Proxy @a)
+
+ gof :: forall e. ExprType e => Expr (FunctionType e) -> FunctionArguments SomeArgumentType
+ gof = \case
+ Let _ _ _ body -> gof body
+ Variable {} -> error "someExprType: gof: variable"
+ FunVariable params _ _ -> params
+ ArgsReq args body -> fmap snd args <> gof body
+ ArgsApp (FunctionArguments used) body ->
+ let FunctionArguments args = gof body
+ in FunctionArguments $ args `M.difference` used
+ FunctionAbstraction {} -> mempty
+ FunctionEval {} -> error "someExprType: gof: function eval"
+ Pure {} -> error "someExprType: gof: pure"
+ App {} -> error "someExprType: gof: app"
+ Undefined {} -> error "someExprType: gof: undefined"
+
+ proxyOfFunctionType :: Expr (FunctionType a) -> Proxy a
+ proxyOfFunctionType _ = Proxy
+
+textSomeExprType :: SomeExprType -> Text
+textSomeExprType (ExprTypePrim p) = textExprType p
+textSomeExprType (ExprTypeVar (TypeVar name)) = name
+textSomeExprType (ExprTypeFunction _ r) = "function:" <> textExprType r
+
+data AsFunType a
+ = forall b. (a ~ FunctionType b, ExprType b) => IsFunType
+ | NotFunType
+
+asFunType :: Expr a -> AsFunType a
+asFunType = \case
+ Let _ _ _ expr -> asFunType expr
+ FunVariable {} -> IsFunType
+ ArgsReq {} -> IsFunType
+ ArgsApp {} -> IsFunType
+ FunctionAbstraction {} -> IsFunType
+ _ -> NotFunType
+
+
+data VarValue a = VarValue
+ { vvVariables :: EvalTrace
+ , vvArguments :: FunctionArguments SomeArgumentType
+ , vvFunction :: SourceLine -> FunctionArguments SomeVarValue -> a
+ }
+
+data SomeVarValue = forall a. ExprType a => SomeVarValue (VarValue a)
+
+svvVariables :: SomeVarValue -> EvalTrace
+svvVariables (SomeVarValue vv) = vvVariables vv
+
+svvArguments :: SomeVarValue -> FunctionArguments SomeArgumentType
+svvArguments (SomeVarValue vv) = vvArguments vv
+
+someConstValue :: ExprType a => a -> SomeVarValue
+someConstValue = SomeVarValue . VarValue [] mempty . const . const
+
+fromConstValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> FqVarName -> VarValue a -> m a
+fromConstValue sline name (VarValue _ args value :: VarValue b) = do
+ maybe (fail err) return $ do
+ guard $ anull args
+ cast $ value sline mempty
+ where
+ err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textFqVarName name, T.pack "' has type ",
+ if anull args then textExprType @b Proxy else "function type" ]
+
+fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> FqVarName -> SomeVarValue -> m a
+fromSomeVarValue sline name (SomeVarValue (VarValue _ args value :: VarValue b)) = do
+ maybe (fail err) return $ do
+ guard $ anull args
+ cast $ value sline mempty
+ where
+ err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textFqVarName name, T.pack "' has type ",
+ if anull args then textExprType @b Proxy else "function type" ]
+
+textSomeVarValue :: SourceLine -> SomeVarValue -> Text
+textSomeVarValue sline (SomeVarValue (VarValue _ args value))
+ | anull args = textExprValue $ value sline mempty
+ | otherwise = "<function>"
+
+someVarValueType :: SomeVarValue -> SomeExprType
+someVarValueType (SomeVarValue (VarValue _ args _ :: VarValue a))
+ | anull args = ExprTypePrim (Proxy @a)
+ | otherwise = ExprTypeFunction args (Proxy @a)
+
+
+newtype ArgumentKeyword = ArgumentKeyword Text
+ deriving (Show, Eq, Ord, IsString)
+
+newtype FunctionArguments a = FunctionArguments (Map (Maybe ArgumentKeyword) a)
+ deriving (Show, Semigroup, Monoid, Functor, Foldable, Traversable)
+
+anull :: FunctionArguments a -> Bool
+anull (FunctionArguments args) = M.null args
+
+exprArgs :: Expr (FunctionType a) -> FunctionArguments SomeArgumentType
+exprArgs = \case
+ Let _ _ _ expr -> exprArgs expr
+ Variable {} -> mempty
+ FunVariable args _ _ -> args
+ ArgsReq args expr -> fmap snd args <> exprArgs expr
+ ArgsApp (FunctionArguments applied) expr ->
+ let FunctionArguments args = exprArgs expr
+ in FunctionArguments (args `M.difference` applied)
+ FunctionAbstraction {} -> mempty
+ FunctionEval {} -> mempty
+ Pure {} -> error "exprArgs: pure"
+ App {} -> error "exprArgs: app"
+ Undefined {} -> error "exprArgs: undefined"
+
+funFromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> FqVarName -> SomeVarValue -> m (FunctionType a)
+funFromSomeVarValue sline name (SomeVarValue (VarValue _ args value :: VarValue b)) = do
+ maybe (fail err) return $ do
+ FunctionType <$> cast (value sline)
+ where
+ err = T.unpack $ T.concat [ T.pack "expected function returning ", textExprType @a Proxy, T.pack ", but variable '", textFqVarName name, T.pack "' has ",
+ (if anull args then "type " else "function type returting ") <> textExprType @b Proxy ]
+
+data SomeArgumentType = forall a. ExprType a => SomeArgumentType (ArgumentType a)
+
+data ArgumentType a
+ = RequiredArgument
+ | OptionalArgument
+ | ExprDefault (Expr a)
+ | ContextDefault
+
+
+data Traced a = Traced EvalTrace a
+
+type VarNameSelectors = ( FqVarName, [ Text ] )
+type EvalTrace = [ ( VarNameSelectors, SomeVarValue ) ]
+
+gatherVars :: forall a m. MonadEval m => Expr a -> m EvalTrace
+gatherVars = fmap (uniqOn fst . sortOn fst) . helper
+ where
+ helper :: forall b. Expr b -> m EvalTrace
+ helper = \case
+ Let _ (TypedVarName var) _ expr -> withDictionary (filter ((var /=) . fst)) $ helper expr
+ Variable _ var
+ | isInternalVar var -> return []
+ | otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var
+ DynVariable _ _ var -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var
+ FunVariable _ _ var -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var
+ ArgsReq args expr -> withDictionary (filter ((`notElem` map fst (toList args)) . fst)) $ helper expr
+ ArgsApp (FunctionArguments args) fun -> do
+ v <- helper fun
+ vs <- mapM (\(SomeExpr e) -> helper e) $ M.elems args
+ return $ concat (v : vs)
+ FunctionAbstraction expr -> helper expr
+ FunctionEval efun -> helper efun
+ LambdaAbstraction (TypedVarName var) expr -> withDictionary (filter ((var /=) . fst)) $ helper expr
+ Pure _ -> return []
+ e@(App (AnnRecord sel) _ x)
+ | Just (var, sels) <- gatherSelectors x
+ -> do
+ val <- SomeVarValue . VarValue [] mempty . const . const <$> eval e
+ return [ (( var, sels ++ [ sel ] ), val ) ]
+ | otherwise -> do
+ helper x
+ App _ f x -> (++) <$> helper f <*> helper x
+ Concat es -> concat <$> mapM helper es
+ Regex es -> concat <$> mapM helper es
+ Undefined {} -> return []
+ Trace expr -> helper expr
+
+ gatherSelectors :: forall b. Expr b -> Maybe ( FqVarName, [ Text ] )
+ gatherSelectors = \case
+ Variable _ var -> Just (var, [])
+ App (AnnRecord sel) _ x -> do
+ (var, sels) <- gatherSelectors x
+ return (var, sels ++ [sel])
+ _ -> Nothing
+
+
+data Regex = RegexCompiled Text RE.Regex
+ | RegexPart Text
+ | RegexString Text
+
+instance ExprType Regex where
+ textExprType _ = T.pack "regex"
+ textExprValue _ = T.pack "<regex>"
+
+ exprExpansionConvFrom = listToMaybe $ catMaybes
+ [ cast (RegexString)
+ , cast (RegexString . T.pack . show @Integer)
+ , cast (RegexString . T.pack . show @Scientific)
+ ]
+
+regexCompile :: Text -> Either String Regex
+regexCompile src = either Left (Right . RegexCompiled src) $ RE.compile RE.defaultCompOpt RE.defaultExecOpt $
+ T.singleton '^' <> src <> T.singleton '$'
+
+regexMatch :: Regex -> Text -> Either String (Maybe (Text, Text, Text, [Text]))
+regexMatch (RegexCompiled _ re) text = RE.regexec re text
+regexMatch _ _ = Left "regex not compiled"
+
+regexSource :: Regex -> Text
+regexSource (RegexCompiled src _) = src
+regexSource (RegexPart src) = src
+regexSource (RegexString str) = T.concatMap escapeChar str
+ where
+ escapeChar c | isAlphaNum c = T.singleton c
+ | c `elem` ['`', '\'', '<', '>'] = T.singleton c
+ | otherwise = T.pack ['\\', c]
diff --git a/src/Script/Expr/Class.hs b/src/Script/Expr/Class.hs
new file mode 100644
index 0000000..20a92b4
--- /dev/null
+++ b/src/Script/Expr/Class.hs
@@ -0,0 +1,77 @@
+module Script.Expr.Class (
+ ExprType(..),
+ RecordSelector(..),
+ ExprListUnpacker(..),
+ ExprEnumerator(..),
+) where
+
+import Data.Maybe
+import Data.Scientific
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Typeable
+import Data.Void
+
+class Typeable a => ExprType a where
+ textExprType :: proxy a -> Text
+ textExprValue :: a -> Text
+
+ recordMembers :: [(Text, RecordSelector a)]
+ recordMembers = []
+
+ exprExpansionConvTo :: ExprType b => Maybe (a -> b)
+ exprExpansionConvTo = Nothing
+
+ exprExpansionConvFrom :: ExprType b => Maybe (b -> a)
+ exprExpansionConvFrom = Nothing
+
+ exprListUnpacker :: proxy a -> Maybe (ExprListUnpacker a)
+ exprListUnpacker _ = Nothing
+
+ exprEnumerator :: proxy a -> Maybe (ExprEnumerator a)
+ exprEnumerator _ = Nothing
+
+
+data RecordSelector a = forall b. ExprType b => RecordSelector (a -> b)
+
+data ExprListUnpacker a = forall e. ExprType e => ExprListUnpacker (a -> [e]) (Proxy a -> Proxy e)
+
+data ExprEnumerator a = ExprEnumerator (a -> a -> [a]) (a -> a -> a -> [a])
+
+
+instance ExprType Integer where
+ textExprType _ = T.pack "integer"
+ textExprValue x = T.pack (show x)
+
+ exprExpansionConvTo = listToMaybe $ catMaybes
+ [ cast (T.pack . show :: Integer -> Text)
+ ]
+
+ exprEnumerator _ = Just $ ExprEnumerator enumFromTo enumFromThenTo
+
+instance ExprType Scientific where
+ textExprType _ = T.pack "number"
+ textExprValue x = T.pack (show x)
+
+ exprExpansionConvTo = listToMaybe $ catMaybes
+ [ cast (T.pack . show :: Scientific -> Text)
+ ]
+
+instance ExprType Bool where
+ textExprType _ = T.pack "bool"
+ textExprValue True = T.pack "true"
+ textExprValue False = T.pack "false"
+
+instance ExprType Text where
+ textExprType _ = T.pack "string"
+ textExprValue x = T.pack (show x)
+
+instance ExprType Void where
+ textExprType _ = T.pack "void"
+ textExprValue _ = T.pack "<void>"
+
+instance ExprType a => ExprType [a] where
+ textExprType _ = "[" <> textExprType @a Proxy <> "]"
+ textExprValue x = "[" <> T.intercalate ", " (map textExprValue x) <> "]"
+
+ exprListUnpacker _ = Just $ ExprListUnpacker id (const Proxy)
diff --git a/src/Script/Module.hs b/src/Script/Module.hs
new file mode 100644
index 0000000..3ea59bf
--- /dev/null
+++ b/src/Script/Module.hs
@@ -0,0 +1,20 @@
+module Script.Module (
+ Module(..),
+ ModuleName(..), textModuleName,
+ moduleExportedDefinitions,
+) where
+
+import Script.Expr
+import Test
+
+data Module = Module
+ { moduleName :: ModuleName
+ , moduleTests :: [ Test ]
+ , moduleDefinitions :: [ ( VarName, SomeExpr ) ]
+ , moduleExports :: [ VarName ]
+ }
+
+moduleExportedDefinitions :: Module -> [ ( VarName, ( FqVarName, SomeExpr )) ]
+moduleExportedDefinitions Module {..} =
+ map (\( var, expr ) -> ( var, ( GlobalVarName moduleName var, expr ))) $
+ filter ((`elem` moduleExports) . fst) moduleDefinitions
diff --git a/src/Script/Object.hs b/src/Script/Object.hs
new file mode 100644
index 0000000..9232b21
--- /dev/null
+++ b/src/Script/Object.hs
@@ -0,0 +1,42 @@
+module Script.Object (
+ ObjectId(..),
+ ObjectType(..),
+ Object(..), SomeObject(..),
+ toSomeObject, fromSomeObject,
+ destroySomeObject,
+) where
+
+import Data.Kind
+import Data.Typeable
+
+
+newtype ObjectId = ObjectId Int
+
+class Typeable a => ObjectType m a where
+ type ConstructorArgs a :: Type
+ type ConstructorArgs a = ()
+
+ createObject :: ObjectId -> ConstructorArgs a -> m (Object m a)
+ destroyObject :: Object m a -> m ()
+
+data Object m a = ObjectType m a => Object
+ { objId :: ObjectId
+ , objImpl :: a
+ }
+
+data SomeObject m = forall a. ObjectType m a => SomeObject
+ { sobjId :: ObjectId
+ , sobjImpl :: a
+ }
+
+toSomeObject :: Object m a -> SomeObject m
+toSomeObject Object {..} = SomeObject { sobjId = objId, sobjImpl = objImpl }
+
+fromSomeObject :: ObjectType m a => SomeObject m -> Maybe (Object m a)
+fromSomeObject SomeObject {..} = do
+ let objId = sobjId
+ objImpl <- cast sobjImpl
+ return Object {..}
+
+destroySomeObject :: SomeObject m -> m ()
+destroySomeObject (SomeObject oid impl) = destroyObject (Object oid impl)
diff --git a/src/Script/Shell.hs b/src/Script/Shell.hs
new file mode 100644
index 0000000..9bbf06c
--- /dev/null
+++ b/src/Script/Shell.hs
@@ -0,0 +1,94 @@
+module Script.Shell (
+ ShellStatement(..),
+ ShellScript(..),
+ withShellProcess,
+) where
+
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.IO.Class
+import Control.Monad.Reader
+
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Text.IO qualified as T
+
+import System.Exit
+import System.IO
+import System.Process hiding (ShellCommand)
+
+import Network
+import Network.Ip
+import Output
+import Process
+import Run.Monad
+import Script.Var
+
+
+data ShellStatement = ShellStatement
+ { shellCommand :: Text
+ , shellArguments :: [ Text ]
+ , shellSourceLine :: SourceLine
+ }
+
+newtype ShellScript = ShellScript [ ShellStatement ]
+
+
+executeScript :: Node -> ProcName -> MVar ExitCode -> Handle -> Handle -> Handle -> ShellScript -> TestRun ()
+executeScript node pname statusVar pstdin pstdout pstderr (ShellScript statements) = do
+ setNetworkNamespace $ getNetns node
+ forM_ statements $ \ShellStatement {..} -> case shellCommand of
+ "echo" -> liftIO $ do
+ T.hPutStrLn pstdout $ T.intercalate " " shellArguments
+ hFlush pstdout
+ cmd -> do
+ (_, _, _, phandle) <- liftIO $ createProcess_ "shell"
+ (proc (T.unpack cmd) (map T.unpack shellArguments))
+ { std_in = UseHandle pstdin
+ , std_out = UseHandle pstdout
+ , std_err = UseHandle pstderr
+ , cwd = Just (nodeDir node)
+ , env = Just []
+ }
+ liftIO (waitForProcess phandle) >>= \case
+ ExitSuccess -> return ()
+ status -> do
+ outLine OutputChildFail (Just $ textProcName pname) $ "failed at: " <> textSourceLine shellSourceLine
+ liftIO $ putMVar statusVar status
+ throwError Failed
+ liftIO $ putMVar statusVar ExitSuccess
+
+spawnShell :: Node -> ProcName -> ShellScript -> TestRun Process
+spawnShell procNode procName script = do
+ procOutput <- liftIO $ newTVarIO []
+ statusVar <- liftIO $ newEmptyMVar
+ ( pstdin, procStdin ) <- liftIO $ createPipe
+ ( hout, pstdout ) <- liftIO $ createPipe
+ ( herr, pstderr ) <- liftIO $ createPipe
+ procHandle <- fmap (Right . (, statusVar)) $ forkTestUsing forkOS $ do
+ executeScript procNode procName statusVar pstdin pstdout pstderr script
+
+ let procKillWith = Nothing
+ let process = Process {..}
+
+ void $ forkTest $ lineReadingLoop process hout $ \line -> do
+ outProc OutputChildStdout process line
+ liftIO $ atomically $ modifyTVar procOutput (++ [ line ])
+ void $ forkTest $ lineReadingLoop process herr $ \line -> do
+ outProc OutputChildStderr process line
+
+ return process
+
+withShellProcess :: Node -> ProcName -> ShellScript -> (Process -> TestRun a) -> TestRun a
+withShellProcess node pname script inner = do
+ procVar <- asks $ teProcesses . fst
+
+ process <- spawnShell node pname script
+ liftIO $ modifyMVar_ procVar $ return . (process:)
+
+ inner process `finally` do
+ ps <- liftIO $ takeMVar procVar
+ closeTestProcess process `finally` do
+ liftIO $ putMVar procVar $ filter (/=process) ps
diff --git a/src/Script/Var.hs b/src/Script/Var.hs
new file mode 100644
index 0000000..668060c
--- /dev/null
+++ b/src/Script/Var.hs
@@ -0,0 +1,56 @@
+module Script.Var (
+ VarName(..), textVarName, unpackVarName,
+ FqVarName(..), textFqVarName, unpackFqVarName, unqualifyName,
+ TypedVarName(..),
+ ModuleName(..), textModuleName,
+ SourceLine(..), textSourceLine,
+) where
+
+import Data.Text (Text)
+import Data.Text qualified as T
+
+
+newtype VarName = VarName Text
+ deriving (Eq, Ord)
+
+textVarName :: VarName -> Text
+textVarName (VarName name) = name
+
+unpackVarName :: VarName -> String
+unpackVarName = T.unpack . textVarName
+
+
+data FqVarName
+ = GlobalVarName ModuleName VarName
+ | LocalVarName VarName
+ deriving (Eq, Ord)
+
+textFqVarName :: FqVarName -> Text
+textFqVarName (GlobalVarName mname vname) = textModuleName mname <> "." <> textVarName vname
+textFqVarName (LocalVarName vname) = textVarName vname
+
+unpackFqVarName :: FqVarName -> String
+unpackFqVarName = T.unpack . textFqVarName
+
+unqualifyName :: FqVarName -> VarName
+unqualifyName (GlobalVarName _ name) = name
+unqualifyName (LocalVarName name) = name
+
+
+newtype TypedVarName a = TypedVarName { fromTypedVarName :: VarName }
+ deriving (Eq, Ord)
+
+
+newtype ModuleName = ModuleName [ Text ]
+ deriving (Eq, Ord, Show)
+
+textModuleName :: ModuleName -> Text
+textModuleName (ModuleName parts) = T.intercalate "." parts
+
+data SourceLine
+ = SourceLine Text
+ | SourceLineBuiltin
+
+textSourceLine :: SourceLine -> Text
+textSourceLine (SourceLine text) = text
+textSourceLine SourceLineBuiltin = "<builtin>"
diff --git a/src/Test.hs b/src/Test.hs
index 3db7919..3e98efa 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -1,533 +1,81 @@
module Test (
- Module(..),
Test(..),
TestStep(..),
TestBlock(..),
- SourceLine(..), textSourceLine,
- MonadEval(..), lookupVar, tryLookupVar, withVar,
- VarName(..), TypedVarName(..), textVarName, unpackVarName, withTypedVar,
- ExprType(..), SomeExpr(..),
- TypeVar(..), SomeExprType(..), someExprType, textSomeExprType,
- FunctionType, DynamicType,
-
- VarValue(..), SomeVarValue(..),
- svvVariables, svvArguments,
- someConstValue, fromConstValue,
- fromSomeVarValue, textSomeVarValue, someVarValueType,
-
- RecordSelector(..),
- ExprListUnpacker(..),
- ExprEnumerator(..),
- Expr(..), varExpr, mapExpr, eval, evalSome,
- Traced(..), EvalTrace, VarNameSelectors, gatherVars,
- AppAnnotation(..),
-
- ArgumentKeyword(..), FunctionArguments(..),
- anull, exprArgs,
- SomeArgumentType(..), ArgumentType(..),
-
- Regex(RegexPart, RegexString), regexMatch,
+ MultiplyTimeout(..),
) where
-import Control.Monad
+import Control.Concurrent.MVar
+import Control.Monad.Except
import Control.Monad.Reader
-import Data.Char
-import Data.Foldable
-import Data.List
-import Data.Map (Map)
-import Data.Map qualified as M
import Data.Scientific
-import Data.String
import Data.Text (Text)
-import Data.Text qualified as T
import Data.Typeable
-import Data.Void
-
-import Text.Regex.TDFA qualified as RE
-import Text.Regex.TDFA.Text qualified as RE
-
-import {-# SOURCE #-} Network
-import {-# SOURCE #-} Process
-import Util
-data Module = Module
- { moduleName :: [ Text ]
- , moduleTests :: [ Test ]
- , moduleDefinitions :: [ ( VarName, SomeExpr ) ]
- }
+import Network
+import Output
+import Process
+import Run.Monad
+import Script.Expr
+import Script.Object
+import Script.Shell
data Test = Test
{ testName :: Text
- , testSteps :: Expr TestBlock
+ , testSteps :: Expr (TestStep ())
}
-newtype TestBlock = TestBlock [ TestStep ]
- deriving (Semigroup, Monoid)
-
-data TestStep
- = Subnet (TypedVarName Network) Network (Network -> TestBlock)
- | DeclNode (TypedVarName Node) Network (Node -> TestBlock)
- | Spawn (TypedVarName Process) (Either Network Node) (Process -> TestBlock)
- | Send Process Text
- | Expect SourceLine Process (Traced Regex) [ TypedVarName Text ] ([ Text ] -> TestBlock)
- | Flush Process (Maybe Regex)
- | Guard SourceLine EvalTrace Bool
- | DisconnectNode Node TestBlock
- | DisconnectNodes Network TestBlock
- | DisconnectUpstream Network TestBlock
- | PacketLoss Scientific Node TestBlock
- | Wait
-
-data SourceLine
- = SourceLine Text
- | SourceLineBuiltin
-
-textSourceLine :: SourceLine -> Text
-textSourceLine (SourceLine text) = text
-textSourceLine SourceLineBuiltin = "<builtin>"
-
-
-class MonadFail m => MonadEval m where
- askDictionary :: m VariableDictionary
- withDictionary :: (VariableDictionary -> VariableDictionary) -> m a -> m a
-
-type VariableDictionary = [ ( VarName, SomeVarValue ) ]
-
-lookupVar :: MonadEval m => VarName -> m SomeVarValue
-lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackVarName name ++ "'") return . lookup name =<< askDictionary
-
-tryLookupVar :: MonadEval m => VarName -> m (Maybe SomeVarValue)
-tryLookupVar name = lookup name <$> askDictionary
-
-withVar :: (MonadEval m, ExprType e) => VarName -> e -> m a -> m a
-withVar name value = withDictionary (( name, someConstValue value ) : )
-
-newtype VarName = VarName Text
- deriving (Eq, Ord, Show)
-
-newtype TypedVarName a = TypedVarName { fromTypedVarName :: VarName }
- deriving (Eq, Ord)
-
-textVarName :: VarName -> Text
-textVarName (VarName name ) = name
-
-unpackVarName :: VarName -> String
-unpackVarName = T.unpack . textVarName
-
-isInternalVar :: VarName -> Bool
-isInternalVar (VarName name)
- | Just ( '$', _ ) <- T.uncons name = True
- | otherwise = False
-
-withTypedVar :: (MonadEval m, ExprType e) => TypedVarName e -> e -> m a -> m a
-withTypedVar (TypedVarName name) = withVar name
-
-
-class Typeable a => ExprType a where
- textExprType :: proxy a -> Text
- textExprValue :: a -> Text
-
- recordMembers :: [(Text, RecordSelector a)]
- recordMembers = []
-
- exprListUnpacker :: proxy a -> Maybe (ExprListUnpacker a)
- exprListUnpacker _ = Nothing
-
- exprEnumerator :: proxy a -> Maybe (ExprEnumerator a)
- exprEnumerator _ = Nothing
-
-instance ExprType Integer where
- textExprType _ = T.pack "integer"
- textExprValue x = T.pack (show x)
-
- exprEnumerator _ = Just $ ExprEnumerator enumFromTo enumFromThenTo
-
-instance ExprType Scientific where
- textExprType _ = T.pack "number"
- textExprValue x = T.pack (show x)
-
-instance ExprType Bool where
- textExprType _ = T.pack "bool"
- textExprValue True = T.pack "true"
- textExprValue False = T.pack "false"
-
-instance ExprType Text where
- textExprType _ = T.pack "string"
- textExprValue x = T.pack (show x)
-
-instance ExprType Regex where
- textExprType _ = T.pack "regex"
- textExprValue _ = T.pack "<regex>"
-
-instance ExprType Void where
- textExprType _ = T.pack "void"
- textExprValue _ = T.pack "<void>"
-
-instance ExprType a => ExprType [a] where
- textExprType _ = "[" <> textExprType @a Proxy <> "]"
- textExprValue x = "[" <> T.intercalate ", " (map textExprValue x) <> "]"
-
- exprListUnpacker _ = Just $ ExprListUnpacker id (const Proxy)
-
-instance ExprType TestBlock where
+data TestBlock a where
+ EmptyTestBlock :: TestBlock ()
+ TestBlockStep :: TestBlock () -> TestStep a -> TestBlock a
+
+instance Semigroup (TestBlock ()) where
+ EmptyTestBlock <> block = block
+ block <> EmptyTestBlock = block
+ block <> TestBlockStep block' step = TestBlockStep (block <> block') step
+
+instance Monoid (TestBlock ()) where
+ mempty = EmptyTestBlock
+
+data TestStep a where
+ Scope :: TestBlock a -> TestStep a
+ CreateObject :: forall o. ObjectType TestRun o => Proxy o -> ConstructorArgs o -> TestStep ()
+ Subnet :: TypedVarName Network -> Network -> (Network -> TestStep a) -> TestStep a
+ DeclNode :: TypedVarName Node -> Network -> (Node -> TestStep a) -> TestStep a
+ Spawn :: TypedVarName Process -> Either Network Node -> [ Text ] -> (Process -> TestStep a) -> TestStep a
+ SpawnShell :: Maybe (TypedVarName Process) -> Node -> ShellScript -> (Process -> TestStep a) -> TestStep a
+ Send :: Process -> Text -> TestStep ()
+ Expect :: SourceLine -> Process -> Traced Regex -> [ TypedVarName Text ] -> ([ Text ] -> TestStep a) -> TestStep a
+ Flush :: Process -> Maybe Regex -> TestStep ()
+ Guard :: SourceLine -> EvalTrace -> Bool -> TestStep ()
+ DisconnectNode :: Node -> TestStep a -> TestStep a
+ DisconnectNodes :: Network -> TestStep a -> TestStep a
+ DisconnectUpstream :: Network -> TestStep a -> TestStep a
+ PacketLoss :: Scientific -> Node -> TestStep a -> TestStep a
+ Wait :: TestStep ()
+
+instance Typeable a => ExprType (TestBlock a) where
textExprType _ = "test block"
textExprValue _ = "<test block>"
-data FunctionType a = FunctionType (FunctionArguments SomeVarValue -> a)
-
-instance ExprType a => ExprType (FunctionType a) where
- textExprType _ = "function type"
- textExprValue _ = "<function type>"
-
-data DynamicType
-
-instance ExprType DynamicType where
- textExprType _ = "ambiguous type"
- textExprValue _ = "<dynamic type>"
-
-data SomeExpr = forall a. ExprType a => SomeExpr (Expr a)
-
-newtype TypeVar = TypeVar Text
- deriving (Eq, Ord)
-
-data SomeExprType
- = forall a. ExprType a => ExprTypePrim (Proxy a)
- | ExprTypeVar TypeVar
- | forall a. ExprType a => ExprTypeFunction (FunctionArguments SomeArgumentType) (Proxy a)
-
-someExprType :: SomeExpr -> SomeExprType
-someExprType (SomeExpr expr) = go expr
- where
- go :: forall e. ExprType e => Expr e -> SomeExprType
- go = \case
- DynVariable tvar _ _ -> ExprTypeVar tvar
- (e :: Expr a)
- | IsFunType <- asFunType e -> ExprTypeFunction (gof e) (proxyOfFunctionType e)
- | otherwise -> ExprTypePrim (Proxy @a)
-
- gof :: forall e. ExprType e => Expr (FunctionType e) -> FunctionArguments SomeArgumentType
- gof = \case
- Let _ _ _ body -> gof body
- Variable {} -> error "someExprType: gof: variable"
- FunVariable params _ _ -> params
- ArgsReq args body -> fmap snd args <> gof body
- ArgsApp (FunctionArguments used) body ->
- let FunctionArguments args = gof body
- in FunctionArguments $ args `M.difference` used
- FunctionAbstraction {} -> mempty
- FunctionEval {} -> error "someExprType: gof: function eval"
- Pure {} -> error "someExprType: gof: pure"
- App {} -> error "someExprType: gof: app"
- Undefined {} -> error "someExprType: gof: undefined"
-
- proxyOfFunctionType :: Expr (FunctionType a) -> Proxy a
- proxyOfFunctionType _ = Proxy
-
-textSomeExprType :: SomeExprType -> Text
-textSomeExprType (ExprTypePrim p) = textExprType p
-textSomeExprType (ExprTypeVar (TypeVar name)) = name
-textSomeExprType (ExprTypeFunction _ r) = "function:" <> textExprType r
-
-data AsFunType a
- = forall b. (a ~ FunctionType b, ExprType b) => IsFunType
- | NotFunType
-
-asFunType :: Expr a -> AsFunType a
-asFunType = \case
- Let _ _ _ expr -> asFunType expr
- FunVariable {} -> IsFunType
- ArgsReq {} -> IsFunType
- ArgsApp {} -> IsFunType
- FunctionAbstraction {} -> IsFunType
- _ -> NotFunType
-
-
-data SomeVarValue = forall a. ExprType a => SomeVarValue (VarValue a)
-
-svvVariables :: SomeVarValue -> EvalTrace
-svvVariables (SomeVarValue vv) = vvVariables vv
-
-svvArguments :: SomeVarValue -> FunctionArguments SomeArgumentType
-svvArguments (SomeVarValue vv) = vvArguments vv
-
-data VarValue a = VarValue
- { vvVariables :: EvalTrace
- , vvArguments :: FunctionArguments SomeArgumentType
- , vvFunction :: SourceLine -> FunctionArguments SomeVarValue -> a
- }
-
-someConstValue :: ExprType a => a -> SomeVarValue
-someConstValue = SomeVarValue . VarValue [] mempty . const . const
-
-fromConstValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> VarName -> VarValue a -> m a
-fromConstValue sline name (VarValue _ args value :: VarValue b) = do
- maybe (fail err) return $ do
- guard $ anull args
- cast $ value sline mempty
- where
- err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textVarName name, T.pack "' has type ",
- if anull args then textExprType @b Proxy else "function type" ]
-
-fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> VarName -> SomeVarValue -> m a
-fromSomeVarValue sline name (SomeVarValue (VarValue _ args value :: VarValue b)) = do
- maybe (fail err) return $ do
- guard $ anull args
- cast $ value sline mempty
- where
- err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textVarName name, T.pack "' has type ",
- if anull args then textExprType @b Proxy else "function type" ]
-
-textSomeVarValue :: SourceLine -> SomeVarValue -> Text
-textSomeVarValue sline (SomeVarValue (VarValue _ args value))
- | anull args = textExprValue $ value sline mempty
- | otherwise = "<function>"
-
-someVarValueType :: SomeVarValue -> SomeExprType
-someVarValueType (SomeVarValue (VarValue _ args _ :: VarValue a))
- | anull args = ExprTypePrim (Proxy @a)
- | otherwise = ExprTypeFunction args (Proxy @a)
-
-
-data RecordSelector a = forall b. ExprType b => RecordSelector (a -> b)
-
-data ExprListUnpacker a = forall e. ExprType e => ExprListUnpacker (a -> [e]) (Proxy a -> Proxy e)
-
-data ExprEnumerator a = ExprEnumerator (a -> a -> [a]) (a -> a -> a -> [a])
-
-
-data Expr a where
- Let :: forall a b. ExprType b => SourceLine -> TypedVarName b -> Expr b -> Expr a -> Expr a
- Variable :: ExprType a => SourceLine -> VarName -> Expr a
- DynVariable :: TypeVar -> SourceLine -> VarName -> Expr DynamicType
- FunVariable :: ExprType a => FunctionArguments SomeArgumentType -> SourceLine -> VarName -> Expr (FunctionType a)
- ArgsReq :: ExprType a => FunctionArguments ( VarName, SomeArgumentType ) -> Expr (FunctionType a) -> Expr (FunctionType a)
- ArgsApp :: ExprType a => FunctionArguments SomeExpr -> Expr (FunctionType a) -> Expr (FunctionType a)
- FunctionAbstraction :: ExprType a => Expr a -> Expr (FunctionType a)
- FunctionEval :: ExprType a => Expr (FunctionType a) -> Expr a
- LambdaAbstraction :: ExprType a => TypedVarName a -> Expr b -> Expr (a -> b)
- Pure :: a -> Expr a
- App :: AppAnnotation b -> Expr (a -> b) -> Expr a -> Expr b
- Concat :: [Expr Text] -> Expr Text
- Regex :: [Expr Regex] -> Expr Regex
- Undefined :: String -> Expr a
- Trace :: Expr a -> Expr (Traced a)
-
-data AppAnnotation b = AnnNone
- | ExprType b => AnnRecord Text
-
-instance Functor Expr where
- fmap f x = Pure f <*> x
-
-instance Applicative Expr where
- pure = Pure
- (<*>) = App AnnNone
-
-instance Semigroup a => Semigroup (Expr a) where
- e <> f = (<>) <$> e <*> f
-
-instance Monoid a => Monoid (Expr a) where
- mempty = Pure mempty
-
-varExpr :: ExprType a => SourceLine -> TypedVarName a -> Expr a
-varExpr sline (TypedVarName name) = Variable sline name
-
-mapExpr :: forall a. (forall b. Expr b -> Expr b) -> Expr a -> Expr a
-mapExpr f = go
- where
- go :: forall c. Expr c -> Expr c
- go = \case
- Let sline vname vval expr -> f $ Let sline vname (go vval) (go expr)
- e@Variable {} -> f e
- e@DynVariable {} -> f e
- e@FunVariable {} -> f e
- ArgsReq args expr -> f $ ArgsReq args (go expr)
- ArgsApp args expr -> f $ ArgsApp (fmap (\(SomeExpr e) -> SomeExpr (go e)) args) (go expr)
- FunctionAbstraction expr -> f $ FunctionAbstraction (go expr)
- FunctionEval expr -> f $ FunctionEval (go expr)
- LambdaAbstraction tvar expr -> f $ LambdaAbstraction tvar (go expr)
- e@Pure {} -> f e
- App ann efun earg -> f $ App ann (go efun) (go earg)
- e@Concat {} -> f e
- e@Regex {} -> f e
- e@Undefined {} -> f e
- Trace expr -> f $ Trace (go expr)
-
-
-newtype SimpleEval a = SimpleEval (Reader VariableDictionary a)
- deriving (Functor, Applicative, Monad)
-
-runSimpleEval :: SimpleEval a -> VariableDictionary -> a
-runSimpleEval (SimpleEval x) = runReader x
-
-instance MonadFail SimpleEval where
- fail = error . ("eval failed: " <>)
-
-instance MonadEval SimpleEval where
- askDictionary = SimpleEval ask
- withDictionary f (SimpleEval inner) = SimpleEval (local f inner)
-
-
-eval :: forall m a. MonadEval m => Expr a -> m a
-eval = \case
- Let _ (TypedVarName name) valExpr expr -> do
- val <- eval valExpr
- withVar name val $ eval expr
- Variable sline name -> fromSomeVarValue sline name =<< lookupVar name
- DynVariable _ _ name -> fail $ "ambiguous type of ‘" <> unpackVarName name <> "’"
- FunVariable _ sline name -> funFromSomeVarValue sline name =<< lookupVar name
- ArgsReq (FunctionArguments req) efun -> do
- dict <- askDictionary
- return $ FunctionType $ \(FunctionArguments args) ->
- let used = M.intersectionWith (\value ( vname, _ ) -> ( vname, value )) args req
- FunctionType fun = runSimpleEval (eval efun) (toList used ++ dict)
- in fun $ FunctionArguments $ args `M.difference` req
- ArgsApp eargs efun -> do
- FunctionType fun <- eval efun
- args <- mapM evalSome eargs
- return $ FunctionType $ \args' -> fun (args <> args')
- FunctionAbstraction expr -> do
- val <- eval expr
- return $ FunctionType $ const val
- FunctionEval efun -> do
- FunctionType fun <- eval efun
- return $ fun mempty
- LambdaAbstraction (TypedVarName name) expr -> do
- dict <- askDictionary
- return $ \x -> runSimpleEval (eval expr) (( name, someConstValue x ) : dict)
- Pure value -> return value
- App _ f x -> eval f <*> eval x
- Concat xs -> T.concat <$> mapM eval xs
- Regex xs -> mapM eval xs >>= \case
- [ re@RegexCompiled {} ] -> return re
- parts -> case regexCompile $ T.concat $ map regexSource parts of
- Left err -> fail err
- Right re -> return re
- Undefined err -> fail err
- Trace expr -> Traced <$> gatherVars expr <*> eval expr
-
-evalSome :: MonadEval m => SomeExpr -> m SomeVarValue
-evalSome (SomeExpr expr)
- | IsFunType <- asFunType expr = do
- FunctionType fun <- eval expr
- fmap SomeVarValue $ VarValue
- <$> gatherVars expr
- <*> pure (exprArgs expr)
- <*> pure (const fun)
- | otherwise = do
- fmap SomeVarValue $ VarValue
- <$> gatherVars expr
- <*> pure mempty
- <*> (const . const <$> eval expr)
-
-data Traced a = Traced EvalTrace a
-
-type VarNameSelectors = ( VarName, [ Text ] )
-type EvalTrace = [ ( VarNameSelectors, SomeVarValue ) ]
-
-gatherVars :: forall a m. MonadEval m => Expr a -> m EvalTrace
-gatherVars = fmap (uniqOn fst . sortOn fst) . helper
- where
- helper :: forall b. Expr b -> m EvalTrace
- helper = \case
- Let _ (TypedVarName var) _ expr -> withDictionary (filter ((var /=) . fst)) $ helper expr
- Variable _ var
- | isInternalVar var -> return []
- | otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var
- DynVariable _ _ var -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var
- FunVariable _ _ var -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var
- ArgsReq args expr -> withDictionary (filter ((`notElem` map fst (toList args)) . fst)) $ helper expr
- ArgsApp (FunctionArguments args) fun -> do
- v <- helper fun
- vs <- mapM (\(SomeExpr e) -> helper e) $ M.elems args
- return $ concat (v : vs)
- FunctionAbstraction expr -> helper expr
- FunctionEval efun -> helper efun
- LambdaAbstraction (TypedVarName var) expr -> withDictionary (filter ((var /=) . fst)) $ helper expr
- Pure _ -> return []
- e@(App (AnnRecord sel) _ x)
- | Just (var, sels) <- gatherSelectors x
- -> do
- val <- SomeVarValue . VarValue [] mempty . const . const <$> eval e
- return [ (( var, sels ++ [ sel ] ), val ) ]
- | otherwise -> do
- helper x
- App _ f x -> (++) <$> helper f <*> helper x
- Concat es -> concat <$> mapM helper es
- Regex es -> concat <$> mapM helper es
- Undefined {} -> return []
- Trace expr -> helper expr
-
- gatherSelectors :: forall b. Expr b -> Maybe (VarName, [Text])
- gatherSelectors = \case
- Variable _ var -> Just (var, [])
- App (AnnRecord sel) _ x -> do
- (var, sels) <- gatherSelectors x
- return (var, sels ++ [sel])
- _ -> Nothing
-
-
-newtype ArgumentKeyword = ArgumentKeyword Text
- deriving (Show, Eq, Ord, IsString)
-
-newtype FunctionArguments a = FunctionArguments (Map (Maybe ArgumentKeyword) a)
- deriving (Show, Semigroup, Monoid, Functor, Foldable, Traversable)
-
-anull :: FunctionArguments a -> Bool
-anull (FunctionArguments args) = M.null args
-
-exprArgs :: Expr (FunctionType a) -> FunctionArguments SomeArgumentType
-exprArgs = \case
- Let _ _ _ expr -> exprArgs expr
- Variable {} -> mempty
- FunVariable args _ _ -> args
- ArgsReq args expr -> fmap snd args <> exprArgs expr
- ArgsApp (FunctionArguments applied) expr ->
- let FunctionArguments args = exprArgs expr
- in FunctionArguments (args `M.difference` applied)
- FunctionAbstraction {} -> mempty
- FunctionEval {} -> mempty
- Pure {} -> error "exprArgs: pure"
- App {} -> error "exprArgs: app"
- Undefined {} -> error "exprArgs: undefined"
-
-funFromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> VarName -> SomeVarValue -> m (FunctionType a)
-funFromSomeVarValue sline name (SomeVarValue (VarValue _ args value :: VarValue b)) = do
- maybe (fail err) return $ do
- guard $ not $ anull args
- FunctionType <$> cast (value sline)
- where
- err = T.unpack $ T.concat [ T.pack "expected function returning ", textExprType @a Proxy, T.pack ", but variable '", textVarName name, T.pack "' has ",
- (if anull args then "type " else "function type returting ") <> textExprType @b Proxy ]
-
-data SomeArgumentType = forall a. ExprType a => SomeArgumentType (ArgumentType a)
-
-data ArgumentType a
- = RequiredArgument
- | OptionalArgument
- | ExprDefault (Expr a)
- | ContextDefault
-
+data MultiplyTimeout = MultiplyTimeout Scientific
-data Regex = RegexCompiled Text RE.Regex
- | RegexPart Text
- | RegexString Text
+instance ObjectType TestRun MultiplyTimeout where
+ type ConstructorArgs MultiplyTimeout = Scientific
-regexCompile :: Text -> Either String Regex
-regexCompile src = either Left (Right . RegexCompiled src) $ RE.compile RE.defaultCompOpt RE.defaultExecOpt $
- T.singleton '^' <> src <> T.singleton '$'
+ createObject oid timeout
+ | timeout > 0 = do
+ var <- asks (teTimeout . fst)
+ liftIO $ modifyMVar_ var $ return . (* timeout)
+ return $ Object oid $ MultiplyTimeout timeout
-regexMatch :: Regex -> Text -> Either String (Maybe (Text, Text, Text, [Text]))
-regexMatch (RegexCompiled _ re) text = RE.regexec re text
-regexMatch _ _ = Left "regex not compiled"
+ | otherwise = do
+ outLine OutputError Nothing "timeout must be positive"
+ throwError Failed
-regexSource :: Regex -> Text
-regexSource (RegexCompiled src _) = src
-regexSource (RegexPart src) = src
-regexSource (RegexString str) = T.concatMap escapeChar str
- where
- escapeChar c | isAlphaNum c = T.singleton c
- | c `elem` ['`', '\'', '<', '>'] = T.singleton c
- | otherwise = T.pack ['\\', c]
+ destroyObject Object { objImpl = MultiplyTimeout timeout } = do
+ var <- asks (teTimeout . fst)
+ liftIO $ modifyMVar_ var $ return . (/ timeout)
diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs
index a676a35..6dba707 100644
--- a/src/Test/Builtins.hs
+++ b/src/Test/Builtins.hs
@@ -4,33 +4,39 @@ module Test.Builtins (
import Data.Map qualified as M
import Data.Maybe
+import Data.Proxy
+import Data.Scientific
import Data.Text (Text)
import Process (Process)
+import Script.Expr
import Test
-builtins :: [ ( VarName, SomeVarValue ) ]
-builtins =
- [ ( VarName "send", builtinSend )
- , ( VarName "flush", builtinFlush )
- , ( VarName "guard", builtinGuard )
- , ( VarName "wait", builtinWait )
+builtins :: GlobalDefs
+builtins = M.fromList
+ [ fq "send" builtinSend
+ , fq "flush" builtinFlush
+ , fq "guard" builtinGuard
+ , fq "multiply_timeout" builtinMultiplyTimeout
+ , fq "wait" builtinWait
]
+ where
+ fq name impl = (( ModuleName [ "$" ], VarName name ), impl )
getArg :: ExprType a => FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> a
getArg args = fromMaybe (error "parameter mismatch") . getArgMb args
getArgMb :: ExprType a => FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> Maybe a
getArgMb (FunctionArguments args) kw = do
- fromSomeVarValue SourceLineBuiltin (VarName "") =<< M.lookup kw args
+ fromSomeVarValue SourceLineBuiltin (LocalVarName (VarName "")) =<< M.lookup kw args
-getArgVars :: FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> [ (( VarName, [ Text ] ), SomeVarValue ) ]
+getArgVars :: FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> [ (( FqVarName, [ Text ] ), SomeVarValue ) ]
getArgVars (FunctionArguments args) kw = do
maybe [] svvVariables $ M.lookup kw args
builtinSend :: SomeVarValue
builtinSend = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $
- \_ args -> TestBlock [ Send (getArg args (Just "to")) (getArg args Nothing) ]
+ \_ args -> TestBlockStep EmptyTestBlock $ Send (getArg args (Just "to")) (getArg args Nothing)
where
atypes =
[ ( Just "to", SomeArgumentType (ContextDefault @Process) )
@@ -39,7 +45,7 @@ builtinSend = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes)
builtinFlush :: SomeVarValue
builtinFlush = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $
- \_ args -> TestBlock [ Flush (getArg args (Just "from")) (getArgMb args (Just "matching")) ]
+ \_ args -> TestBlockStep EmptyTestBlock $ Flush (getArg args (Just "from")) (getArgMb args (Just "matching"))
where
atypes =
[ ( Just "from", SomeArgumentType (ContextDefault @Process) )
@@ -48,7 +54,11 @@ builtinFlush = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes
builtinGuard :: SomeVarValue
builtinGuard = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton Nothing (SomeArgumentType (RequiredArgument @Bool))) $
- \sline args -> TestBlock [ Guard sline (getArgVars args Nothing) (getArg args Nothing) ]
+ \sline args -> TestBlockStep EmptyTestBlock $ Guard sline (getArgVars args Nothing) (getArg args Nothing)
+
+builtinMultiplyTimeout :: SomeVarValue
+builtinMultiplyTimeout = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton (Just "by") (SomeArgumentType (RequiredArgument @Scientific))) $
+ \_ args -> TestBlockStep EmptyTestBlock $ CreateObject (Proxy @MultiplyTimeout) (getArg args (Just "by"))
builtinWait :: SomeVarValue
-builtinWait = someConstValue $ TestBlock [ Wait ]
+builtinWait = someConstValue $ TestBlockStep EmptyTestBlock Wait
diff --git a/src/TestMode.hs b/src/TestMode.hs
new file mode 100644
index 0000000..c052fb9
--- /dev/null
+++ b/src/TestMode.hs
@@ -0,0 +1,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"
generated by cgit v1.2.3 (git 2.25.1) at 2025-07-02 05:49:26 +0000