erebos-tester 0.3.4 → 0.3.5
raw patch · 21 files changed
+1037/−337 lines, 21 files
Files
- CHANGELOG.md +9/−0
- README.md +52/−5
- erebos-tester.cabal +3/−12
- src/Config.hs +11/−0
- src/GDB.hs +2/−0
- src/Main.hs +43/−25
- src/Parser.hs +42/−9
- src/Parser/Core.hs +190/−34
- src/Parser/Expr.hs +156/−57
- src/Parser/Statement.hs +11/−9
- src/Process.hs +28/−7
- src/Process/Signal.hs +88/−0
- src/Run.hs +85/−22
- src/Run/Monad.hs +3/−1
- src/Script/Expr.hs +175/−62
- src/Script/Expr/Class.hs +19/−2
- src/Script/Shell.hs +1/−0
- src/Test.hs +10/−1
- src/Test/Builtins.hs +54/−36
- src/TestMode.hs +44/−51
- src/main.c +11/−4
CHANGELOG.md view
@@ -1,5 +1,14 @@ # Revision history for erebos-tester +## 0.3.5 -- 2026-05-31++* Added tags to group and filter tests.+* Initial support for polymorphic types.+* Added `concat` function and `++` operator to concatenate lists, and support for empty list expression.+* Added `killwith` clause to set a signal used to terminate `spawn`ed process.+* Added `pid` member to the `Process` type to get its system PID.+* Added command-line options to set path of tcpdump or disable its use.+ ## 0.3.4 -- 2026-01-15 * Show call stack in error messages.
README.md view
@@ -88,7 +88,11 @@ * `tool`: path to the test tool, which may be overridden by the `--tool` command-line option. * `tests`: glob pattern that expands to all the test script files that should be used.-* `timeout`: initial timeout for test steps like `expect`, given as `int` or `float`; defaults to `1` if not specified.+* `select`: tests or tags to be selected for running by default (if not provided, all tests will be executed);+ given as a single `string` or a list of `string`s.+* `exclude`: tests or tags to be excluded from running (unless requested explicitly on command line);+ given as a single `string` or a list of `string`s.+* `timeout`: initial timeout in seconds for test steps like `expect`, given as `int` or `float`; defaults to `1` if not specified. Script language ---------------@@ -210,6 +214,9 @@ `node` : Node on which the process is running. +`pid`+: PID of the corresponding system process, `0` if there is none.+ #### asset Represents an asset (file or directory), which can be used during test execution.@@ -219,6 +226,14 @@ `path` : Path to the asset valid during the test execution. +#### `Tag`++Tag, which can be assigned to a test using the `tag: <Tag>` declaration.++#### `Signal`++Type representing unix signals sent to processes. Values are `SIGINT`, `SIGTERM`, etc.+ #### list Lists are written using bracket notation:@@ -227,8 +242,14 @@ ``` List elements can be of any type, but all elements of a particular list must have the same type.--Used in the `for` command.+They can be concatenated using the `concat` function, which takes a list of lists as argument:+```+let list = concat [[1], [2, 3], [4]] # = [1, 2, 3, 4]+```+Or with the `++` operator:+```+let list = [1] ++ [2, 3] ++ [4] # = [1, 2, 3, 4]+``` ### Built-in commands @@ -245,7 +266,7 @@ Create a node on network `<network>` (or context network if omitted) and assign the new node to the variable `<name>`. ```-spawn as <name> [on (<node> | <network>)] [args <arguments>]+spawn as <name> [on (<node> | <network>)] [args <arguments>] [killwith <signal>] ``` Spawn a new test process on `<node>` or `<network>` (or one from context) and assign the new process to variable `<name>`.@@ -253,6 +274,7 @@ Extra `<arguments>` to the tool can be given as a list of strings using the `args` keyword. The process is terminated when the variable `<name>` goes out of scope (at the end of the block in which it was created) by closing its stdin.+If the `killwith` clause is present, it is also sent the given `<signal>` at that point. When the process fails to terminate successfully within a timeout, the test fails. ```@@ -516,7 +538,7 @@ ``` test:- spawn p+ spawn as p send to p "use-asset ${my_asset.path}" ``` @@ -531,6 +553,31 @@ export asset my_asset: path: ../path/to/file ```++### Tags++Tags are a way to refer to a group of tests, instead of needing to list all their names individually;+for example to mark broken tests, which can then be easily excluded from running until fixed.+Tags are declared using the `tag` keyword on the top level of a module,+and need to be `export`ed if they are to be referenced from outside of that module:++```+export tag Broken+```++Tags can be assigned to tests in a the test preamble before the first test steps+using `tag: <Tag>` declaration, which can also be given multiple times:++```+test SomeBrokenTest:+ tag: Broken+ tag: OtherTag+ spawn as p+ ...+```++Such tags can then be used instead of test names to select or exclude tests on+command line or in the configuration file. Optional dependencies
erebos-tester.cabal view
@@ -1,7 +1,7 @@ cabal-version: 3.0 name: erebos-tester-version: 0.3.4+version: 0.3.5 synopsis: Test framework with virtual network using Linux namespaces description: This framework is intended mainly for networking libraries/applications and@@ -21,11 +21,6 @@ README.md CHANGELOG.md -flag ci- description: Options for CI testing- default: False- manual: True- source-repository head type: git location: https://code.erebosprotocol.net/tester@@ -37,12 +32,6 @@ -threaded -no-hs-main - if flag(ci)- ghc-options:- -Werror- -- sometimes needed for backward/forward compatibility:- -Wno-error=unused-imports- main-is: Main.hs @@ -60,6 +49,7 @@ Parser.Statement Paths_erebos_tester Process+ Process.Signal Run Run.Monad Sandbox@@ -99,6 +89,7 @@ MultiParamTypeClasses MultiWayIf OverloadedStrings+ QuantifiedConstraints RankNTypes RecordWildCards ScopedTypeVariables
src/Config.hs view
@@ -9,6 +9,7 @@ import Data.ByteString.Lazy qualified as BS import Data.Scientific+import Data.Text (Text) import Data.Text qualified as T import Data.YAML @@ -21,6 +22,8 @@ { configDir :: FilePath , configTool :: Maybe FilePath , configTests :: [ Pattern ]+ , configSelect :: Maybe [ Text ]+ , configExclude :: [ Text ] , configTimeout :: Maybe Scientific } deriving (Show)@@ -33,6 +36,14 @@ , m .:? "tests" .!= [] -- list of patterns ] )+ configSelect <- foldr1 (<|>)+ [ fmap (Just . (: [])) (m .: "select") -- single item+ , m .:? "select" -- list of items+ ]+ configExclude <- foldr1 (<|>)+ [ fmap (: []) (m .: "exclude") -- single item+ , m .:? "exclude" .!= [] -- list of items+ ] configTimeout <- fmap fromNumber <$> m .:! "timeout" return $ \configDir -> Config {..}
src/GDB.hs view
@@ -73,6 +73,7 @@ } pout <- liftIO $ newTVarIO [] ignore <- liftIO $ newTVarIO ( 0, [] )+ pid <- liftIO $ getPid handle let process = Process { procId = ProcessId (-2)@@ -83,6 +84,7 @@ , procIgnore = ignore , procKillWith = Nothing , procNode = undefined+ , procPid = pid } gdb <- GDB <$> pure process
src/Main.hs view
@@ -2,7 +2,7 @@ import Control.Monad -import Data.List+import Data.Char import Data.Maybe import Data.Text (Text) import Data.Text qualified as T@@ -20,10 +20,9 @@ import Config import Output+import Parser.Core import Process import Run-import Script.Module-import Test import TestMode import Util import Version@@ -37,6 +36,7 @@ , optShowHelp :: Bool , optShowVersion :: Bool , optTestMode :: Bool+ , optCmdlineTcpdump :: TcpdumpOption } defaultCmdlineOptions :: CmdlineOptions@@ -49,8 +49,15 @@ , optShowHelp = False , optShowVersion = False , optTestMode = False+ , optCmdlineTcpdump = TcpdumpAuto } +data TcpdumpOption+ = TcpdumpAuto+ | TcpdumpManual FilePath+ | TcpdumpOff++ options :: [ OptDescr (CmdlineOptions -> CmdlineOptions) ] options = [ Option ['T'] ["tool"]@@ -86,11 +93,17 @@ (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"+ (ReqArg (\str opts -> opts { optExclude = T.pack str : optExclude opts }) "<test|tag>")+ "exclude given test or test tag from execution" , Option [] ["wait"] (NoArg $ to $ \opts -> opts { optWait = True }) "wait at the end of each test"+ , Option [] [ "no-tcpdump" ]+ (NoArg (\opts -> opts { optCmdlineTcpdump = TcpdumpOff }))+ "do not run tcpdump to capture network traffic"+ , Option [] [ "tcpdump" ]+ (OptArg (\str opts -> opts { optCmdlineTcpdump = maybe TcpdumpAuto TcpdumpManual str }) "<path>")+ "use tcpdump to capture network traffic, at given <path> or found in PATH" , Option ['h'] ["help"] (NoArg $ \opts -> opts { optShowHelp = True }) "show this help and exit"@@ -179,29 +192,34 @@ | 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+ lm@LoadedModules {..} <- exitOnError =<< loadModules files - ok <- allM (runTest out (optTest opts) globalDefs) $+ let tfSelect = if null otests then Nothing else Just otests+ tfExclude = optExclude opts+ tfilter = maybe mempty testFilterFromConfig config <> TestFilter {..}+ tests <- exitOnError $ filterTests tfilter lm++ tcpdump <- case optCmdlineTcpdump opts of+ TcpdumpAuto -> findExecutable "tcpdump"+ TcpdumpManual path -> return (Just path)+ TcpdumpOff -> return Nothing++ let topts = (optTest opts)+ { optTcpdump = tcpdump+ }+ ok <- allM (runTest out topts lmGlobalDefs) $ concat $ replicate (optRepeat opts) tests when (not ok) exitFailure++exitOnError :: Either CustomTestError a -> IO a+exitOnError (Left err) = do+ hPutStrLn stderr $ capitalize $ showCustomTestError err+ exitFailure+ where+ capitalize (c : cs) = toUpper c : cs+ capitalize [] = []+exitOnError (Right x) = do+ return x foreign export ccall testerMain :: IO () testerMain :: IO ()
src/Parser.hs view
@@ -43,12 +43,35 @@ modify $ \s -> s { testContext = SomeExpr $ varExpr SourceLineBuiltin rootNetworkVar }- block (\name steps -> return $ Test name $ Scope <$> mconcat steps) header testStep+ href <- L.indentLevel+ testName <- header+ osymbol ":" <* eol <* scn++ ref <- L.indentGuard scn GT href+ testTags <- preamble ref+ testSteps <- fmap Scope <$> testBlock ref+ return Test {..}+ where header = do wsymbol "test" lexeme $ TL.toStrict <$> takeWhileP (Just "test name") (/=':') + preamble :: Pos -> TestParser [ Expr Tag ]+ preamble ref = fmap catMaybes $ many $ do+ void $ L.indentGuard scn EQ ref+ off <- stateOffset <$> getParserState+ name <- try $ identifier <* osymbol ":"+ <* ((eol >> mzero) <|> return ()) -- continue only if not on EOL+ case name of+ "tag" -> do+ Just <$> typedExpr FunctionTerm <* eol <* scn+ _ -> do+ registerParseError $ FancyError off $ S.singleton $ ErrorFail $+ "unexpected test metadata ‘" <> T.unpack name <> "’"+ takeWhileP Nothing (/= '\n') *> eol *> scn *> return Nothing++ parseDefinition :: Pos -> TestParser ( VarName, SomeExpr ) parseDefinition href = label "symbol definition" $ do def@( name, expr ) <- localState $ do@@ -67,7 +90,7 @@ SomeExpr <$> testBlock ref , do osymbol "="- someExpr <* eol+ someExpr FunctionTerm <* eol ] scn atypes' <- getInferredTypes atypes@@ -79,11 +102,9 @@ getInferredTypes atypes = forM atypes $ \( off, vname, tvar@(TypeVar tvarname) ) -> do let err msg = do registerParseError . FancyError off . S.singleton . ErrorFail $ T.unpack msg- return ( vname, SomeArgumentType (OptionalArgument @DynamicType) )+ return ( vname, SomeArgumentType OptionalArgument (ExprTypeForall (TypeVar "a") (ExprTypeVar (TypeVar "a"))) ) gets (M.lookup tvar . testTypeUnif) >>= \case- Just (ExprTypePrim (_ :: Proxy a)) -> return ( vname, SomeArgumentType (RequiredArgument @a) )- Just (ExprTypeVar (TypeVar tvar')) -> err $ "ambiguous type for ‘" <> textVarName vname <> " : " <> tvar' <> "’"- Just (ExprTypeFunction {}) -> err $ "unsupported function type of ‘" <> textVarName vname <> "’"+ Just t -> return ( vname, SomeArgumentType RequiredArgument t ) Nothing -> err $ "ambiguous type for ‘" <> textVarName vname <> " : " <> tvarname <> "’" replaceDynArgs :: forall a. Expr a -> TestParser (Expr a)@@ -95,7 +116,7 @@ go unif = \case ArgsApp args body -> ArgsApp (fmap replaceArgs args) body where- replaceArgs (SomeExpr (DynVariable tvar sline vname))+ replaceArgs (SomeExpr (DynVariable (ExprTypeVar tvar) sline vname)) | Just (ExprTypePrim (Proxy :: Proxy v)) <- M.lookup tvar unif = SomeExpr (Variable sline vname :: Expr v) replaceArgs (SomeExpr e) = SomeExpr (go unif e)@@ -125,13 +146,24 @@ modify $ \s -> s { testVars = ( name, ( GlobalVarName (testCurrentModuleName s) name, someExprType expr )) : testVars s } return ( name, expr ) +parseTag :: Pos -> TestParser ( VarName, SomeExpr )+parseTag _ = label "tag definition" $ do+ wsymbol "tag"+ name <- constrName+ void eol+ cmn <- gets testCurrentModuleName+ let expr = SomeExpr $ Pure $ Tag cmn name+ modify $ \s -> s { testVars = ( name, ( GlobalVarName cmn name, someExprType expr )) : testVars s }+ scn+ 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+ def@( name, _ ) <- parseDefinition ref <|> parseAsset ref <|> parseTag ref return [ ToplevelDefinition def, ToplevelExport name ] , do names <- listOf varName@@ -168,6 +200,7 @@ [ (: []) <$> parseTestDefinition , (: []) <$> toplevel ToplevelDefinition (parseDefinition pos1) , (: []) <$> toplevel ToplevelDefinition (parseAsset pos1)+ , (: []) <$> toplevel ToplevelDefinition (parseTag pos1) , parseExport , parseImport ]@@ -201,7 +234,7 @@ let initState = TestParserState { testSourcePath = path , testVars = concat- [ map (\(( mname, name ), value ) -> ( name, ( GlobalVarName mname name, someVarValueType value ))) $ M.toList builtins+ [ map (\(( mname, name ), value ) -> ( name, ( GlobalVarName mname name, someExprType value ))) $ M.toList builtins ] , testContext = SomeExpr (Undefined "void" :: Expr Void) , testNextTypeVar = 0
src/Parser/Core.hs view
@@ -1,6 +1,7 @@ module Parser.Core where import Control.Applicative+import Control.Arrow import Control.Monad import Control.Monad.State @@ -8,6 +9,7 @@ import Data.Map qualified as M import Data.Maybe import Data.Set qualified as S+import Data.Text (Text) import Data.Text qualified as T import Data.Text.Lazy qualified as TL import Data.Typeable@@ -18,6 +20,7 @@ import Network () import Script.Expr+import Script.Expr.Class import Script.Module import Test @@ -38,6 +41,8 @@ data CustomTestError = ModuleNotFound ModuleName | FileNotFound FilePath+ | TestNotFound Text (Maybe FilePath)+ | TestOrTagNotFound Text (Maybe FilePath) | ImportModuleError (ParseErrorBundle TestStream CustomTestError) deriving (Eq) @@ -50,16 +55,31 @@ compare (FileNotFound _) _ = LT compare _ (FileNotFound _) = GT + compare (TestNotFound a a') (TestNotFound b b') = compare ( a, a' ) ( b, b' )+ compare (TestNotFound _ _ ) _ = LT+ compare _ (TestNotFound _ _ ) = GT++ compare (TestOrTagNotFound a a') (TestOrTagNotFound b b') = compare ( a, a' ) ( b, b' )+ compare (TestOrTagNotFound _ _ ) _ = LT+ compare _ (TestOrTagNotFound _ _ ) = 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+ showErrorComponent err = showCustomTestError err +showCustomTestError :: CustomTestError -> String+showCustomTestError = \case+ ModuleNotFound name -> "module ‘" <> T.unpack (textModuleName name) <> "’ not found"+ FileNotFound path -> "file ‘" <> path <> "’ not found"+ TestNotFound tname mbpath -> "test ‘" <> T.unpack tname <> "’ not found" <> maybe "" (\path -> " in ‘" <> path <> "’") mbpath+ TestOrTagNotFound tname mbpath -> "test or tag ‘" <> T.unpack tname <> "’ not found" <> maybe "" (\path -> " in ‘" <> path <> "’") mbpath+ ImportModuleError bundle -> 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 @@ -104,18 +124,40 @@ ( 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))+ ExprTypeConstr1 _ -> return $ SomeExpr $ (Undefined "incomplete type" :: Expr DynamicType)+ ExprTypeFunction args (ExprTypePrim (_ :: Proxy a)) -> return $ SomeExpr $ (FunVariable args sline fqn :: Expr (FunctionType a))+ stype -> return $ SomeExpr $ DynVariable stype sline fqn 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+ ExprTypeConstr1 _ -> return $ SomeExpr $ (Undefined "incomplete type" :: Expr DynamicType)+ ExprTypeFunction args (ExprTypePrim (pa :: Proxy a)) -> do SomeExpr <$> unifyExpr off pa (FunVariable args sline fqn :: Expr (FunctionType a))+ stype -> return $ SomeExpr $ DynVariable stype sline fqn ++resolveKnownTypeVars :: SomeExprType -> TestParser SomeExprType+resolveKnownTypeVars stype = case stype of+ ExprTypePrim {} -> return stype+ ExprTypeConstr1 {} -> return stype+ ExprTypeVar tvar -> do+ gets (M.lookup tvar . testTypeUnif) >>= \case+ Just stype' -> resolveKnownTypeVars stype'+ Nothing -> return stype+ ExprTypeFunction args body -> ExprTypeFunction <$> resolveKnownTypeVars args <*> resolveKnownTypeVars body+ ExprTypeArguments args -> ExprTypeArguments <$> mapM (\(SomeArgumentType a t) -> SomeArgumentType a <$> resolveKnownTypeVars t) args+ ExprTypeApp ctor params -> do+ ctor' <- resolveKnownTypeVars ctor+ params' <- mapM resolveKnownTypeVars params+ return $ case ( ctor', params' ) of+ ( ExprTypeConstr1 (Proxy :: Proxy c'), [ ExprTypePrim (Proxy :: Proxy p') ] )+ -> ExprTypePrim (Proxy :: Proxy (c' p'))+ _ -> ExprTypeApp ctor' params'+ ExprTypeForall tvar inner -> ExprTypeForall tvar <$> resolveKnownTypeVars inner+ unify :: Int -> SomeExprType -> SomeExprType -> TestParser SomeExprType unify _ (ExprTypeVar aname) (ExprTypeVar bname) | aname == bname = do cur <- gets testTypeUnif@@ -171,38 +213,87 @@ | Just (Refl :: a :~: b) <- eqT = return res +unify _ res@(ExprTypeConstr1 (Proxy :: Proxy a)) (ExprTypeConstr1 (Proxy :: Proxy b))+ | Just (Refl :: a :~: b) <- eqT+ = return res++unify off (ExprTypeFunction args res) (ExprTypeFunction args' res')+ = ExprTypeFunction+ <$> unify off args args'+ <*> unify off res res'++unify off (ExprTypeApp ac aparams) (ExprTypeApp bc bparams)+ | length aparams == length bparams+ = do+ c <- unify off ac bc+ params <- zipWithM (unify off) aparams bparams+ return $ case ( c, params ) of+ ( ExprTypeConstr1 (Proxy :: Proxy c'), [ ExprTypePrim (Proxy :: Proxy p') ] )+ -> ExprTypePrim (Proxy :: Proxy (c' p'))+ _ -> ExprTypeApp c params++unify off a@(ExprTypeApp {}) (ExprTypePrim bproxy)+ | TypeDeconstructor1 c p <- matchTypeConstructor bproxy+ = unify off a (ExprTypeApp (ExprTypeConstr1 c) [ ExprTypePrim p ])++unify off (ExprTypePrim aproxy) b@(ExprTypeApp {})+ | TypeDeconstructor1 c p <- matchTypeConstructor aproxy+ = unify off (ExprTypeApp (ExprTypeConstr1 c) [ ExprTypePrim p ]) b+ unify off a b = do parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $- "couldn't match expected type `" <> textSomeExprType a <> "' with actual type `" <> textSomeExprType b <> "'"+ "couldn't match expected type ‘" <> textSomeExprType a <> "’ with actual type ‘" <> textSomeExprType b <> "’" +unifyArguments+ :: FunctionArguments SomeArgumentType+ -> FunctionArguments ( Int, SomeExpr )+ -> TestParser ( FunctionArguments SomeExpr, ( FunctionArguments SomeArgumentType, FunctionArguments ( Int, SomeExpr ) ) )+unifyArguments (FunctionArguments am) (FunctionArguments bm) = (toArgs *** (toArgs *** toArgs)) <$> go (M.toAscList am) (M.toAscList bm)+ where+ toArgs = FunctionArguments . M.fromAscList+ go [] bs = return ( [], ( [], bs ) )+ go as [] = return ( [], ( as, [] ) )+ go (a@( ak, SomeArgumentType _ at ) : as) (b@( bk, ( off, expr ) ) : bs)+ | ak < bk = second (first (a :)) <$> go as (b : bs)+ | bk < ak = second (second (b :)) <$> go (a : as) bs+ | otherwise = do+ expr' <- unifySomeExpr off at expr+ first (( ak, expr' ) :) <$> go as bs++ unifyExpr :: forall a b proxy. (ExprType a, ExprType b) => Int -> proxy a -> Expr b -> TestParser (Expr a) unifyExpr off pa expr = if | Just (Refl :: a :~: b) <- eqT -> return expr - | DynVariable tvar sline name <- expr+ | DynVariable stype sline name <- expr+ , ExprTypeForall qvar itype <- stype -> do- _ <- unify off (ExprTypePrim (Proxy :: Proxy a)) (ExprTypeVar tvar)+ tvar <- newTypeVar+ res <- unify off (ExprTypePrim (Proxy :: Proxy a)) $ renameVarInType qvar tvar itype+ rtype <- M.lookup tvar <$> gets testTypeUnif+ return $ ExposePrimType $ TypeApp res (fromMaybe (ExprTypeVar tvar) rtype) (Variable sline name)++ | DynVariable stype sline name <- expr+ -> do+ _ <- unify off (ExprTypePrim (Proxy :: Proxy a)) stype return $ Variable sline name - | Just (Refl :: FunctionType a :~: b) <- eqT+ | HidePrimType (_ :: Expr b') <- expr+ -> unifyExpr off pa (ExposePrimType expr :: Expr b')++ | HideFunType args (_ :: Expr (FunctionType b')) <- expr+ -> unifyExpr off pa (ExposeFunType args expr :: Expr (FunctionType b'))++ | TypeLambda tvar t f <- expr -> do- let FunctionArguments remaining = exprArgs expr- showType ( Nothing, SomeArgumentType atype ) = "`<" <> textExprType atype <> ">'"- showType ( Just (ArgumentKeyword kw), SomeArgumentType atype ) = "`" <> kw <> " <" <> textExprType atype <> ">'"- err = parseError . FancyError off . S.singleton . ErrorFail . T.unpack+ _ <- unify off (ExprTypePrim (Proxy :: Proxy a)) t+ Just (ExprTypePrim pt) <- M.lookup tvar <$> gets testTypeUnif+ unifyExpr off pa (f $ ExprTypePrim pt) - defaults <- fmap catMaybes $ forM (M.toAscList remaining) $ \case- arg@(_, SomeArgumentType RequiredArgument) -> err $ "missing " <> showType arg <> " argument"- (_, SomeArgumentType OptionalArgument) -> return Nothing- (kw, SomeArgumentType (ExprDefault def)) -> return $ Just ( kw, SomeExpr def )- (kw, SomeArgumentType atype@ContextDefault) -> do- SomeExpr context <- gets testContext- context' <- unifyExpr off atype context- return $ Just ( kw, SomeExpr context' )- sline <- getSourceLine- return (FunctionEval sline $ ArgsApp (FunctionArguments $ M.fromAscList defaults) expr)+ | Just (Refl :: FunctionType a :~: b) <- eqT+ -> evalRemainingArguments off (exprArgs expr) expr | Just (Refl :: DynamicType :~: b) <- eqT , Undefined msg <- expr@@ -212,9 +303,83 @@ | otherwise -> do parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $- "couldn't match expected type `" <> textExprType pa <> "' with actual type `" <> textExprType expr <> "'"+ "couldn't match expected type ‘" <> textExprType pa <> "’ with actual type ‘" <> textExprType expr <> "’" +evalRemainingArguments :: ExprType a => Int -> FunctionArguments SomeArgumentType -> Expr (FunctionType a) -> TestParser (Expr a)+evalRemainingArguments off (FunctionArguments remaining) expr = do+ let showType ( Nothing, SomeArgumentType _ stype ) = "‘<" <> textSomeExprType stype <> ">’"+ showType ( Just (ArgumentKeyword kw), SomeArgumentType _ stype ) = "‘" <> kw <> " <" <> textSomeExprType stype <> ">’"+ err = parseError . FancyError off . S.singleton . ErrorFail . T.unpack++ defaults <- fmap catMaybes $ forM (M.toAscList remaining) $ \case+ arg@( _, SomeArgumentType RequiredArgument _ ) -> err $ "missing " <> showType arg <> " argument"+ ( _, SomeArgumentType OptionalArgument _ ) -> return Nothing+ ( kw, SomeArgumentType (ExprDefault def) _ ) -> return $ Just ( kw, def )+ ( kw, SomeArgumentType ContextDefault (ExprTypePrim atype) ) -> do+ SomeExpr context <- gets testContext+ context' <- unifyExpr off atype context+ return $ Just ( kw, SomeExpr context' )+ ( _, SomeArgumentType ContextDefault _ ) -> err "non-primitive context requirement"+ sline <- getSourceLine+ return (FunctionEval sline $ ArgsApp (FunctionArguments $ M.fromAscList defaults) expr)+++unifySomeExpr :: Int -> SomeExprType -> SomeExpr -> TestParser SomeExpr+unifySomeExpr off stype sexpr@(SomeExpr (expr :: Expr a))+ | ExprTypePrim pa <- stype+ = SomeExpr <$> unifyExpr off pa expr++ | ExprTypeConstr1 {} <- stype+ = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ "unification with incomplete type"++ | ExprTypeVar tvar <- stype+ = do+ _ <- unify off (ExprTypeVar tvar) (someExprType sexpr)+ return sexpr++ | Just (Refl :: a :~: DynamicType) <- eqT+ , ExprTypeForall qvar itype <- someExprType sexpr+ = do+ tvar <- newTypeVar+ itype' <- unify off stype $ renameVarInType qvar tvar itype+ rtype <- M.lookup tvar <$> gets testTypeUnif+ return $ SomeExpr (TypeApp itype' (fromMaybe (ExprTypeVar tvar) rtype) expr)++ | ExprTypeFunction args res <- stype+ = case someExprType sexpr of+ ExprTypeFunction args' res' -> do+ _ <- unify off args args'+ _ <- unify off res res'+ return sexpr+ _ -> do+ _ <- unify off args (ExprTypeArguments mempty)+ SomeExpr expr' <- unifySomeExpr off res sexpr+ return $ SomeExpr $ FunctionAbstraction expr'++ | ExprTypeApp _ _ <- stype+ , ExprTypeFunction args' res' <- someExprType sexpr+ = do+ ( _, ( remaining, _ ) ) <- case args' of+ ExprTypeArguments args'' -> do+ unifyArguments args'' mempty+ _ -> do+ _ <- unify off (ExprTypeArguments mempty) args'+ return ( mempty, ( mempty, mempty ) )+ unify off stype res' >>= \case+ ExprTypePrim (Proxy :: Proxy r) | Just (Refl :: a :~: FunctionType r) <- eqT ->+ SomeExpr <$> evalRemainingArguments off remaining expr+ _ | Just (Refl :: a :~: FunctionType DynamicType) <- eqT ->+ SomeExpr <$> evalRemainingArguments off remaining expr+ _ ->+ error $ "expecting function type, got: " <> show (typeRep expr)++ | otherwise+ = do+ _ <- unify off stype (someExprType sexpr)+ return sexpr++ skipLineComment :: TestParser () skipLineComment = L.skipLineComment $ TL.pack "#" @@ -249,15 +414,6 @@ 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-block merge header item = L.indentBlock scn $ do- h <- header- choice- [ do symbol ":"- return $ L.IndentSome Nothing (merge h) item- , L.IndentNone <$> merge h []- ] listOf :: TestParser a -> TestParser [a] listOf item = do
src/Parser/Expr.hs view
@@ -4,17 +4,20 @@ varName, newVarName,- addVarName,+ addVarName, addVarNameType,+ constrName, + TermComplexity(..), someExpr, typedExpr, literal, variable,+ constructor, stringExpansion, - checkFunctionArguments, functionArguments,+ applyFunctionArguments, ) where import Control.Applicative (liftA2)@@ -76,13 +79,23 @@ return name addVarName :: forall a. ExprType a => Int -> TypedVarName a -> TestParser ()-addVarName off (TypedVarName name) = do+addVarName off tname = addVarNameType off tname (ExprTypePrim @a Proxy)++addVarNameType :: forall a. ExprType a => Int -> TypedVarName a -> SomeExprType -> TestParser ()+addVarNameType off (TypedVarName name) stype = do gets (lookup name . testVars) >>= \case 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, ( LocalVarName name, ExprTypePrim @a Proxy )) : testVars s }+ modify $ \s -> s { testVars = ( name, ( LocalVarName name, stype )) : testVars s } +constrName :: TestParser VarName+constrName = label "contructor name" $ do+ lexeme $ try $ do+ lead <- upperChar+ rest <- takeWhileP Nothing (\x -> isAlphaNum x || x == '_')+ return $ VarName $ TL.toStrict $ TL.fromChunks $ T.singleton lead : TL.toChunks rest+ someExpansion :: TestParser SomeExpr someExpansion = do void $ char '$'@@ -91,7 +104,7 @@ sline <- getSourceLine name <- VarName . TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_') lookupScalarVarExpr off sline name- , between (char '{') (char '}') someExpr+ , between (char '{') (char '}') (someExpr FunctionTerm) ] expressionExpansion :: forall a. ExprType a => Text -> TestParser (Expr a)@@ -149,7 +162,7 @@ regex :: TestParser (Expr Regex) regex = label "regular expression" $ lexeme $ do off <- stateOffset <$> getParserState- void $ char '/'+ void $ try $ char '/' <* notFollowedBy (char '=') -- TODO: better parsing rules for regexes let inner = choice [ char '/' >> return [] , takeWhile1P Nothing (`notElem` ['/', '\\', '$']) >>= \s -> (Pure (RegexPart (TL.toStrict s)) :) <$> inner@@ -175,40 +188,51 @@ list :: TestParser SomeExpr list = label "list" $ do symbol "["- SomeExpr x <- someExpr - let enumErr off = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $- "list range enumeration not defined for '" <> textExprType x <> "'"- let exprList = foldr (liftA2 (:)) (Pure [])- SomeExpr <$> choice+ choice [do symbol "]"- return $ exprList [x]-- ,do off <- stateOffset <$> getParserState- osymbol ".."- ExprEnumerator fromTo _ <- maybe (enumErr off) return $ exprEnumerator x- y <- typedExpr- symbol "]"- return $ fromTo <$> x <*> y+ tvar <- newTypeVar+ return $ SomeExpr $+ TypeLambda tvar (ExprTypeApp (ExprTypeConstr1 (Proxy :: Proxy [])) [ ExprTypeVar tvar ]) $+ \case+ (ExprTypePrim (Proxy :: Proxy a)) -> HidePrimType $ Pure ([] :: [ a ])+ _ -> Undefined "incomplete type" - ,do symbol ","- y <- typedExpr+ ,do SomeExpr x <- someExpr FunctionTerm+ let enumErr off = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $+ "list range enumeration not defined for ‘" <> textExprType x <> "’"+ let exprList = foldr (liftA2 (:)) (Pure []) - choice+ SomeExpr <$> choice [do symbol "]"- return $ exprList [x, y]+ return $ exprList [ x ] ,do off <- stateOffset <$> getParserState osymbol ".."- ExprEnumerator _ fromThenTo <- maybe (enumErr off) return $ exprEnumerator x- z <- typedExpr+ ExprEnumerator fromTo _ <- maybe (enumErr off) return $ exprEnumerator x+ y <- typedExpr FunctionTerm symbol "]"- return $ fromThenTo <$> x <*> y <*> z+ return $ fromTo <$> x <*> y ,do symbol ","- xs <- listOf typedExpr- symbol "]"- return $ exprList (x:y:xs)+ y <- typedExpr FunctionTerm++ choice+ [do symbol "]"+ return $ exprList [ x, y ]++ ,do off <- stateOffset <$> getParserState+ osymbol ".."+ ExprEnumerator _ fromThenTo <- maybe (enumErr off) return $ exprEnumerator x+ z <- typedExpr FunctionTerm+ symbol "]"+ return $ fromThenTo <$> x <*> y <*> z++ ,do symbol ","+ xs <- listOf (typedExpr FunctionTerm)+ symbol "]"+ return $ exprList (x : y : xs)+ ] ] ] @@ -231,16 +255,30 @@ y' <- unifyExpr off (Proxy @b) y return $ op <$> x' <*> y' -someExpr :: TestParser SomeExpr-someExpr = join inner <?> "expression"+data TermComplexity+ = SimpleTerm -- variable name, literal or more complex term in parentheses+ | FunctionTerm -- simple term or function call++someExpr :: TermComplexity -> TestParser SomeExpr+someExpr complexity = label "expression" $ do+ case complexity of+ SimpleTerm -> join termSimple+ FunctionTerm -> join inner where- inner = makeExprParser term table+ inner = makeExprParser termFunction table parens = between (symbol "(") (symbol ")") - term = label "term" $ choice+ termSimple = label "term" $ choice [ parens inner , return <$> literal+ , return <$> variable+ , return <$> constructor+ ]++ termFunction = label "term" $ choice+ [ parens inner+ , return <$> literal , return <$> functionCall ] @@ -264,6 +302,19 @@ , SomeBinOp ((-) @Scientific) ] ]+ , [ let tvar = TypeVar "a"+ targs = FunctionArguments $ M.fromList+ [ ( Just "$l", ( VarName "$l", SomeArgumentType RequiredArgument $ ExprTypeApp (ExprTypeConstr1 (Proxy @[])) [ ExprTypeVar tvar ]) )+ , ( Just "$r", ( VarName "$r", SomeArgumentType RequiredArgument $ ExprTypeApp (ExprTypeConstr1 (Proxy @[])) [ ExprTypeVar tvar ]) )+ ]+ in infixrExpr "++" $ SomeExpr $ TypeLambda tvar (ExprTypeFunction (ExprTypeArguments $ fmap snd targs) (ExprTypeApp (ExprTypeConstr1 (Proxy @[])) [ ExprTypeVar tvar ])) $ \case+ ExprTypePrim (Proxy :: Proxy a) ->+ HideFunType (fmap snd targs) $ ArgsReq targs $+ FunctionAbstraction $ ((++) @a)+ <$> (Variable SourceLineBuiltin $ LocalVarName $ VarName "$l")+ <*> (Variable SourceLineBuiltin $ LocalVarName $ VarName "$r")+ t -> Undefined ("ambiguous type ‘" <> T.unpack (textSomeExprType t) <> "’ for operator ‘++’") :: Expr DynamicType+ ] , [ binary' "==" (\op xs ys -> length xs == length ys && and (zipWith op xs ys)) $ [ SomeBinOp ((==) @Integer) , SomeBinOp ((==) @Scientific)@@ -307,6 +358,17 @@ choice $ map (\(SomeUnOp op) -> SomeExpr <$> applyUnOp off op e) ops + infixrExpr :: String -> SomeExpr -> Operator TestParser (TestParser SomeExpr)+ infixrExpr name fun = InfixR $ do+ void $ osymbol name+ return $ \p q -> do+ loff <- stateOffset <$> getParserState+ l <- p+ roff <- stateOffset <$> getParserState+ r <- q+ applyFunctionArguments (FunctionArguments $ M.fromList [ ( Just "$l", ( loff, l ) ), ( Just "$r", ( roff, r ) ) ]) fun++ binary :: String -> [SomeBinOp] -> Operator TestParser (TestParser SomeExpr) binary name = binary' name (undefined :: forall a b. (a -> b -> Void) -> [a] -> [b] -> Integer) -- use 'Void' that can never match actually used type to disable recursion@@ -347,10 +409,10 @@ region (const err) $ foldl1 (<|>) $ map (\(SomeBinOp op) -> tryop op (proxyOf e) (proxyOf f)) ops -typedExpr :: forall a. ExprType a => TestParser (Expr a)-typedExpr = do+typedExpr :: forall a. ExprType a => TermComplexity -> TestParser (Expr a)+typedExpr complexity = do off <- stateOffset <$> getParserState- SomeExpr e <- someExpr+ SomeExpr e <- someExpr complexity unifyExpr off Proxy e literal :: TestParser SomeExpr@@ -370,15 +432,19 @@ e <- lookupVarExpr off sline name recordSelector e <|> return e +constructor :: TestParser SomeExpr+constructor = label "constructor" $ do+ off <- stateOffset <$> getParserState+ sline <- getSourceLine+ name <- constrName+ lookupVarExpr off sline name+ functionCall :: TestParser SomeExpr functionCall = do sline <- getSourceLine- variable >>= \case- SomeExpr e'@(FunVariable argTypes _ _) -> do- let check = checkFunctionArguments argTypes- args <- functionArguments check someExpr literal (\poff -> lookupVarExpr poff sline . VarName)- return $ SomeExpr $ ArgsApp args e'- e -> return e+ fun <- variable <|> constructor+ args <- functionArguments (\poff _ e -> return ( poff, e )) (someExpr FunctionTerm) literal (\poff -> lookupVarExpr poff sline . VarName)+ applyFunctionArguments args fun recordSelector :: SomeExpr -> TestParser SomeExpr recordSelector (SomeExpr expr) = do@@ -394,21 +460,6 @@ applyRecordSelector m e (RecordSelector f) = SomeExpr $ App (AnnRecord m) (pure f) e -checkFunctionArguments :: FunctionArguments SomeArgumentType- -> Int -> Maybe ArgumentKeyword -> SomeExpr -> TestParser SomeExpr-checkFunctionArguments (FunctionArguments argTypes) poff kw sexpr@(SomeExpr expr) = do- case M.lookup kw argTypes of- Just (SomeArgumentType (_ :: ArgumentType expected)) -> do- 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 <> "’"- Nothing -> "unexpected parameter"- return sexpr-- functionArguments :: (Int -> Maybe ArgumentKeyword -> a -> TestParser b) -> TestParser a -> TestParser a -> (Int -> Text -> TestParser a) -> TestParser (FunctionArguments b) functionArguments check param lit promote = do args <- parseArgs True@@ -436,3 +487,51 @@ pparam = between (symbol "(") (symbol ")") param <|> lit checkAndInsert off kw x cont = M.insert kw <$> check off kw x <*> cont+++applyFunctionArguments :: FunctionArguments ( Int, SomeExpr ) -> SomeExpr -> TestParser SomeExpr+applyFunctionArguments (FunctionArguments margs) sexpr+ | M.null margs = return sexpr+applyFunctionArguments args sexpr@(SomeExpr (expr :: Expr a))+ | Just (Refl :: a :~: DynamicType) <- eqT+ , ExprTypeForall qvar itype <- someExprType sexpr+ = do+ tvar <- newTypeVar+ case renameVarInType qvar tvar itype of+ ExprTypeFunction (ExprTypeArguments args') res' -> do+ ( used, ( _, unexpectedArgs ) ) <- unifyArguments args' args+ unexpectedArguments unexpectedArgs+ t <- fromMaybe (ExprTypeVar tvar) . M.lookup tvar <$> gets testTypeUnif+ resolveKnownTypeVars res' >>= \case+ res''@(ExprTypePrim (Proxy :: Proxy r)) ->+ return $ SomeExpr (ArgsApp used (ExposeFunType args' (TypeApp res'' t expr) :: Expr (FunctionType r)))+ r ->+ return $ SomeExpr (ArgsApp used (ExposeFunType args' (TypeApp r t expr) :: Expr (FunctionType DynamicType)))+ _ -> do+ unexpectedArguments args+ return sexpr++ | otherwise+ = case someExprType sexpr of+ ExprTypeFunction (ExprTypeArguments args') res' -> do+ ( used, ( _, unexpectedArgs ) ) <- unifyArguments args' args+ unexpectedArguments unexpectedArgs+ resolveKnownTypeVars res' >>= \case+ ExprTypePrim (Proxy :: Proxy r)+ | Just (Refl :: a :~: FunctionType r) <- eqT+ -> return $ SomeExpr (ArgsApp used expr)+ _+ | Just (Refl :: a :~: FunctionType DynamicType) <- eqT+ -> return $ SomeExpr (ArgsApp used expr)+ _ ->+ error $ "expecting function type, got: " <> show (typeRep expr)+ _ -> do+ unexpectedArguments args+ return sexpr+ where+ unexpectedArguments (FunctionArguments amap) = do+ forM_ (M.toAscList amap) $ \( kw, ( poff, _ ) ) ->+ registerParseError $ FancyError poff $ S.singleton $ ErrorFail $ T.unpack $+ case kw of+ Just (ArgumentKeyword tkw) -> "unexpected parameter with keyword ‘" <> tkw <> "’"+ Nothing -> "unexpected parameter"
src/Parser/Statement.hs view
@@ -37,11 +37,11 @@ off <- stateOffset <$> getParserState name <- varName osymbol "="- SomeExpr e <- someExpr+ se@(SomeExpr e) <- someExpr FunctionTerm localState $ do let tname = TypedVarName name- addVarName off tname+ addVarNameType off tname (someExprType se) void $ eol body <- testBlock indent return $ Let line tname e (TestBlockStep EmptyTestBlock . Scope <$> body)@@ -55,7 +55,8 @@ wsymbol "in" loff <- stateOffset <$> getParserState- SomeExpr e <- someExpr+ tvar <- newTypeVar+ SomeExpr e <- unifySomeExpr loff (ExprTypeApp (ExprTypeConstr1 (Proxy :: Proxy [])) [ ExprTypeVar tvar ]) =<< someExpr FunctionTerm let err = parseError $ FancyError loff $ S.singleton $ ErrorFail $ T.unpack $ "expected a list, expression has type '" <> textExprType e <> "'" ExprListUnpacker unpack _ <- maybe err return $ exprListUnpacker e@@ -93,7 +94,7 @@ , do parseParamKeyword "on" mbnode- node <- typedExpr+ node <- typedExpr SimpleTerm parseParams ref mbpname (Just node) , do@@ -120,7 +121,7 @@ exprStatement = do ref <- L.indentLevel off <- stateOffset <$> getParserState- SomeExpr expr <- someExpr+ SomeExpr expr <- someExpr FunctionTerm choice [ continuePartial off ref expr , unifyExpr off Proxy expr@@ -136,8 +137,8 @@ blockOf indent $ do coff <- stateOffset <$> getParserState sline <- getSourceLine- args <- functionArguments (checkFunctionArguments (exprArgs fun)) someExpr literal (\poff -> lookupVarExpr poff sline . VarName)- let fun' = ArgsApp args fun+ args <- functionArguments (\poff _ e -> return ( poff, e )) (someExpr FunctionTerm) literal (\poff -> lookupVarExpr poff sline . VarName)+ SomeExpr fun' <- applyFunctionArguments args (SomeExpr fun) choice [ continuePartial coff indent fun' , unifyExpr coff Proxy fun'@@ -309,7 +310,7 @@ type ParamRep (ExprParam a) = Expr a parseParam _ = do off <- stateOffset <$> getParserState- SomeExpr e <- literal <|> variable <|> between (symbol "(") (symbol ")") someExpr+ SomeExpr e <- someExpr SimpleTerm unifyExpr off Proxy e showParamType _ = "<" ++ T.unpack (textExprType @a Proxy) ++ ">" paramExpr = fmap ExprParam@@ -393,7 +394,7 @@ wsymbol "with" off <- stateOffset <$> getParserState- ctx@(SomeExpr (_ :: Expr ctxe)) <- someExpr+ ctx@(SomeExpr (_ :: Expr ctxe)) <- someExpr SimpleTerm let expected = [ ExprTypePrim @Network Proxy , ExprTypePrim @Node Proxy@@ -430,6 +431,7 @@ <$> param "as" <*> (bimap fromExprParam fromExprParam <$> paramOrContext "on") <*> (maybe [] fromExprParam <$> param "args")+ <*> (maybe Nothing (Just . fromExprParam) <$> param "killwith") <*> innerBlockFun testExpect :: TestParser (Expr (TestBlock ()))
src/Process.hs view
@@ -2,6 +2,7 @@ Process(..), ProcessId(..), textProcId, ProcName(..), textProcName, unpackProcName,+ Signal, send, outProc, outProcName, lineReadingLoop,@@ -36,13 +37,14 @@ import System.FilePath import System.IO import System.IO.Error-import System.Posix.Signals+import System.Posix.Process import System.Process import {-# SOURCE #-} GDB import Network import Network.Ip import Output+import Process.Signal import Run.Monad import Script.Expr import Script.Expr.Class@@ -57,6 +59,7 @@ , procIgnore :: TVar ( Int, [ ( Int, Maybe Regex ) ] ) , procKillWith :: Maybe Signal , procNode :: Node+ , procPid :: Maybe Pid } instance Eq Process where@@ -67,7 +70,8 @@ textExprValue p = "<process:" <> textProcName (procName p) <> "#" <> textProcId (procId p) <> ">" recordMembers = map (first T.pack)- [ ("node", RecordSelector $ procNode)+ [ ( "node", RecordSelector $ procNode )+ , ( "pid", RecordSelector $ maybe (0 :: Integer) fromIntegral . procPid ) ] @@ -168,6 +172,7 @@ procOutput <- liftIO $ newTVarIO [] procIgnore <- liftIO $ newTVarIO ( 0, [] ) let procNode = either (const undefined) id target+ procPid <- liftIO $ getPid handle let process = Process {..} startProcessIOLoops process hout herr@@ -183,17 +188,33 @@ liftIO $ hClose $ procStdin p case procKillWith p of Nothing -> return ()- Just sig -> liftIO $ either getPid (\_ -> return Nothing) (procHandle p) >>= \case+ Just sig -> case procPid p of Nothing -> return () Just pid -> signalProcess sig pid liftIO $ void $ forkIO $ do 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++ status <- case procPid p of+ Nothing -> Just . Exited <$> liftIO (either waitForProcess (takeMVar . snd) (procHandle p))+ Just pid -> liftIO (getProcessStatus True False pid)+ case status of+ Just (Exited ExitSuccess) -> do+ return ()+ Just (Exited (ExitFailure code)) -> do+ outProc OutputChildFail p $ "exit code: " <> T.pack (show code)+ throwError Failed+ Just (Terminated sig _)+ | Just (Signal sig) == procKillWith p -> return ()+ | otherwise -> do+ outProc OutputChildFail p $ "killed with signal " <> T.pack (show sig)+ throwError Failed+ Just (Stopped sig) -> do+ outProc OutputChildFail p $ "stopped with signal " <> T.pack (show sig)+ throwError Failed+ Nothing -> do+ outProc OutputChildFail p $ "no exit status" throwError Failed closeTestProcess :: Process -> TestRun ()
+ src/Process/Signal.hs view
@@ -0,0 +1,88 @@+module Process.Signal (+ Signal(..),+ signalBuiltins,+ signalProcess,+) where++import Control.Monad.IO.Class++import Data.Text (Text)+import Data.Text qualified as T++import Script.Expr++import System.Posix qualified as Posix+++newtype Signal = Signal Posix.Signal+ deriving (Eq, Ord)++instance ExprType Signal where+ textExprType _ = "Signal"+ textExprValue (Signal sig)+ | sig == Posix.sigHUP = "SIGHUP"+ | sig == Posix.sigINT = "SIGINT"+ | sig == Posix.sigQUIT = "SIGQUIT"+ | sig == Posix.sigILL = "SIGILL"+ | sig == Posix.sigTRAP = "SIGTRAP"+ | sig == Posix.sigABRT = "SIGABRT"+ | sig == Posix.sigBUS = "SIGBUS"+ | sig == Posix.sigFPE = "SIGFPE"+ | sig == Posix.sigKILL = "SIGKILL"+ | sig == Posix.sigUSR1 = "SIGUSR1"+ | sig == Posix.sigSEGV = "SIGSEGV"+ | sig == Posix.sigUSR2 = "SIGUSR2"+ | sig == Posix.sigPIPE = "SIGPIPE"+ | sig == Posix.sigALRM = "SIGALRM"+ | sig == Posix.sigTERM = "SIGTERM"+ | sig == Posix.sigCHLD = "SIGCHLD"+ | sig == Posix.sigCONT = "SIGCONT"+ | sig == Posix.sigSTOP = "SIGSTOP"+ | sig == Posix.sigTSTP = "SIGTSTP"+ | sig == Posix.sigTTIN = "SIGTTIN"+ | sig == Posix.sigTTOU = "SIGTTOU"+ | sig == Posix.sigURG = "SIGURG"+ | sig == Posix.sigXCPU = "SIGXCPU"+ | sig == Posix.sigXFSZ = "SIGXFSZ"+ | sig == Posix.sigVTALRM = "SIGVTALRM"+ | sig == Posix.sigPROF = "SIGPROF"+ | sig == Posix.sigPOLL = "SIGPOLL"+ | sig == Posix.sigSYS = "SIGSYS"+ | otherwise = "<SIG_" <> T.pack (show sig) <> ">"+++signalBuiltins :: [ ( Text, SomeExpr ) ]+signalBuiltins = map (fmap $ SomeExpr . Pure)+ [ ( "SIGHUP", Signal Posix.sigHUP )+ , ( "SIGINT", Signal Posix.sigINT )+ , ( "SIGQUIT", Signal Posix.sigQUIT )+ , ( "SIGILL", Signal Posix.sigILL )+ , ( "SIGTRAP", Signal Posix.sigTRAP )+ , ( "SIGABRT", Signal Posix.sigABRT )+ , ( "SIGBUS", Signal Posix.sigBUS )+ , ( "SIGFPE", Signal Posix.sigFPE )+ , ( "SIGKILL", Signal Posix.sigKILL )+ , ( "SIGUSR1", Signal Posix.sigUSR1 )+ , ( "SIGSEGV", Signal Posix.sigSEGV )+ , ( "SIGUSR2", Signal Posix.sigUSR2 )+ , ( "SIGPIPE", Signal Posix.sigPIPE )+ , ( "SIGALRM", Signal Posix.sigALRM )+ , ( "SIGTERM", Signal Posix.sigTERM )+ , ( "SIGCHLD", Signal Posix.sigCHLD )+ , ( "SIGCONT", Signal Posix.sigCONT )+ , ( "SIGSTOP", Signal Posix.sigSTOP )+ , ( "SIGTSTP", Signal Posix.sigTSTP )+ , ( "SIGTTIN", Signal Posix.sigTTIN )+ , ( "SIGTTOU", Signal Posix.sigTTOU )+ , ( "SIGURG", Signal Posix.sigURG )+ , ( "SIGXCPU", Signal Posix.sigXCPU )+ , ( "SIGXFSZ", Signal Posix.sigXFSZ )+ , ( "SIGVTALRM", Signal Posix.sigVTALRM )+ , ( "SIGPROF", Signal Posix.sigPROF )+ , ( "SIGPOLL", Signal Posix.sigPOLL )+ , ( "SIGSYS", Signal Posix.sigSYS )+ ]+++signalProcess :: MonadIO m => Signal -> Posix.ProcessID -> m ()+signalProcess (Signal sig) pid = liftIO $ Posix.signalProcess sig pid
src/Run.hs view
@@ -1,8 +1,14 @@ module Run ( module Run.Monad, runTest,++ LoadedModules(..), loadModules, evalGlobalDefs,++ TestFilter(..),+ testFilterFromConfig,+ filterTests, ) where import Control.Applicative@@ -10,11 +16,12 @@ 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.Either+import Data.List import Data.Map qualified as M import Data.Maybe import Data.Proxy@@ -22,6 +29,7 @@ import Data.Set qualified as S import Data.Text (Text) import Data.Text qualified as T+import Data.Typeable import System.Directory import System.Exit@@ -30,14 +38,14 @@ import System.Posix.Signals import System.Process -import Text.Megaparsec (errorBundlePretty, showErrorComponent)-+import Config import GDB import Network import Network.Ip import Output import Parser import Process+import Process.Signal import Run.Monad import Sandbox import Script.Expr@@ -81,7 +89,7 @@ } tstate = TestState { tsGlobals = gdefs- , tsLocals = [ ( callStackVarName, someConstValue (CallStack []) ) ]+ , tsLocals = [ ( callStackVarName, SomeExpr $ Pure $ CallStack [] ) ] , tsNodePacketLoss = M.empty , tsDisconnectedUp = S.empty , tsDisconnectedBridge = S.empty@@ -142,26 +150,81 @@ return False -loadModules :: [ FilePath ] -> IO ( [ Module ], GlobalDefs )+data LoadedModules = LoadedModules+ { lmModules :: [ Module ]+ , lmTags :: [ ( ( ModuleName, Text ), [ Tag ] ) ]+ , lmGlobalDefs :: GlobalDefs+ }++loadModules :: [ ( FilePath, Maybe Text ) ] -> IO (Either CustomTestError LoadedModules) loadModules files = do- ( modules, allModules ) <- parseTestFiles files >>= \case- Right res -> do- return res+ parseTestFiles (map fst files) >>= \case+ Right ( modules, allModules ) -> return $ do+ lmModules <- forM (zip files modules) $ \( ( path, tsel ), m ) -> do+ tests <- case tsel of+ Nothing -> return $ moduleTests m+ Just tname+ | Just test <- find ((tname ==) . testName) (moduleTests m)+ -> return [ test ]+ | otherwise+ -> throwError $ TestNotFound tname (Just path)+ return m { moduleTests = tests }++ let lmGlobalDefs = evalGlobalDefs $ concatMap (\m -> map (first ( moduleName m, )) $ moduleDefinitions m) allModules+ evalTags test = map (\e -> runSimpleEval (eval e) lmGlobalDefs []) $ testTags test+ lmTags = concatMap (\Module {..} -> map (\test -> ( ( moduleName, testName test ), evalTags test )) moduleTests) lmModules+ Right $ LoadedModules {..} 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 )+ return $ Left err evalGlobalDefs :: [ (( ModuleName, VarName ), SomeExpr ) ] -> GlobalDefs-evalGlobalDefs exprs = fix $ \gdefs ->- builtins `M.union` M.fromList (map (fmap (evalSomeWith gdefs)) exprs)+evalGlobalDefs exprs = builtins `M.union` M.fromList exprs ++data TestFilter = TestFilter+ { tfSelect :: Maybe [ Text ]+ , tfExclude :: [ Text ]+ }++instance Semigroup TestFilter where+ a <> b+ | isJust (tfSelect b) = b+ | otherwise = a { tfExclude = tfExclude a <> tfExclude b }++instance Monoid TestFilter where+ mempty = TestFilter Nothing []++testFilterFromConfig :: Config -> TestFilter+testFilterFromConfig Config {..} = TestFilter+ { tfSelect = configSelect+ , tfExclude = configExclude+ }++filterTests :: TestFilter -> LoadedModules -> Either CustomTestError [ Test ]+filterTests TestFilter {..} LoadedModules {..} = do+ let allTests = concatMap (\m -> ( moduleName m, ) <$> moduleTests m) lmModules+ let evalTerm :: Text -> Either CustomTestError (Either Text Tag)+ evalTerm t =+ case find ((VarName t ==) . snd . fst) $ M.toList lmGlobalDefs of+ Just ( _, SomeExpr (expr :: Expr etype))+ | Just (Refl :: etype :~: Tag) <- eqT+ -> return $ Right $ runSimpleEval (eval expr) lmGlobalDefs []+ Nothing+ | Just _ <- find ((t ==) . testName . snd) allTests+ -> return $ Left t+ _ ->+ throwError $ TestOrTagNotFound t Nothing+ exclude <- partitionEithers <$> mapM evalTerm tfExclude+ let matches ( tnames, tags ) ( mname, test ) =+ testName test `elem` tnames || maybe False (any (`elem` tags)) (lookup ( mname, testName test ) lmTags)+ map snd . filter (not . matches exclude) <$> case tfSelect of+ Nothing -> return allTests+ Just tnames -> do+ selected <- partitionEithers <$> mapM evalTerm tnames+ return $ filter (matches selected) allTests++ runBlock :: TestBlock () -> TestRun () runBlock EmptyTestBlock = return () runBlock (TestBlockStep prev step) = runBlock prev >> runStep step@@ -185,7 +248,7 @@ DeclNode name net inner -> do withNode net (Left name) $ runStep . inner - Spawn tvname@(TypedVarName (VarName tname)) target args inner -> do+ Spawn tvname@(TypedVarName (VarName tname)) target args killWith inner -> do case target of Left net -> withNode net (Right tvname) go Right node -> go node@@ -197,7 +260,7 @@ cmd = T.unwords $ T.pack tool : map escape args escape = ("'" <>) . (<> "'") . T.replace "'" "'\\''" outProcName OutputChildExec pname cmd- withProcess (Right node) pname Nothing (T.unpack cmd) $ runStep . inner+ withProcess (Right node) pname killWith (T.unpack cmd) $ runStep . inner SpawnShell mbname node script inner -> do let tname | Just (TypedVarName (VarName name)) <- mbname = name@@ -253,8 +316,8 @@ withNetwork :: Network -> (Network -> TestRun a) -> TestRun a withNetwork net inner = do- tcpdump <- liftIO (findExecutable "tcpdump") >>= return . \case- Just path -> withProcess (Left net) ProcNameTcpdump (Just softwareTermination)+ tcpdump <- asks (optTcpdump . teOptions . fst) >>= return . \case+ Just path -> withProcess (Left net) ProcNameTcpdump (Just (Signal softwareTermination)) (path ++ " -i br0 -w './br0.pcap' -U -Z root") . const Nothing -> id
src/Run/Monad.hs view
@@ -52,7 +52,7 @@ data TestState = TestState { tsGlobals :: GlobalDefs- , tsLocals :: [ ( VarName, SomeVarValue ) ]+ , tsLocals :: [ ( VarName, SomeExpr ) ] , tsDisconnectedUp :: Set NetworkNamespace , tsDisconnectedBridge :: Set NetworkNamespace , tsNodePacketLoss :: Map NetworkNamespace Scientific@@ -63,6 +63,7 @@ , optProcTools :: [(ProcName, String)] , optTestDir :: FilePath , optTimeout :: Scientific+ , optTcpdump :: Maybe FilePath , optGDB :: Bool , optForce :: Bool , optKeep :: Bool@@ -75,6 +76,7 @@ , optProcTools = [] , optTestDir = ".test" , optTimeout = 1+ , optTcpdump = Nothing , optGDB = False , optForce = False , optKeep = False
src/Script/Expr.hs view
@@ -4,10 +4,12 @@ MonadEval(..), VariableDictionary, GlobalDefs, lookupVar, tryLookupVar, withVar, withTypedVar, eval, evalSome, evalSomeWith,+ runSimpleEval, FunctionType, DynamicType, ExprType(..), SomeExpr(..), TypeVar(..), SomeExprType(..), someExprType, textSomeExprType,+ renameTypeVar, renameVarInType, VarValue(..), SomeVarValue(..), svvVariables, svvArguments,@@ -55,12 +57,19 @@ 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)+ DynVariable :: SomeExprType -> SourceLine -> FqVarName -> Expr DynamicType+ FunVariable :: ExprType a => SomeExprType -> SourceLine -> FqVarName -> Expr (FunctionType a)+ OptVariable :: ExprType a => SourceLine -> FqVarName -> Expr (Maybe 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 => SourceLine -> Expr (FunctionType a) -> Expr a+ HidePrimType :: forall a. ExprType a => Expr a -> Expr DynamicType+ HideFunType :: forall a. ExprType a => FunctionArguments SomeArgumentType -> Expr (FunctionType a) -> Expr DynamicType+ ExposePrimType :: forall a. ExprType a => Expr DynamicType -> Expr a+ ExposeFunType :: forall a. ExprType a => FunctionArguments SomeArgumentType -> Expr DynamicType -> Expr (FunctionType a)+ TypeLambda :: TypeVar -> SomeExprType -> (SomeExprType -> Expr DynamicType) -> Expr DynamicType+ TypeApp :: SomeExprType {- result type -} -> SomeExprType {- type argument -} -> Expr DynamicType -> Expr DynamicType LambdaAbstraction :: ExprType a => TypedVarName a -> Expr b -> Expr (a -> b) Pure :: a -> Expr a App :: AppAnnotation b -> Expr (a -> b) -> Expr a -> Expr b@@ -97,10 +106,17 @@ e@Variable {} -> f e e@DynVariable {} -> f e e@FunVariable {} -> f e+ e@OptVariable {} -> 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 sline expr -> f $ FunctionEval sline (go expr)+ HidePrimType expr -> f $ HidePrimType $ go expr+ HideFunType args expr -> f $ HideFunType args $ go expr+ ExposePrimType expr -> f $ ExposePrimType $ go expr+ ExposeFunType args expr -> f $ ExposeFunType args $ go expr+ TypeLambda tvar stype efun -> TypeLambda tvar stype (go . efun)+ TypeApp restype arg expr -> TypeApp restype arg (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)@@ -116,19 +132,19 @@ askDictionary :: m VariableDictionary withDictionary :: (VariableDictionary -> VariableDictionary) -> m a -> m a -type GlobalDefs = Map ( ModuleName, VarName ) SomeVarValue+type GlobalDefs = Map ( ModuleName, VarName ) SomeExpr -type VariableDictionary = [ ( VarName, SomeVarValue ) ]+type VariableDictionary = [ ( VarName, SomeExpr ) ] -lookupVar :: MonadEval m => FqVarName -> m SomeVarValue+lookupVar :: MonadEval m => FqVarName -> m SomeExpr lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackFqVarName name ++ "'") return =<< tryLookupVar name -tryLookupVar :: MonadEval m => FqVarName -> m (Maybe SomeVarValue)+tryLookupVar :: MonadEval m => FqVarName -> m (Maybe SomeExpr) 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 ) : )+withVar name value = withDictionary (( name, SomeExpr (Pure value) ) : ) withTypedVar :: (MonadEval m, ExprType e) => TypedVarName e -> e -> m a -> m a withTypedVar (TypedVarName name) = withVar name@@ -169,14 +185,15 @@ Let _ (TypedVarName name) valExpr expr -> do val <- eval valExpr withVar name val $ eval expr- Variable _ name -> fromSomeVarValue (CallStack []) name =<< lookupVar name- DynVariable _ _ name -> fail $ "ambiguous type of ‘" <> unpackFqVarName name <> "’"- FunVariable _ _ name -> funFromSomeVarValue name =<< lookupVar name+ Variable _ name -> evalSomeExpr name =<< lookupVar name+ DynVariable _ _ name -> evalSomeExpr name =<< lookupVar name+ FunVariable _ _ name -> evalSomeExpr name =<< lookupVar name+ OptVariable _ name -> maybe (return Nothing) (fmap Just . evalSomeExpr name) =<< tryLookupVar name ArgsReq (FunctionArguments req) efun -> do gdefs <- askGlobalDefs dict <- askDictionary return $ FunctionType $ \stack (FunctionArguments args) ->- let used = M.intersectionWith (\value ( vname, _ ) -> ( vname, value )) args req+ let used = M.intersectionWith (\(SomeVarValue value) ( vname, _ ) -> ( vname, SomeExpr $ Pure $ vvFunction value (CallStack []) mempty )) args req FunctionType fun = runSimpleEval (eval efun) gdefs (toList used ++ dict) in fun stack $ FunctionArguments $ args `M.difference` req ArgsApp eargs efun -> do@@ -187,17 +204,38 @@ gdefs <- askGlobalDefs dict <- askDictionary return $ FunctionType $ \stack _ ->- runSimpleEval (eval expr) gdefs (( callStackVarName, someConstValue stack ) : filter ((callStackVarName /=) . fst) dict)+ runSimpleEval (eval expr) gdefs (( callStackVarName, SomeExpr (Pure stack) ) : filter ((callStackVarName /=) . fst) dict) FunctionEval sline efun -> do vars <- gatherVars efun- CallStack cs <- maybe (return $ CallStack []) (fromSomeVarValue (CallStack []) callStackFqVarName) =<< tryLookupVar callStackFqVarName+ CallStack cs <- maybe (return $ CallStack []) (evalSomeExpr callStackFqVarName) =<< tryLookupVar callStackFqVarName let cs' = CallStack (( sline, vars ) : cs) FunctionType fun <- withVar callStackVarName cs' $ eval efun return $ fun cs' mempty+ HidePrimType expr -> DynamicType <$> eval expr+ HideFunType _ expr -> DynamicType <$> eval expr+ ExposePrimType expr -> do+ DynamicType x <- eval expr+ case cast x of+ Just x' -> return x'+ n@Nothing -> fail $ "type error in expose primitive type result " <> show ( typeOf x, typeOf n )+ ExposeFunType _ expr -> do+ DynamicType x <- eval expr+ case cast x of+ Just x' -> return x'+ n@Nothing -> fail $ "type error in expose function type result " <> show ( typeOf x, typeOf n )+ TypeLambda _ _ f -> do+ gdefs <- askGlobalDefs+ dict <- askDictionary+ return $ DynamicType $ \t -> runSimpleEval (eval $ f t) gdefs dict+ TypeApp _ arg expr -> do+ DynamicType f <- eval expr+ case cast f of+ Just f' -> return (f' arg)+ n@Nothing -> fail $ "type error in type application " <> show ( typeOf f, typeOf n ) LambdaAbstraction (TypedVarName name) expr -> do gdefs <- askGlobalDefs dict <- askDictionary- return $ \x -> runSimpleEval (eval expr) gdefs (( name, someConstValue x ) : dict)+ return $ \x -> runSimpleEval (eval expr) gdefs (( name, SomeExpr $ Pure x ) : dict) Pure value -> return value App _ f x -> eval f <*> eval x Concat xs -> T.concat <$> mapM eval xs@@ -209,6 +247,13 @@ Undefined err -> fail err Trace expr -> Traced <$> gatherVars expr <*> eval expr +evalSomeExpr :: forall m a. (MonadEval m, ExprType a) => FqVarName -> SomeExpr -> m a+evalSomeExpr name (SomeExpr (e :: Expr b)) = do+ maybe (fail err) eval $ cast e+ where+ err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable ‘", textFqVarName name, T.pack "’ has type type ",+ textExprType @b Proxy ]+ evalToVarValue :: MonadEval m => Expr a -> m (VarValue a) evalToVarValue expr = do VarValue@@ -239,7 +284,7 @@ textExprType _ = "function type" textExprValue _ = "<function type>" -data DynamicType+data DynamicType = forall a. Typeable a => DynamicType a instance ExprType DynamicType where textExprType _ = "ambiguous type"@@ -253,41 +298,106 @@ data SomeExprType = forall a. ExprType a => ExprTypePrim (Proxy a)+ | forall a. ExprTypeConstr1 a => ExprTypeConstr1 (Proxy a) | ExprTypeVar TypeVar- | forall a. ExprType a => ExprTypeFunction (FunctionArguments SomeArgumentType) (Proxy a)+ | ExprTypeFunction SomeExprType SomeExprType+ | ExprTypeArguments (FunctionArguments SomeArgumentType)+ | ExprTypeApp SomeExprType [ SomeExprType ]+ | ExprTypeForall TypeVar SomeExprType 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)+ DynVariable stype _ _ -> stype+ e@(FunVariable args _ _) -> ExprTypeFunction args (ExprTypePrim (proxyOfFunctionType e))+ HidePrimType (_ :: Expr a) -> ExprTypePrim (Proxy @a)+ HideFunType args e -> ExprTypeFunction (ExprTypeArguments args) (ExprTypePrim (proxyOfFunctionType e))+ e@(ExposeFunType args _) -> ExprTypeFunction (ExprTypeArguments args) (ExprTypePrim (proxyOfFunctionType e))+ TypeLambda tvar stype _ -> ExprTypeForall tvar stype+ TypeApp stype _ _ -> stype - 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"+ ArgsReq args inner -> exprTypeFunction (fmap snd args) (go inner)+ ArgsApp (FunctionArguments used) inner+ | ExprTypeFunction (ExprTypeArguments (FunctionArguments args)) x <- go inner+ -> ExprTypeFunction (ExprTypeArguments (FunctionArguments (args `M.difference` used))) x+ FunctionAbstraction inner -> exprTypeFunction mempty (go inner)+ FunctionEval _ inner+ | ExprTypeFunction _ x <- go inner -> x + (_ :: Expr a) -> ExprTypePrim (Proxy @a)++ exprTypeFunction :: FunctionArguments SomeArgumentType -> SomeExprType -> SomeExprType+ exprTypeFunction args (ExprTypeFunction (ExprTypeArguments args') inner) = ExprTypeFunction (ExprTypeArguments (args <> args')) inner+ exprTypeFunction args inner = ExprTypeFunction (ExprTypeArguments args) inner+ proxyOfFunctionType :: Expr (FunctionType a) -> Proxy a proxyOfFunctionType _ = Proxy ++renameTypeVar :: TypeVar -> TypeVar -> Expr a -> Expr a+renameTypeVar a b = go+ where+ go :: Expr e -> Expr e+ go orig = case orig of+ Let sline vname x y -> Let sline vname (go x) (go y)+ Variable {} -> orig+ DynVariable stype sline name -> DynVariable (renameVarInType a b stype) sline name+ FunVariable {} -> orig+ OptVariable {} -> orig+ ArgsReq args body -> ArgsReq args (go body)+ ArgsApp args fun -> ArgsApp (fmap (renameTypeVarInSomeExpr a b) args) (go fun)+ FunctionAbstraction expr -> FunctionAbstraction (go expr)+ FunctionEval sline expr -> FunctionEval sline (go expr)+ HidePrimType expr -> HidePrimType (go expr)+ HideFunType args expr -> HideFunType args (go expr)+ ExposePrimType {} -> orig+ ExposeFunType {} -> orig+ TypeLambda tvar stype expr+ | tvar == a -> orig+ | tvar == b -> error "type var collision"+ | otherwise -> TypeLambda tvar (renameVarInType a b stype) (go . expr)+ TypeApp restype arg expr -> TypeApp (renameVarInType a b restype) (renameVarInType a b arg) (go expr)+ LambdaAbstraction vname expr -> LambdaAbstraction vname (go expr)+ Pure {} -> orig+ App ann f x -> App ann (go f) (go x)+ Concat xs -> Concat (map go xs)+ Regex xs -> Regex (map go xs)+ Undefined {} -> orig+ Trace expr -> Trace (go expr)++renameTypeVarInSomeExpr :: TypeVar -> TypeVar -> SomeExpr -> SomeExpr+renameTypeVarInSomeExpr a b (SomeExpr e) = SomeExpr (renameTypeVar a b e)++renameVarInType :: TypeVar -> TypeVar -> SomeExprType -> SomeExprType+renameVarInType a b = go+ where+ go orig = case orig of+ ExprTypePrim {} -> orig+ ExprTypeConstr1 {} -> orig+ ExprTypeVar tvar | tvar == a -> ExprTypeVar b+ | otherwise -> orig+ ExprTypeFunction args result -> ExprTypeFunction (go args) (go result)+ ExprTypeArguments args -> ExprTypeArguments (fmap (\(SomeArgumentType atype stype) -> SomeArgumentType atype (go stype)) args)+ ExprTypeApp c xs -> ExprTypeApp (go c) (map go xs)+ ExprTypeForall tvar stype+ | tvar == a -> orig+ | tvar == b -> error "type var collision"+ | otherwise -> ExprTypeForall tvar (go stype)++ textSomeExprType :: SomeExprType -> Text-textSomeExprType (ExprTypePrim p) = textExprType p-textSomeExprType (ExprTypeVar (TypeVar name)) = name-textSomeExprType (ExprTypeFunction _ r) = "function:" <> textExprType r+textSomeExprType = go []+ where+ go _ (ExprTypePrim p) = textExprType p+ go (x : _) (ExprTypeConstr1 c) = textExprTypeConstr1 c x+ go [] (ExprTypeConstr1 _) = "<incomplte type>"+ go _ (ExprTypeVar (TypeVar name)) = name+ go _ (ExprTypeFunction _ r) = "function:" <> textSomeExprType r+ go _ (ExprTypeArguments _) = "{…}"+ go _ (ExprTypeApp c xs) = go (map textSomeExprType xs) c+ go _ (ExprTypeForall (TypeVar name) ctype) = "∀" <> name <> "." <> go [] ctype data AsFunType a = forall b. (a ~ FunctionType b, ExprType b) => IsFunType@@ -346,7 +456,7 @@ someVarValueType :: SomeVarValue -> SomeExprType someVarValueType (SomeVarValue (VarValue _ args _ :: VarValue a)) | anull args = ExprTypePrim (Proxy @a)- | otherwise = ExprTypeFunction args (Proxy @a)+ | otherwise = ExprTypeFunction (ExprTypeArguments args) (ExprTypePrim (Proxy @a)) newtype ArgumentKeyword = ArgumentKeyword Text@@ -362,31 +472,26 @@ exprArgs = \case Let _ _ _ expr -> exprArgs expr Variable {} -> mempty- FunVariable args _ _ -> args+ FunVariable (ExprTypeArguments args) _ _ -> args+ FunVariable _ _ _ -> error "exprArgs: type-var 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+ ExposePrimType {} -> mempty+ ExposeFunType args _ -> args Pure {} -> error "exprArgs: pure" App {} -> error "exprArgs: app" Undefined {} -> error "exprArgs: undefined" -funFromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => FqVarName -> SomeVarValue -> m (FunctionType a)-funFromSomeVarValue name (SomeVarValue (VarValue _ args value :: VarValue b)) = do- maybe (fail err) return $ do- FunctionType <$> cast value- 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 SomeArgumentType = SomeArgumentType ArgumentType SomeExprType -data ArgumentType a+data ArgumentType = RequiredArgument | OptionalArgument- | ExprDefault (Expr a)+ | ExprDefault SomeExpr | ContextDefault @@ -406,18 +511,10 @@ helper :: forall b. Expr b -> m EvalTrace helper = \case Let _ (TypedVarName var) _ expr -> withDictionary (filter ((var /=) . fst)) $ helper expr- Variable _ var- | GlobalVarName {} <- var -> return []- | isInternalVar var -> return []- | otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var- DynVariable _ _ var- | GlobalVarName {} <- var -> return []- | isInternalVar var -> return []- | otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var- FunVariable _ _ var- | GlobalVarName {} <- var -> return []- | isInternalVar var -> return []- | otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var+ e@(Variable _ var) -> gatherLocalVar var e+ e@(DynVariable _ _ var) -> gatherLocalVar var e+ e@(FunVariable _ _ var) -> gatherLocalVar var e+ e@(OptVariable _ var) -> gatherLocalVar var e ArgsReq args expr -> withDictionary (filter ((`notElem` map fst (toList args)) . fst)) $ helper expr ArgsApp (FunctionArguments args) fun -> do v <- helper fun@@ -425,6 +522,12 @@ return $ concat (v : vs) FunctionAbstraction expr -> helper expr FunctionEval _ efun -> helper efun+ HidePrimType expr -> helper expr+ HideFunType _ expr -> helper expr+ ExposePrimType expr -> helper expr+ ExposeFunType _ expr -> helper expr+ TypeLambda {} -> return []+ TypeApp _ _ expr -> helper expr LambdaAbstraction (TypedVarName var) expr -> withDictionary (filter ((var /=) . fst)) $ helper expr Pure _ -> return [] e@(App (AnnRecord sel) _ x)@@ -441,6 +544,16 @@ Regex es -> concat <$> mapM helper es Undefined {} -> return [] Trace expr -> helper expr++ gatherLocalVar :: forall b. ExprType b => FqVarName -> Expr b -> m EvalTrace+ gatherLocalVar var expr+ | GlobalVarName {} <- var = return []+ | isInternalVar var = return []+ | otherwise = do+ gdefs <- askGlobalDefs+ dict <- askDictionary+ let mbVal = SomeVarValue . VarValue [] mempty . const . const <$> trySimpleEval (eval expr) gdefs dict+ return $ maybe [] (\x -> [ ( ( var, [] ), x ) ]) mbVal gatherSelectors :: forall b. Expr b -> Maybe ( FqVarName, [ Text ] ) gatherSelectors = \case
src/Script/Expr/Class.hs view
@@ -1,10 +1,13 @@ module Script.Expr.Class ( ExprType(..),+ ExprTypeConstr1(..),+ TypeDeconstructor(..), RecordSelector(..), ExprListUnpacker(..), ExprEnumerator(..), ) where +import Data.Kind import Data.Maybe import Data.Scientific import Data.Text (Text)@@ -16,6 +19,9 @@ textExprType :: proxy a -> Text textExprValue :: a -> Text + matchTypeConstructor :: proxy a -> TypeDeconstructor a+ matchTypeConstructor _ = NoTypeDeconstructor+ recordMembers :: [(Text, RecordSelector a)] recordMembers = [] @@ -31,7 +37,14 @@ exprEnumerator :: proxy a -> Maybe (ExprEnumerator a) exprEnumerator _ = Nothing +class (Typeable a, forall b. ExprType b => ExprType (a b)) => ExprTypeConstr1 (a :: Type -> Type) where+ textExprTypeConstr1 :: proxy a -> Text -> Text +data TypeDeconstructor a+ = NoTypeDeconstructor+ | forall c x. (ExprTypeConstr1 c, ExprType x, c x ~ a) => TypeDeconstructor1 (Proxy c) (Proxy x)++ data RecordSelector a = forall b. ExprType b => RecordSelector (a -> b) data ExprListUnpacker a = forall e. ExprType e => ExprListUnpacker (a -> [e]) (Proxy a -> Proxy e)@@ -74,11 +87,15 @@ textExprType _ = T.pack "void" textExprValue _ = T.pack "<void>" -instance ExprType a => ExprType [a] where- textExprType _ = "[" <> textExprType @a Proxy <> "]"+instance ExprType a => ExprType [ a ] where+ textExprType _ = textExprTypeConstr1 @[] Proxy (textExprType @a Proxy) textExprValue x = "[" <> T.intercalate ", " (map textExprValue x) <> "]"+ matchTypeConstructor _ = TypeDeconstructor1 Proxy Proxy exprListUnpacker _ = Just $ ExprListUnpacker id (const Proxy)++instance ExprTypeConstr1 [] where+ textExprTypeConstr1 _ x = "[" <> x <> "]" instance ExprType a => ExprType (Maybe a) where textExprType _ = textExprType @a Proxy <> "?"
src/Script/Shell.hs view
@@ -202,6 +202,7 @@ hClose pstderr let procKillWith = Nothing+ let procPid = Nothing let process = Process {..} startProcessIOLoops process hout herr
src/Test.hs view
@@ -1,5 +1,6 @@ module Test ( Test(..),+ Tag(..), TestStep(..), TestBlock(..), @@ -25,9 +26,17 @@ data Test = Test { testName :: Text+ , testTags :: [ Expr Tag ] , testSteps :: Expr (TestStep ()) } +data Tag = Tag ModuleName VarName+ deriving (Eq)++instance ExprType Tag where+ textExprType _ = "Tag"+ textExprValue (Tag mname vname) = "<tag:" <> textModuleName mname <> "." <> textVarName vname <> ">"+ data TestBlock a where EmptyTestBlock :: TestBlock () TestBlockStep :: TestBlock () -> TestStep a -> TestBlock a@@ -45,7 +54,7 @@ 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+ Spawn :: TypedVarName Process -> Either Network Node -> [ Text ] -> Maybe Signal -> (Process -> TestStep a) -> TestStep a SpawnShell :: Maybe (TypedVarName Process) -> Node -> ShellScript -> (Process -> TestStep a) -> TestStep a Send :: Process -> Text -> TestStep () Expect :: CallStack -> SourceLine -> Process -> Traced Regex -> Scientific -> [ TypedVarName Text ] -> ([ Text ] -> TestStep a) -> TestStep a
src/Test/Builtins.hs view
@@ -3,68 +3,86 @@ ) where import Data.Map qualified as M-import Data.Maybe import Data.Proxy import Data.Scientific import Data.Text (Text)+import Data.Text qualified as T import Process+import Process.Signal import Script.Expr import Test builtins :: GlobalDefs-builtins = M.fromList- [ fq "send" builtinSend- , fq "flush" builtinFlush- , fq "ignore" builtinIgnore- , fq "guard" builtinGuard- , fq "multiply_timeout" builtinMultiplyTimeout- , fq "wait" builtinWait+builtins = M.fromList $ concat+ [ [ fq "send" builtinSend+ , fq "flush" builtinFlush+ , fq "ignore" builtinIgnore+ , fq "guard" builtinGuard+ , fq "multiply_timeout" builtinMultiplyTimeout+ , fq "wait" builtinWait+ , fq "concat" builtinConcat+ ]+ , map (uncurry fq) signalBuiltins ] where fq name impl = (( ModuleName [ "$" ], VarName name ), impl ) -getArg :: ExprType a => FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> a-getArg args = fromMaybe (error "parameter mismatch") . getArgMb args+biVar :: ExprType a => Text -> Expr a+biVar = Variable SourceLineBuiltin . LocalVarName . VarName -getArgMb :: ExprType a => FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> Maybe a-getArgMb (FunctionArguments args) kw = do- fromSomeVarValue (CallStack []) (LocalVarName (VarName "")) =<< M.lookup kw args+biOpt :: ExprType a => Text -> Expr (Maybe a)+biOpt = OptVariable SourceLineBuiltin . LocalVarName . VarName -builtinSend :: SomeVarValue-builtinSend = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $- \_ args -> TestBlockStep EmptyTestBlock $ Send (getArg args (Just "to")) (getArg args Nothing)+biArgs :: [ ( Maybe ArgumentKeyword, a ) ] -> FunctionArguments ( VarName, a )+biArgs = FunctionArguments . M.fromList . map (\( kw, atype ) -> ( kw, ( VarName $ maybe "$0" (\(ArgumentKeyword tkw) -> "$" <> tkw) kw, atype ) ))++builtinSend :: SomeExpr+builtinSend = SomeExpr $ ArgsReq (biArgs atypes) $+ FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (Send <$> biVar "$to" <*> biVar "$0") where atypes =- [ ( Just "to", SomeArgumentType (ContextDefault @Process) )- , ( Nothing, SomeArgumentType (RequiredArgument @Text) )+ [ ( Just "to", SomeArgumentType ContextDefault (ExprTypePrim (Proxy @Process)) )+ , ( Nothing, SomeArgumentType RequiredArgument (ExprTypePrim (Proxy @Text)) ) ] -builtinFlush :: SomeVarValue-builtinFlush = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $- \_ args -> TestBlockStep EmptyTestBlock $ Flush (getArg args (Just "from")) (getArgMb args (Just "matching"))+builtinFlush :: SomeExpr+builtinFlush = SomeExpr $ ArgsReq (biArgs atypes) $+ FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (Flush <$> biVar "$from" <*> biOpt "$matching") where atypes =- [ ( Just "from", SomeArgumentType (ContextDefault @Process) )- , ( Just "matching", SomeArgumentType (OptionalArgument @Regex) )+ [ ( Just "from", SomeArgumentType ContextDefault (ExprTypePrim (Proxy @Process)) )+ , ( Just "matching", SomeArgumentType OptionalArgument (ExprTypePrim (Proxy @Regex)) ) ] -builtinIgnore :: SomeVarValue-builtinIgnore = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $- \_ args -> TestBlockStep EmptyTestBlock $ CreateObject (Proxy @IgnoreProcessOutput) ( getArg args (Just "from"), getArgMb args (Just "matching") )+builtinIgnore :: SomeExpr+builtinIgnore = SomeExpr $ ArgsReq (biArgs atypes) $+ FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (CreateObject (Proxy @IgnoreProcessOutput) <$> ((,) <$> biVar "$from" <*> biOpt "$matching")) where atypes =- [ ( Just "from", SomeArgumentType (ContextDefault @Process) )- , ( Just "matching", SomeArgumentType (OptionalArgument @Regex) )+ [ ( Just "from", SomeArgumentType ContextDefault (ExprTypePrim (Proxy @Process)) )+ , ( Just "matching", SomeArgumentType OptionalArgument (ExprTypePrim (Proxy @Regex)) ) ] -builtinGuard :: SomeVarValue-builtinGuard = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton Nothing (SomeArgumentType (RequiredArgument @Bool))) $- \stack args -> TestBlockStep EmptyTestBlock $ Guard stack (getArg args Nothing)+builtinGuard :: SomeExpr+builtinGuard = SomeExpr $+ ArgsReq (biArgs [ ( Nothing, SomeArgumentType RequiredArgument (ExprTypePrim (Proxy @Bool)) ) ]) $+ FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (Guard <$> Variable SourceLineBuiltin callStackFqVarName <*> biVar "$0") -builtinMultiplyTimeout :: SomeVarValue-builtinMultiplyTimeout = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton (Just "by") (SomeArgumentType (RequiredArgument @Scientific))) $- \_ args -> TestBlockStep EmptyTestBlock $ CreateObject (Proxy @MultiplyTimeout) (getArg args (Just "by"))+builtinMultiplyTimeout :: SomeExpr+builtinMultiplyTimeout = SomeExpr $ ArgsReq (biArgs $ [ ( Just "by", SomeArgumentType RequiredArgument (ExprTypePrim (Proxy @Scientific)) ) ]) $+ FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (CreateObject (Proxy @MultiplyTimeout) <$> biVar "$by") -builtinWait :: SomeVarValue-builtinWait = someConstValue $ TestBlockStep EmptyTestBlock Wait+builtinWait :: SomeExpr+builtinWait = SomeExpr $ Pure $ TestBlockStep EmptyTestBlock Wait++builtinConcat :: SomeExpr+builtinConcat = SomeExpr $ TypeLambda (TypeVar "a")+ (ExprTypeFunction+ (ExprTypeArguments $ FunctionArguments $ M.singleton Nothing $ SomeArgumentType RequiredArgument+ (ExprTypeApp (ExprTypeConstr1 (Proxy @[])) [ ExprTypeApp (ExprTypeConstr1 (Proxy @[])) [ ExprTypeVar (TypeVar "a") ] ] ))+ (ExprTypeApp (ExprTypeConstr1 (Proxy @[])) [ ExprTypeVar (TypeVar "a") ])+ ) $ \case+ ExprTypePrim (pa :: Proxy a) -> HideFunType (FunctionArguments $ M.singleton Nothing $ SomeArgumentType RequiredArgument (ExprTypePrim (Proxy :: Proxy [[ a ]]))) $+ ArgsReq (biArgs [ ( Nothing, SomeArgumentType RequiredArgument (ExprTypePrim pa) ) ]) $ FunctionAbstraction $ (concat :: [[ a ]] -> [ a ]) <$> biVar "$0"+ t -> Undefined ("ambiguous type ‘" <> T.unpack (textSomeExprType t) <> "’ for concat") :: Expr DynamicType
src/TestMode.hs view
@@ -9,7 +9,6 @@ import Control.Monad.Reader import Control.Monad.State -import Data.Bifunctor import Data.List import Data.Maybe import Data.Text (Text)@@ -26,7 +25,6 @@ import Parser import Run import Script.Expr-import Script.Module import Test @@ -37,15 +35,13 @@ } data TestModeState = TestModeState- { tmsModules :: [ Module ]- , tmsGlobals :: GlobalDefs+ { tmsModules :: Maybe LoadedModules , tmsNextTestNumber :: Int } initTestModeState :: TestModeState initTestModeState = TestModeState- { tmsModules = mempty- , tmsGlobals = mempty+ { tmsModules = Nothing , tmsNextTestNumber = 1 } @@ -86,14 +82,14 @@ runSingleTest test = do out <- asks tmiOutput num <- getNextTestNumber- globals <- gets tmsGlobals+ Just LoadedModules {..} <- gets tmsModules mbconfig <- asks tmiConfig let opts = defaultTestOptions- { optDefaultTool = fromMaybe "" $ configTool =<< mbconfig+ { optDefaultTool = fromMaybe "/bin/true" $ configTool =<< mbconfig , optTestDir = ".test" <> show num , optKeep = True }- liftIO (runTest out opts globals test)+ liftIO (runTest out opts lmGlobalDefs test) newtype CommandM a = CommandM (ReaderT TestModeInput (StateT TestModeState (ExceptT String IO)) a)@@ -112,30 +108,23 @@ [ ( "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+showError :: Text -> CustomTestError -> Command+showError prefix = \case+ ModuleNotFound moduleName -> do+ cmdOut $ prefix <> " module-not-found" <> textModuleName moduleName+ FileNotFound notFoundPath -> do+ cmdOut $ prefix <> " file-not-found " <> T.pack notFoundPath+ TestNotFound tname mbfile -> do+ cmdOut $ prefix <> " test-not-found " <> tname <> maybe "" ((" " <>) . T.pack) mbfile+ TestOrTagNotFound tname mbfile -> do+ cmdOut $ prefix <> " test-or-tag-not-found " <> tname <> maybe "" ((" " <>) . T.pack) mbfile+ ImportModuleError bundle -> do #if MIN_VERSION_megaparsec(9,7,0)- mapM_ (cmdOut . T.pack) $ lines $ errorBundlePrettyWith showParseError bundle+ mapM_ (cmdOut . T.pack) $ lines $ errorBundlePrettyWith showParseError bundle #endif- cmdOut $ "load-failed parse-error"+ cmdOut $ prefix <> " parse-error" where showParseError _ SourcePos {..} _ = concat [ "parse-error"@@ -144,31 +133,35 @@ , ":", show $ unPos sourceColumn ] +cmdLoad :: Command+cmdLoad = do+ [ path ] <- asks tmiParams+ liftIO (loadModules [ ( T.unpack path, Nothing ) ]) >>= \case+ Right modules -> do+ modify $ \s -> s { tmsModules = Just modules }+ cmdOut "load-done"+ Left err -> showError "load-failed" err+ cmdLoadConfig :: Command cmdLoadConfig = do Just config <- asks tmiConfig- ( modules, globalDefs ) <- liftIO $ loadModules =<< getConfigTestFiles config- modify $ \s -> s- { tmsModules = modules- , tmsGlobals = globalDefs- }- cmdOut "load-config-done"+ liftIO (getConfigTestFiles config >>= loadModules . (map (, Nothing ))) >>= \case+ Right modules -> do+ modify $ \s -> s { tmsModules = Just modules }+ cmdOut "load-config-done"+ Left err -> showError "load-config-failed" err cmdRun :: Command cmdRun = do- [ name ] <- asks tmiParams- 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"+ params <- asks tmiParams+ let ( select, exclude ) = fmap (map (T.drop 1)) $ partition (("^" /=) . T.take 1) params+ pfilter = (TestFilter (if select == [ "*" ] then Nothing else Just select) exclude)+ cfilter <- asks $ maybe mempty testFilterFromConfig . tmiConfig+ Just lm <- gets tmsModules+ case filterTests (cfilter <> pfilter) lm of+ Left err -> showError "run-failed" err+ Right tests -> do+ forM_ tests $ \test -> do+ res <- runSingleTest test+ cmdOut $ "run-test-result " <> testName test <> " " <> (if res then "done" else "failed")+ cmdOut "run-done"
src/main.c view
@@ -109,7 +109,7 @@ }; ret = mount_setattr( -1, "/run/new_root", AT_RECURSIVE, attr_ro, sizeof( * attr_ro ) ); if( ret < 0 ){- fprintf( stderr, "failed set new_root as read-only: %s\n", strerror( errno ));+ fprintf( stderr, "failed set sandbox root as read-only: %s\n", strerror( errno )); return 1; } @@ -118,17 +118,24 @@ }; ret = mount_setattr( -1, "/run/new_root/proc", AT_RECURSIVE, attr_rw, sizeof( * attr_rw ) ); if( ret < 0 ){- fprintf( stderr, "failed set new_root/proc as read-write: %s\n", strerror( errno ));+ fprintf( stderr, "failed set sandbox /proc as read-write: %s\n", strerror( errno )); return 1; } ret = mount_setattr( -1, "/run/new_root/tmp", AT_RECURSIVE, attr_rw, sizeof( * attr_rw ) ); if( ret < 0 ){- fprintf( stderr, "failed set new_root/tmp as read-write: %s\n", strerror( errno ));+ if( errno == EINVAL ){+ // Original /tmp is not a separate filesystem, so we can't just change the attributes+ ret = mount( "/tmp", "/run/new_root/tmp", NULL, MS_BIND, NULL );+ if( ret < 0 )+ fprintf( stderr, "failed to bind-mount original /tmp in sandbox as read-write: %s\n", strerror( errno ));+ } else {+ fprintf( stderr, "failed set sandbox /tmp as read-write: %s\n", strerror( errno ));+ } } ret = mount( "tmpfs", "/run/new_root/run", "tmpfs", 0, "size=4m" ); if( ret < 0 ){- fprintf( stderr, "failed to mount tmpfs on new_root/run: %s\n", strerror( errno ));+ fprintf( stderr, "failed to mount tmpfs on sandbox /run: %s\n", strerror( errno )); return 1; }