erebos-tester 0.2.4 → 0.3.0
raw patch · 22 files changed
+1736/−672 lines, 22 filesdep +clockdep −linux-namespacesdep ~basedep ~directorydep ~stm
Dependencies added: clock
Dependencies removed: linux-namespaces
Dependency ranges changed: base, directory, stm, template-haskell
Files
- CHANGELOG.md +14/−0
- README.md +112/−3
- erebos-tester.cabal +64/−73
- src/Main.hs +22/−7
- src/Network.hs +9/−3
- src/Network.hs-boot +0/−5
- src/Output.hs +18/−4
- src/Parser.hs +153/−29
- src/Parser/Core.hs +206/−13
- src/Parser/Expr.hs +166/−62
- src/Parser/Statement.hs +175/−105
- src/Process.hs +3/−2
- src/Run.hs +57/−93
- src/Run/Monad.hs +8/−8
- src/Script/Expr.hs +443/−0
- src/Script/Expr/Class.hs +62/−0
- src/Script/Module.hs +20/−0
- src/Script/Var.hs +56/−0
- src/Test.hs +18/−215
- src/Test/Builtins.hs +49/−5
- src/Wrapper.hs +0/−45
- src/main.c +81/−0
CHANGELOG.md view
@@ -1,5 +1,19 @@ # Revision history for erebos-tester +## 0.3.0 -- 2025-02-28++* User-defined functions+* Modules, exports and imports+* Added `ifname` member to the `node` type+* Added `>`, `>=`, `<=` and `<` operators for numbers+* Change "flush" command to take regex argument via "matching" keyword+* Change working directory of spawned process to node directory+* Use custom C main instead of wrapper binary for unshare(2) call.+* Fix regex check in flush command+* Time information in output+* Support for GHC up to 9.12+* Fail when test requested on command-line is not found+ ## 0.2.4 -- 2024-08-13 * Fix build with mtl-2.3
README.md view
@@ -178,8 +178,11 @@ Members: +`ifname`+: Name of the primary network interface of the node.+ `ip`-: String representation of node's IP address.+: String representation of the node primary IP address. `network` : The network which the node belogs to.@@ -204,7 +207,7 @@ Used in the `for` command. -### Build-in commands+### Built-in commands ``` subnet <name> [of <network>]@@ -248,10 +251,11 @@ Results of the captures are then assigned to the newly created variables as strings. ```-flush [from <proc>]+flush [from <proc>] [matching <regex>] ``` Flush memory of `<proc>` output, so no following `expect` command will match anything produced up to this point.+If the `matching` clause is used, discard only output lines matching `<regex>`. ``` guard <expr>@@ -313,6 +317,111 @@ ``` Wait for user input before continuing. Useful mostly for debugging or test development.+++### Functions++When calling a function, parameters are usually passed using argument keywords+(in the case of built-in commands, those keywords are typically prepositions+like `on`, `from`, etc.), and apart from those, there can be at most one+parameter passed without a keyword. This is done in order to avoid the need to+remember parameter order and to make the behavior of each call as clear as+possible, even without looking up the documentation.++To make the syntax unambiguous, the keywordless parameter can be passed as+a literal (number, string, etc.), or using parentheses. So this is ok:++```+expect /something/ from p+```++but if the regular expression is stored in a variable, the parameter needs to+be enclosed in parentheses:+```+expect (re) from p+```+or in a literal:+```+expect /$re/ from p+```++### Defining functions++Custom functions can be defined on the top level using `def` keyword, and with+the parameters either followed by `=` sign to return a value:+```+def quadruple of x = 4 * x+```++or followed by `:` to define test block:+```+def say_hello to p:+ send "hello" to p+ expect /hi/ from p+```++Those then can be invoked elsewhere:+```+test:+ spawn as p+ say_hello to p+```++When defining a function, the unnamed parameter, if any, must be enclosed in+parentheses:+```+def twice (x) = 2 * x+```++### Modules, exports and imports++Each test script file constitutes a module. As such, it can export definitions+for other modules to use, and import definitions from other modules. The name+of each module must match the filename with the file extension removed, and is+given using the `module` declaration. This declaration, if present, must be+given at the beginning of the file, before other declarations.++For example a file `test/foo.et` can start with:+```+module foo+```+This name is also implicitly assigned when the `module` declaration is omitted.++In case of a more complex hierarchy, individual parts are separated with `.`+and must match names of parent directories. E.g. a file `test/bar/baz.et`+can start with:++```+module bar.baz+```++Such declared hierarchy is then used to determine the root of the project in+order to find imported modules.++To export a definition from module, use `export` keyword before `def`:+```+export def say_hello to p:+ send "hello" to p+ expect /hi/ from p+```+or list the exported name in a standalone export declaration:+```+export say_hello++...++def say_hello to p:+ send "hello" to p+ expect /hi/ from p+```++To import module, use `import <name>` statement, which makes all the exported+definitions from the module `<name>` available in the local scope.+```+module bar.baz++import foo+``` Optional dependencies
erebos-tester.cabal view
@@ -1,7 +1,7 @@ cabal-version: 3.0 name: erebos-tester-version: 0.2.4+version: 0.3.0 synopsis: Test framework with virtual network using Linux namespaces description: This framework is intended mainly for networking libraries/applications and@@ -28,12 +28,14 @@ source-repository head type: git- location: git://erebosprotocol.net/tester+ location: https://code.erebosprotocol.net/tester -common common+executable erebos-tester ghc-options: -Wall -fdefer-typed-holes+ -threaded+ -no-hs-main if flag(ci) ghc-options:@@ -41,79 +43,67 @@ -- sometimes needed for backward/forward compatibility: -Wno-error=unused-imports - build-depends:- base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20 },--executable erebos-tester- import: common- ghc-options:- -- disable interval timer to avoid spawing thread that breaks unshare(CLONE_NEWUSER)- -with-rtsopts=-V0- if impl(ghc >= 9.8)- ghc-options:- -- no multithreading is allowed for unshare(CLONE_NEWUSER)- -single-threaded-- main-is: Wrapper.hs- -- other-modules:- -- other-extensions:- build-depends:- directory >=1.3 && <1.4,- filepath ^>= { 1.4.2.1, 1.5.2 },- linux-namespaces^>=0.1.3,- process ^>=1.6.9,- unix >=2.7 && <2.9,- hs-source-dirs: src- default-language: Haskell2010+ main-is:+ Main.hs -executable erebos-tester-core- import: common- ghc-options:- -threaded+ other-modules:+ Config+ GDB+ Network+ Network.Ip+ Output+ Parser+ Parser.Core+ Parser.Expr+ Parser.Statement+ Paths_erebos_tester+ Process+ Run+ Run.Monad+ Script.Expr+ Script.Expr.Class+ Script.Module+ Script.Var+ Test+ Test.Builtins+ Util+ Version+ Version.Git - main-is: Main.hs+ autogen-modules:+ Paths_erebos_tester - other-modules: Config- GDB- Network- Network.Ip- Output- Parser- Parser.Core- Parser.Expr- Parser.Statement- Paths_erebos_tester- Process- Run- Run.Monad- Test- Test.Builtins- Util- Version- Version.Git+ c-sources:+ src/main.c - autogen-modules: Paths_erebos_tester+ other-extensions:+ TemplateHaskell+ default-extensions:+ DefaultSignatures+ DeriveTraversable+ ExistentialQuantification+ FlexibleContexts+ FlexibleInstances+ GADTs+ GeneralizedNewtypeDeriving+ ImportQualifiedPost+ LambdaCase+ MultiParamTypeClasses+ MultiWayIf+ OverloadedStrings+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ TupleSections+ TypeApplications+ TypeFamilies+ TypeOperators - other-extensions: TemplateHaskell- default-extensions: ExistentialQuantification- FlexibleContexts- FlexibleInstances- GADTs- GeneralizedNewtypeDeriving- ImportQualifiedPost- LambdaCase- MultiParamTypeClasses- OverloadedStrings- RankNTypes- RecordWildCards- ScopedTypeVariables- TupleSections- TypeApplications- TypeFamilies- TypeOperators- build-depends:+ build-depends:+ base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20, 4.21 }, bytestring ^>= { 0.10, 0.11, 0.12 }, containers ^>= { 0.6.2.1, 0.7 },+ clock ^>= { 0.8.3 }, directory ^>=1.3.6.0, filepath ^>= { 1.4.2.1, 1.5.2 }, Glob >=0.10 && <0.11,@@ -125,10 +115,11 @@ process ^>=1.6.9, regex-tdfa ^>=1.3.1.0, scientific >=0.3 && < 0.4,- stm ^>=2.5.0.1,- template-haskell^>= { 2.17, 2.18, 2.19, 2.20, 2.21, 2.22 },+ stm ^>= { 2.5.0 },+ template-haskell^>= { 2.17, 2.18, 2.19, 2.20, 2.21, 2.22, 2.23 }, text ^>= { 1.2, 2.0, 2.1 }, th-compat >=0.1 && <0.2, unix >=2.7 && <2.9,- hs-source-dirs: src- default-language: Haskell2010++ hs-source-dirs: src+ default-language: Haskell2010
src/Main.hs view
@@ -2,8 +2,10 @@ import Control.Monad +import Data.Bifunctor+import Data.List import Data.Maybe-import qualified Data.Text as T+import Data.Text qualified as T import Text.Read (readMaybe) @@ -22,6 +24,7 @@ import Parser import Process import Run+import Script.Module import Test import Util import Version@@ -148,12 +151,24 @@ Nothing -> queryTerminal (Fd 1) out <- startOutput (optVerbose opts) useColor - tests <- forM files $ \(path, mbTestName) -> do- Module { .. } <- parseTestFile path- return $ case mbTestName of- Nothing -> moduleTests- Just name -> filter ((==name) . testName) moduleTests+ ( modules, allModules ) <- parseTestFiles $ map fst files+ tests <- 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 - ok <- allM (runTest out $ optTest opts) $+ let globalDefs = evalGlobalDefs $ concatMap (\m -> map (first ( moduleName m, )) $ moduleDefinitions m) allModules++ ok <- allM (runTest out (optTest opts) globalDefs) $ concat $ replicate (optRepeat opts) $ concat tests when (not ok) exitFailure++foreign export ccall testerMain :: IO ()+testerMain :: IO ()+testerMain = main
src/Network.hs view
@@ -5,6 +5,7 @@ NodeName(..), textNodeName, unpackNodeName, nextNodeName, + rootNetworkVar, newInternet, delInternet, newSubnet, newNode,@@ -25,7 +26,8 @@ import System.Process import Network.Ip-import Test+import Script.Expr+import Script.Expr.Class {- NETWORK STRUCTURE@@ -107,10 +109,14 @@ 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 ) ] ++rootNetworkVar :: TypedVarName Network+rootNetworkVar = TypedVarName (VarName "$ROOT_NET") nextPrefix :: IpPrefix -> [Word8] -> Word8 nextPrefix _ used = maximum (0 : used) + 1
− src/Network.hs-boot
@@ -1,5 +0,0 @@-module Network where--data Network-data Node-data NodeName
src/Output.hs view
@@ -2,6 +2,7 @@ Output, OutputType(..), MonadOutput(..), startOutput,+ resetOutputTime, outLine, outPromptGetLine, outPromptGetLineCompletion,@@ -19,10 +20,14 @@ import System.Console.Haskeline import System.Console.Haskeline.History+import System.Clock +import Text.Printf+ data Output = Output { outState :: MVar OutputState , outConfig :: OutputConfig+ , outStartedAt :: MVar TimeSpec } data OutputConfig = OutputConfig@@ -52,10 +57,16 @@ getOutput = ask startOutput :: Bool -> Bool -> IO Output-startOutput outVerbose outUseColor = Output- <$> newMVar OutputState { outPrint = TL.putStrLn, outHistory = emptyHistory }- <*> pure OutputConfig { .. }+startOutput outVerbose outUseColor = do+ outState <- newMVar OutputState { outPrint = TL.putStrLn, outHistory = emptyHistory }+ outConfig <- pure OutputConfig {..}+ outStartedAt <- newMVar =<< getTime Monotonic+ return Output {..} +resetOutputTime :: Output -> IO ()+resetOutputTime Output {..} = do+ modifyMVar_ outStartedAt . const $ getTime Monotonic+ outColor :: OutputType -> Text outColor OutputChildStdout = T.pack "0" outColor OutputChildStderr = T.pack "31"@@ -97,9 +108,12 @@ outLine :: MonadOutput m => OutputType -> Maybe Text -> Text -> m () outLine otype prompt line = ioWithOutput $ \out -> when (outVerbose (outConfig out) || printWhenQuiet otype) $ 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 ]
src/Parser.hs view
@@ -1,74 +1,198 @@ {-# OPTIONS_GHC -Wno-orphans #-} module Parser (- parseTestFile,+ parseTestFiles, ) where import Control.Monad import Control.Monad.State-import Control.Monad.Writer +import Data.IORef+import Data.Map qualified as M import Data.Maybe+import Data.Proxy import Data.Set qualified as S import Data.Text qualified as T import Data.Text.Lazy qualified as TL import Data.Text.Lazy.IO qualified as TL+import Data.Void import Text.Megaparsec hiding (State) 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 Network import Parser.Core import Parser.Expr import Parser.Statement+import Script.Expr+import Script.Module import Test import Test.Builtins -parseTestDefinition :: TestParser ()+parseTestDefinition :: TestParser Toplevel parseTestDefinition = label "test definition" $ toplevel ToplevelTest $ do- block (\name steps -> return $ Test name $ concat steps) header testStep- where header = do- wsymbol "test"- lexeme $ TL.toStrict <$> takeWhileP (Just "test name") (/=':')+ localState $ do+ modify $ \s -> s+ { testContext = SomeExpr $ varExpr SourceLineBuiltin rootNetworkVar+ }+ block (\name steps -> return $ Test name $ mconcat steps) header testStep+ where+ header = do+ wsymbol "test"+ lexeme $ TL.toStrict <$> takeWhileP (Just "test name") (/=':') +parseDefinition :: TestParser ( VarName, SomeExpr )+parseDefinition = label "symbol definition" $ do+ def@( name, expr ) <- localState $ L.indentBlock scn $ 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, ( LocalVarName vname, ExprTypeVar tvar )) : testVars s }+ return ( off, vname, tvar )+ choice+ [ do+ osymbol ":"+ let finish steps = do+ atypes' <- getInferredTypes atypes+ ( name, ) . SomeExpr . ArgsReq atypes' . FunctionAbstraction <$> replaceDynArgs (mconcat steps)+ return $ L.IndentSome Nothing finish testStep+ , do+ osymbol "="+ SomeExpr (expr :: Expr e) <- someExpr+ atypes' <- getInferredTypes atypes+ L.IndentNone . ( name, ) . SomeExpr . ArgsReq atypes' . FunctionAbstraction <$> replaceDynArgs expr+ ]+ 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+ let err msg = do+ registerParseError . FancyError off . S.singleton . ErrorFail $ T.unpack msg+ return ( vname, SomeArgumentType (OptionalArgument @DynamicType) )+ 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 <> "’"+ Nothing -> err $ "ambiguous type for ‘" <> textVarName vname <> " : " <> tvarname <> "’"++ replaceDynArgs :: forall a. Expr a -> TestParser (Expr a)+ replaceDynArgs expr = do+ unif <- gets testTypeUnif+ return $ mapExpr (go unif) expr+ where+ go :: forall b. M.Map TypeVar SomeExprType -> Expr b -> Expr b+ go unif = \case+ ArgsApp args body -> ArgsApp (fmap replaceArgs args) body+ where+ replaceArgs (SomeExpr (DynVariable 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)+ e -> e++parseExport :: TestParser [ Toplevel ]+parseExport = label "export declaration" $ toplevel id $ do+ wsymbol "export"+ choice+ [ do+ def@( name, _ ) <- parseDefinition+ 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) <- listen $ many $ choice- [ parseTestDefinition+ modify $ \s -> s { testCurrentModuleName = moduleName }+ toplevels <- fmap concat $ many $ choice+ [ (: []) <$> parseTestDefinition+ , (: []) <$> toplevel ToplevelDefinition parseDefinition+ , parseExport+ , parseImport ]- let moduleTests = catMaybes $ map (\case ToplevelTest x -> Just x; {- _ -> Nothing -}) toplevels+ 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 { .. }+ 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 RootNetwork- }- (res, _) = flip evalState initState $ runWriterT $ runParserT (parseTestModule absPath) path content+parseTestFiles :: [ FilePath ] -> IO ( [ Module ], [ Module ] )+parseTestFiles paths = do+ parsedModules <- newIORef []+ requestedModules <- reverse <$> foldM (go parsedModules) [] paths+ allModules <- map snd <$> readIORef parsedModules+ return ( requestedModules, allModules )+ where+ go parsedModules res path = do+ let moduleName = error "current module name should be set at the beginning of parseTestModule"+ parseTestFile parsedModules moduleName path >>= \case+ Left (ImportModuleError bundle) -> do+ putStr (errorBundlePretty bundle)+ exitFailure+ Left err -> do+ putStr (showErrorComponent err)+ exitFailure+ Right cur -> do+ return $ cur : res - case res of- Left err -> putStr (errorBundlePretty err) >> exitFailure- Right testModule -> return testModule+parseTestFile :: IORef [ ( FilePath, Module ) ] -> ModuleName -> FilePath -> IO (Either CustomTestError Module)+parseTestFile parsedModules moduleName path = do+ absPath <- makeAbsolute path+ (lookup absPath <$> readIORef parsedModules) >>= \case+ Just found -> return $ Right found+ Nothing -> do+ let initState = TestParserState+ { 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 = moduleName+ , testParseModule = \(ModuleName current) mname@(ModuleName imported) -> do+ let projectRoot = iterate takeDirectory absPath !! length current+ parseTestFile parsedModules 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 path 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 $ ModuleNotFound moduleName
src/Parser/Core.hs view
@@ -1,38 +1,211 @@ module Parser.Core where +import Control.Applicative import Control.Monad import Control.Monad.State-import Control.Monad.Writer -import Data.Text (Text)-import qualified Data.Text.Lazy as TL-import Data.Void+import Data.Map (Map)+import Data.Map qualified as M+import Data.Maybe+import Data.Set qualified as S+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Typeable 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 -type TestParser = ParsecT Void TestStream (WriterT [ Toplevel ] (State TestParserState))+newtype TestParser a = TestParser (StateT TestParserState (ParsecT CustomTestError TestStream IO) a)+ deriving+ ( Functor, Applicative, Alternative, Monad+ , MonadState TestParserState+ , MonadPlus+ , MonadFail+ , MonadParsec CustomTestError TestStream+ ) type TestStream = TL.Text +type TestParseError = ParseError TestStream CustomTestError++data CustomTestError+ = ModuleNotFound ModuleName+ | ImportModuleError (ParseErrorBundle TestStream CustomTestError)+ deriving (Eq)++instance Ord CustomTestError where+ compare (ModuleNotFound a) (ModuleNotFound b) = compare a b+ compare (ModuleNotFound _) _ = LT+ compare _ (ModuleNotFound _) = 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 (ImportModuleError bundle) = "error parsing imported module:\n" <> errorBundlePretty bundle++runTestParser :: String -> TestStream -> TestParserState -> TestParser a -> IO (Either (ParseErrorBundle TestStream CustomTestError) a)+runTestParser path content initState (TestParser parser) = flip (flip runParserT path) content . flip evalStateT initState $ parser+ data Toplevel = ToplevelTest Test+ | ToplevelDefinition ( VarName, SomeExpr )+ | ToplevelExport VarName+ | ToplevelImport ( ModuleName, VarName ) data TestParserState = TestParserState- { testVars :: [(VarName, SomeExprType)]+ { testVars :: [ ( VarName, ( FqVarName, SomeExprType )) ] , testContext :: SomeExpr+ , testNextTypeVar :: Int+ , testTypeUnif :: Map TypeVar SomeExprType+ , testCurrentModuleName :: ModuleName+ , testParseModule :: ModuleName -> ModuleName -> IO (Either CustomTestError Module) } -textSomeExprType :: SomeExprType -> Text-textSomeExprType (SomeExprType p) = textExprType p+newTypeVar :: TestParser TypeVar+newTypeVar = do+ idx <- gets testNextTypeVar+ modify $ \s -> s { testNextTypeVar = idx + 1 }+ return $ TypeVar $ T.pack $ 'a' : show idx -lookupVarType :: VarName -> TestParser SomeExprType-lookupVarType name = maybe (fail $ "variable not in scope: '" ++ unpackVarName name ++ "'") return =<< gets (lookup name . testVars)+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+ 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+ ( 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+ cur <- gets testTypeUnif+ case M.lookup aname cur of+ Just a -> return a+ Nothing -> return (ExprTypeVar aname)++unify off (ExprTypeVar aname) (ExprTypeVar bname) = do+ cur <- gets testTypeUnif+ case ( M.lookup aname cur, M.lookup bname cur ) of+ ( Just a, Just b ) -> do+ c <- unify off a b+ modify $ \s -> s { testTypeUnif = M.insert aname c $ M.insert bname c $ cur }+ return c++ ( Just a, Nothing ) -> do+ modify $ \s -> s { testTypeUnif = M.insert bname a $ cur }+ return a++ ( Nothing, Just b ) -> do+ modify $ \s -> s { testTypeUnif = M.insert aname b $ cur }+ return b++ ( Nothing, Nothing ) -> do+ let b = ExprTypeVar bname+ modify $ \s -> s { testTypeUnif = M.insert aname b $ cur }+ return b++unify off (ExprTypeVar aname) b = do+ cur <- gets testTypeUnif+ case M.lookup aname cur of+ Just a -> do+ c <- unify off a b+ modify $ \s -> s { testTypeUnif = M.insert aname c $ cur }+ return c+ Nothing -> do+ modify $ \s -> s { testTypeUnif = M.insert aname b $ cur }+ return b++unify off a (ExprTypeVar bname) = do+ cur <- gets testTypeUnif+ case M.lookup bname cur of+ Just b -> do+ c <- unify off a b+ modify $ \s -> s { testTypeUnif = M.insert bname c $ cur }+ return c++ Nothing -> do+ modify $ \s -> s { testTypeUnif = M.insert bname a $ cur }+ return a++unify _ res@(ExprTypePrim (Proxy :: Proxy a)) (ExprTypePrim (Proxy :: Proxy b))+ | Just (Refl :: a :~: b) <- eqT+ = return res++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 <> "'"+++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+ -> do+ _ <- unify off (ExprTypePrim (Proxy :: Proxy a)) (ExprTypeVar tvar)+ return $ Variable sline name++ | Just (Refl :: FunctionType a :~: b) <- eqT+ -> 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++ 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' )+ return (FunctionEval $ ArgsApp (FunctionArguments $ M.fromAscList defaults) expr)++ | Just (Refl :: DynamicType :~: b) <- eqT+ , Undefined msg <- expr+ -> do+ return $ Undefined msg++ | otherwise+ -> do+ parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $+ "couldn't match expected type `" <> textExprType pa <> "' with actual type `" <> textExprType expr <> "'"++ skipLineComment :: TestParser () skipLineComment = L.skipLineComment $ TL.pack "#" @@ -61,11 +234,12 @@ localState inner = do s <- get x <- inner- put s+ s' <- get+ put s { testNextTypeVar = testNextTypeVar s', testTypeUnif = testTypeUnif s' } return x -toplevel :: (a -> Toplevel) -> TestParser a -> TestParser ()-toplevel f = tell . (: []) . f <=< L.nonIndented scn+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@@ -80,3 +254,22 @@ listOf item = do x <- item (x:) <$> choice [ symbol "," >> listOf item, return [] ]+++getSourceLine :: TestParser SourceLine+getSourceLine = do+ pstate <- statePosState <$> getParserState+ return $ SourceLine $ T.concat+ [ T.pack $ sourcePosPretty $ pstateSourcePos pstate+ , 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
src/Parser/Expr.hs view
@@ -1,5 +1,6 @@ module Parser.Expr ( identifier,+ parseModuleName, varName, newVarName,@@ -7,6 +8,11 @@ someExpr, typedExpr,+ literal,+ variable,++ checkFunctionArguments,+ functionArguments, ) where import Control.Applicative (liftA2)@@ -15,30 +21,52 @@ import Control.Monad.State import Data.Char+import Data.Map qualified as M import Data.Maybe import Data.Scientific-import qualified Data.Set as S+import Data.Set qualified as S import Data.Text (Text) import Data.Text qualified as T-import qualified Data.Text.Lazy as TL+import Data.Text.Lazy qualified as TL import Data.Typeable import Data.Void 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 =+ [ "test", "def", "let"+ , "module", "export", "import"+ ]+ identifier :: TestParser Text-identifier = do- lexeme $ TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_')+identifier = label "identifier" $ do+ lexeme $ try $ do+ off <- stateOffset <$> getParserState+ lead <- lowerChar+ rest <- takeWhileP Nothing (\x -> isAlphaNum x || x == '_')+ let ident = TL.toStrict $ TL.fromChunks $ (T.singleton lead :) $ TL.toChunks rest+ when (ident `elem` reservedWords) $ parseError $ Err.err off $ mconcat+ [ Err.utoks $ TL.fromStrict ident+ ]+ return ident +parseModuleName :: TestParser ModuleName+parseModuleName = do+ x <- identifier+ ModuleName . (x :) <$> many (symbol "." >> identifier)+ varName :: TestParser VarName-varName = VarName <$> identifier+varName = label "variable name" $ VarName <$> identifier newVarName :: forall a. ExprType a => TestParser (TypedVarName a) newVarName = do@@ -53,15 +81,16 @@ 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, SomeExprType @a Proxy) : testVars s }+ modify $ \s -> s { testVars = ( name, ( LocalVarName name, ExprTypePrim @a Proxy )) : testVars s } someExpansion :: TestParser SomeExpr someExpansion = do void $ char '$' choice- [do name <- VarName . TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_')- SomeExprType (_ :: Proxy a) <- lookupVarType name- return $ SomeExpr $ Variable @a name+ [do off <- stateOffset <$> getParserState+ sline <- getSourceLine+ name <- VarName . TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_')+ lookupScalarVarExpr off sline name , between (char '{') (char '}') someExpr ] @@ -186,20 +215,20 @@ applyUnOp :: forall a b sa. (ExprType a, ExprType b, ExprType sa) =>- (a -> b) -> Expr sa -> Maybe (Expr b)-applyUnOp op x = do- Refl :: a :~: sa <- eqT- return $ op <$> x+ Int -> (a -> b) -> Expr sa -> TestParser (Expr b)+applyUnOp off op x = do+ x' <- unifyExpr off (Proxy @a) x+ return $ op <$> x' data SomeBinOp = forall a b c. (ExprType a, ExprType b, ExprType c) => SomeBinOp (a -> b -> c) applyBinOp :: forall a b c sa sb. (ExprType a, ExprType b, ExprType c, ExprType sa, ExprType sb) =>- (a -> b -> c) -> Expr sa -> Expr sb -> Maybe (Expr c)-applyBinOp op x y = do- Refl :: a :~: sa <- eqT- Refl :: b :~: sb <- eqT- return $ op <$> x <*> y+ Int -> (a -> b -> c) -> Expr sa -> Expr sb -> TestParser (Expr c)+applyBinOp off op x y = do+ x' <- unifyExpr off (Proxy @a) x+ y' <- unifyExpr off (Proxy @b) y+ return $ op <$> x' <*> y' someExpr :: TestParser SomeExpr someExpr = join inner <?> "expression"@@ -208,11 +237,13 @@ parens = between (symbol "(") (symbol ")") - term = parens inner <|> literal <|> variable <?> "term"+ term = label "term" $ choice+ [ parens inner+ , return <$> literal+ , return <$> functionCall+ ] - table = [ [ recordSelector- ]- , [ prefix "-" $ [ SomeUnOp (negate @Integer)+ table = [ [ prefix "-" $ [ SomeUnOp (negate @Integer) , SomeUnOp (negate @Scientific) ] ]@@ -242,6 +273,22 @@ , SomeBinOp ((/=) @Scientific) , SomeBinOp ((/=) @Text) ]+ , binary ">" $+ [ SomeBinOp ((>) @Integer)+ , SomeBinOp ((>) @Scientific)+ ]+ , binary ">=" $+ [ SomeBinOp ((>=) @Integer)+ , SomeBinOp ((>=) @Scientific)+ ]+ , binary "<=" $+ [ SomeBinOp ((<=) @Integer)+ , SomeBinOp ((<=) @Scientific)+ ]+ , binary "<" $+ [ SomeBinOp ((<) @Integer)+ , SomeBinOp ((<) @Scientific)+ ] ] ] @@ -251,10 +298,12 @@ void $ osymbol name return $ \p -> do SomeExpr e <- p- let err = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat+ let err = FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat [T.pack "operator '", T.pack name, T.pack "' not defined for '", textExprType e, T.pack "'"]- maybe err return $ listToMaybe $ catMaybes $ map (\(SomeUnOp op) -> SomeExpr <$> applyUnOp op e) ops+ region (const err) $+ choice $ map (\(SomeUnOp op) -> SomeExpr <$> applyUnOp off op e) ops + 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@@ -278,53 +327,108 @@ let proxyOf :: proxy a -> Proxy a proxyOf _ = Proxy + let err = FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat+ [T.pack "operator '", T.pack name, T.pack "' not defined for '", textExprType e, T.pack "' and '", textExprType f, T.pack "'"]+ let tryop :: forall a b d sa sb. (ExprType a, ExprType b, ExprType d, ExprType sa, ExprType sb) =>- (a -> b -> d) -> Proxy sa -> Proxy sb -> Maybe SomeExpr- tryop op pe pf = msum- [ SomeExpr <$> applyBinOp op e f- , do Refl <- eqT' op- ExprListUnpacker _ une <- exprListUnpacker pe- ExprListUnpacker _ unf <- exprListUnpacker pf+ (a -> b -> d) -> Proxy sa -> Proxy sb -> TestParser SomeExpr+ tryop op pe pf = foldl1 (<|>) $+ [ SomeExpr <$> applyBinOp off op e f+ , do Refl <- maybe (parseError err) return $ eqT' op+ ExprListUnpacker _ une <- maybe (parseError err) return $ exprListUnpacker pe+ ExprListUnpacker _ unf <- maybe (parseError err) return $ exprListUnpacker pf tryop (listmap op) (une pe) (unf pf) ] - let err = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat- [T.pack "operator '", T.pack name, T.pack "' not defined for '", textExprType e, T.pack "' and '", textExprType f, T.pack "'"]- maybe err return $ listToMaybe $ catMaybes $ map (\(SomeBinOp op) -> tryop op (proxyOf e) (proxyOf f)) ops+ region (const err) $+ foldl1 (<|>) $ map (\(SomeBinOp op) -> tryop op (proxyOf e) (proxyOf f)) ops - recordSelector :: Operator TestParser (TestParser SomeExpr)- recordSelector = Postfix $ fmap (foldl1 (flip (.))) $ some $ do- void $ osymbol "."- off <- stateOffset <$> getParserState- m <- identifier- return $ \p -> do- SomeExpr e <- p- let err = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat- [ T.pack "value of type ", textExprType e, T.pack " does not have member '", m, T.pack "'" ]- maybe err return $ applyRecordSelector m e <$> lookup m recordMembers+typedExpr :: forall a. ExprType a => TestParser (Expr a)+typedExpr = do+ off <- stateOffset <$> getParserState+ SomeExpr e <- someExpr+ unifyExpr off Proxy e +literal :: TestParser SomeExpr+literal = label "literal" $ choice+ [ numberLiteral+ , SomeExpr <$> quotedString+ , SomeExpr <$> regex+ , list+ ]++variable :: TestParser SomeExpr+variable = label "variable" $ do+ off <- stateOffset <$> getParserState+ sline <- getSourceLine+ name <- varName+ e <- lookupVarExpr off sline name+ recordSelector e <|> return e++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++recordSelector :: SomeExpr -> TestParser SomeExpr+recordSelector (SomeExpr expr) = do+ void $ osymbol "."+ off <- stateOffset <$> getParserState+ m <- identifier+ let err = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat+ [ T.pack "value of type ", textExprType expr, T.pack " does not have member '", m, T.pack "'" ]+ e' <- maybe err return $ applyRecordSelector m expr <$> lookup m recordMembers+ recordSelector e' <|> return e'+ where applyRecordSelector :: ExprType a => Text -> Expr a -> RecordSelector a -> SomeExpr applyRecordSelector m e (RecordSelector f) = SomeExpr $ App (AnnRecord m) (pure f) e - literal = label "literal" $ choice- [ return <$> numberLiteral- , return . SomeExpr <$> quotedString- , return . SomeExpr <$> regex- , return <$> list++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+ return $ FunctionArguments args+ where+ parseArgs allowUnnamed = choice+ [do off <- stateOffset <$> getParserState+ x <- pparam+ if allowUnnamed+ then do+ checkAndInsert off Nothing x $ parseArgs False+ else do+ registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat+ [ T.pack "multiple unnamed parameters" ]+ parseArgs False++ ,do x <- identifier+ off <- stateOffset <$> getParserState+ y <- pparam <|> (promote off =<< identifier)+ checkAndInsert off (Just (ArgumentKeyword x)) y $ parseArgs allowUnnamed++ ,do return M.empty ] - variable = label "variable" $ do- name <- varName- SomeExprType (_ :: Proxy a) <- lookupVarType name- return $ return $ SomeExpr $ Variable @a name+ pparam = between (symbol "(") (symbol ")") param <|> lit -typedExpr :: forall a. ExprType a => TestParser (Expr a)-typedExpr = do- off <- stateOffset <$> getParserState- SomeExpr e <- someExpr- let err = do- registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat- [ T.pack "expected '", textExprType @a Proxy, T.pack "', expression has type '", textExprType e, T.pack "'" ]- return $ Undefined "unexpected type"- maybe err return $ cast e+ checkAndInsert off kw x cont = M.insert kw <$> check off kw x <*> cont
src/Parser/Statement.hs view
@@ -6,12 +6,13 @@ import Control.Monad.Identity import Control.Monad.State +import Data.Bifunctor import Data.Kind import Data.Maybe-import qualified Data.Set as S+import Data.Set qualified as S import Data.Text qualified as T-import qualified Data.Text.Lazy as TL import Data.Typeable+import Data.Void import Text.Megaparsec hiding (State) import Text.Megaparsec.Char@@ -21,20 +22,12 @@ import Parser.Core import Parser.Expr import Process (Process)+import Script.Expr+import Script.Expr.Class import Test import Util -getSourceLine :: TestParser SourceLine-getSourceLine = do- pstate <- statePosState <$> getParserState- return $ SourceLine $ T.concat- [ T.pack $ sourcePosPretty $ pstateSourcePos pstate- , T.pack ": "- , TL.toStrict $ TL.takeWhile (/='\n') $ pstateInput pstate- ]---letStatement :: TestParser [TestStep]+letStatement :: TestParser (Expr TestBlock) letStatement = do line <- getSourceLine indent <- L.indentLevel@@ -49,11 +42,10 @@ addVarName off tname void $ eol body <- testBlock indent- return [Let line tname e body]+ return $ Let line tname e body -forStatement :: TestParser [TestStep]+forStatement :: TestParser (Expr TestBlock) forStatement = do- line <- getSourceLine ref <- L.indentLevel wsymbol "for" voff <- stateOffset <$> getParserState@@ -73,12 +65,36 @@ let tname = TypedVarName name addVarName voff tname body <- testBlock indent- return [For line tname (unpack <$> e) body]+ return $ (\xs f -> mconcat $ map f xs)+ <$> (unpack <$> e)+ <*> LambdaAbstraction tname body -exprStatement :: TestParser [ TestStep ]-exprStatement = do- expr <- typedExpr- return [ ExprStatement expr ]+exprStatement :: TestParser (Expr TestBlock)+exprStatement = do+ ref <- L.indentLevel+ off <- stateOffset <$> getParserState+ SomeExpr expr <- someExpr+ choice+ [ continuePartial off ref expr+ , unifyExpr off Proxy expr+ ]+ where+ 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+ scn+ indent <- L.indentGuard scn GT ref+ 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+ choice+ [ continuePartial coff indent fun'+ , unifyExpr coff Proxy fun'+ ] class (Typeable a, Typeable (ParamRep a)) => ParamType a where type ParamRep a :: Type@@ -90,9 +106,18 @@ paramDefault :: proxy a -> TestParser (ParamRep a) paramDefault _ = mzero + paramNewVariables :: proxy a -> ParamRep a -> NewVariables+ paramNewVariables _ _ = NoNewVariables+ paramNewVariablesEmpty :: proxy a -> NewVariables+ paramNewVariablesEmpty _ = NoNewVariables -- to keep type info for optional parameters+ paramFromSomeExpr :: proxy a -> SomeExpr -> Maybe (ParamRep a) paramFromSomeExpr _ (SomeExpr e) = cast e + paramExpr :: ParamRep a -> Expr a+ default paramExpr :: ParamRep a ~ a => ParamRep a -> Expr a+ paramExpr = Pure+ instance ParamType SourceLine where parseParam _ = mzero showParamType _ = "<source line>"@@ -100,9 +125,14 @@ instance ExprType a => ParamType (TypedVarName a) where parseParam _ = newVarName showParamType _ = "<variable>"+ paramNewVariables _ var = SomeNewVariables [ var ]+ paramNewVariablesEmpty _ = SomeNewVariables @a [] instance ExprType a => ParamType (Expr a) where- parseParam _ = typedExpr+ parseParam _ = do+ off <- stateOffset <$> getParserState+ SomeExpr e <- literal <|> between (symbol "(") (symbol ")") someExpr+ unifyExpr off Proxy e showParamType _ = "<" ++ T.unpack (textExprType @a Proxy) ++ ">" instance ParamType a => ParamType [a] where@@ -110,14 +140,20 @@ parseParam _ = listOf (parseParam @a Proxy) showParamType _ = showParamType @a Proxy ++ " [, " ++ showParamType @a Proxy ++ " ...]" paramDefault _ = return []+ paramNewVariables _ = foldr (<>) (paramNewVariablesEmpty @a Proxy) . fmap (paramNewVariables @a Proxy)+ paramNewVariablesEmpty _ = paramNewVariablesEmpty @a Proxy paramFromSomeExpr _ se@(SomeExpr e) = cast e <|> ((:[]) <$> paramFromSomeExpr @a Proxy se)+ paramExpr = sequenceA . fmap paramExpr instance ParamType a => ParamType (Maybe a) where type ParamRep (Maybe a) = Maybe (ParamRep a) parseParam _ = Just <$> parseParam @a Proxy showParamType _ = showParamType @a Proxy paramDefault _ = return Nothing+ paramNewVariables _ = foldr (<>) (paramNewVariablesEmpty @a Proxy) . fmap (paramNewVariables @a Proxy)+ paramNewVariablesEmpty _ = paramNewVariablesEmpty @a Proxy paramFromSomeExpr _ se = Just <$> paramFromSomeExpr @a Proxy se+ paramExpr = sequenceA . fmap paramExpr instance (ParamType a, ParamType b) => ParamType (Either a b) where type ParamRep (Either a b) = Either (ParamRep a) (ParamRep b)@@ -130,62 +166,106 @@ (_ : _) -> fail "" showParamType _ = showParamType @a Proxy ++ " or " ++ showParamType @b Proxy paramFromSomeExpr _ se = (Left <$> paramFromSomeExpr @a Proxy se) <|> (Right <$> paramFromSomeExpr @b Proxy se)+ paramExpr = either (fmap Left . paramExpr) (fmap Right . paramExpr) +instance ExprType a => ParamType (Traced a) where+ type ParamRep (Traced a) = Expr a+ parseParam _ = parseParam (Proxy @(Expr a))+ showParamType _ = showParamType (Proxy @(Expr a))+ paramExpr = Trace+ data SomeParam f = forall a. ParamType a => SomeParam (Proxy a) (f (ParamRep a)) -data CommandDef a = CommandDef [(String, SomeParam Proxy)] ([SomeParam Identity] -> a)+data NewVariables+ = NoNewVariables+ | forall a. ExprType a => SomeNewVariables [ TypedVarName a ] +instance Semigroup NewVariables where+ NoNewVariables <> x = x+ x <> NoNewVariables = x+ SomeNewVariables (xs :: [ TypedVarName a ]) <> SomeNewVariables (ys :: [ TypedVarName b ])+ | Just (Refl :: a :~: b) <- eqT = SomeNewVariables (xs <> ys)+ | otherwise = error "new variables with different types"++instance Monoid NewVariables where+ mempty = NoNewVariables++someParamVars :: Foldable f => SomeParam f -> NewVariables+someParamVars (SomeParam proxy rep) = foldr (\x nvs -> paramNewVariables proxy x <> nvs) (paramNewVariablesEmpty proxy) rep++data CommandDef a = CommandDef [(String, SomeParam Proxy)] ([SomeParam Identity] -> Expr a)+ instance Functor CommandDef where- fmap f (CommandDef types ctor) = CommandDef types (f . ctor)+ fmap f (CommandDef types ctor) = CommandDef types (fmap f . ctor) instance Applicative CommandDef where- pure x = CommandDef [] (\case [] -> x; _ -> error "command arguments mismatch")- CommandDef types1 ctor1 <*> CommandDef types2 ctor2 =- CommandDef (types1 ++ types2) $ \params ->- let (params1, params2) = splitAt (length types1) params- in ctor1 params1 $ ctor2 params2+ pure x = CommandDef [] (\case [] -> Pure x; _ -> error "command arguments mismatch")+ CommandDef types1 ctor1 <*> CommandDef types2 ctor2 =+ CommandDef (types1 ++ types2) $ \params ->+ let (params1, params2) = splitAt (length types1) params+ in ctor1 params1 <*> ctor2 params2 param :: forall a. ParamType a => String -> CommandDef a param name = CommandDef [(name, SomeParam (Proxy @a) Proxy)] $ \case- [SomeParam Proxy (Identity x)] -> fromJust $ cast x+ [SomeParam Proxy (Identity x)] -> paramExpr $ fromJust $ cast x _ -> error "command arguments mismatch" -data ParamOrContext a+newtype ParamOrContext a = ParamOrContext { fromParamOrContext :: a }+ deriving (Functor, Foldable, Traversable) instance ParamType a => ParamType (ParamOrContext a) where- type ParamRep (ParamOrContext a) = ParamRep a- parseParam _ = parseParam @a Proxy+ type ParamRep (ParamOrContext a) = ParamOrContext (ParamRep a)+ parseParam _ = ParamOrContext <$> parseParam @a Proxy showParamType _ = showParamType @a Proxy paramDefault _ = gets testContext >>= \case se@(SomeExpr ctx)- | Just e <- paramFromSomeExpr @a Proxy se -> return e+ | Just e <- paramFromSomeExpr @a Proxy se -> return (ParamOrContext e) | otherwise -> fail $ showParamType @a Proxy <> " not available from context type '" <> T.unpack (textExprType ctx) <> "'"+ paramExpr = sequenceA . fmap paramExpr paramOrContext :: forall a. ParamType a => String -> CommandDef a-paramOrContext name = CommandDef [(name, SomeParam (Proxy @(ParamOrContext a)) Proxy)] $ \case- [SomeParam Proxy (Identity x)] -> fromJust $ cast x- _ -> error "command arguments mismatch"+paramOrContext name = fromParamOrContext <$> param name cmdLine :: CommandDef SourceLine cmdLine = param "" -data InnerBlock+newtype InnerBlock a = InnerBlock { fromInnerBlock :: [ a ] -> TestBlock } -instance ParamType InnerBlock where- type ParamRep InnerBlock = [TestStep]+instance ExprType a => ParamType (InnerBlock a) where+ type ParamRep (InnerBlock a) = ( [ TypedVarName a ], Expr TestBlock ) parseParam _ = mzero showParamType _ = "<code block>"+ paramExpr ( vars, expr ) = fmap InnerBlock $ helper vars $ const <$> expr+ where+ helper :: ExprType a => [ TypedVarName a ] -> Expr ([ a ] -> b) -> Expr ([ a ] -> b)+ helper ( v : vs ) = fmap combine . LambdaAbstraction v . helper vs+ helper [] = id -instance ParamType TestStep where- parseParam _ = mzero- showParamType _ = "<code line>"+ combine f (x : xs) = f x xs+ combine _ [] = error "inner block parameter count mismatch" -innerBlock :: CommandDef [TestStep]-innerBlock = CommandDef [("", SomeParam (Proxy @InnerBlock) Proxy)] $ \case- [SomeParam Proxy (Identity x)] -> fromJust $ cast x- _ -> error "command arguments mismatch"+innerBlock :: CommandDef TestBlock+innerBlock = ($ ([] :: [ Void ])) <$> innerBlockFun -command :: String -> CommandDef TestStep -> TestParser [TestStep]+innerBlockFun :: ExprType a => CommandDef (a -> TestBlock)+innerBlockFun = (\f x -> f [ x ]) <$> innerBlockFunList++innerBlockFunList :: ExprType a => CommandDef ([ a ] -> TestBlock)+innerBlockFunList = fromInnerBlock <$> param ""++newtype ExprParam a = ExprParam { fromExprParam :: a }+ deriving (Functor, Foldable, Traversable)++instance ExprType a => ParamType (ExprParam a) where+ type ParamRep (ExprParam a) = Expr a+ parseParam _ = do+ off <- stateOffset <$> getParserState+ SomeExpr e <- literal <|> variable <|> between (symbol "(") (symbol ")") someExpr+ unifyExpr off Proxy e+ showParamType _ = "<" ++ T.unpack (textExprType @a Proxy) ++ ">"+ paramExpr = fmap ExprParam++command :: String -> CommandDef TestStep -> TestParser (Expr TestBlock) command name (CommandDef types ctor) = do indent <- L.indentLevel line <- getSourceLine@@ -193,19 +273,24 @@ 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 [TestStep]+ 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 iparams <- forM params $ \case (_, SomeParam (p :: Proxy p) Nothing) | Just (Refl :: p :~: SourceLine) <- eqT -> return $ SomeParam p $ Identity line- | Just (Refl :: p :~: InnerBlock) <- eqT -> SomeParam p . Identity <$> restOfParts cmdi partials++ | SomeNewVariables (vars :: [ TypedVarName a ]) <- definedVariables+ , Just (Refl :: p :~: InnerBlock a) <- eqT+ -> SomeParam p . Identity . ( vars, ) <$> restOfParts cmdi partials+ (sym, SomeParam p Nothing) -> choice [ SomeParam p . Identity <$> paramDefault p , fail $ "missing " ++ (if null sym then "" else "'" ++ sym ++ "' ") ++ showParamType p ] (_, SomeParam (p :: Proxy p) (Just x)) -> return $ SomeParam p $ Identity x- return [ctor iparams]+ return $ (TestBlock . (: [])) <$> ctor iparams ,do symbol ":" scn@@ -215,16 +300,16 @@ ,do tryParams cmdi partials line [] params ] - restOfParts :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> TestParser [TestStep]+ restOfParts :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> TestParser (Expr TestBlock) restOfParts cmdi [] = testBlock cmdi restOfParts cmdi partials@((partIndent, params) : rest) = do scn pos <- L.indentLevel line <- getSourceLine optional eof >>= \case- Just _ -> return []+ Just _ -> return $ Pure mempty _ | pos < partIndent -> restOfParts cmdi rest- | pos == partIndent -> (++) <$> restOfLine cmdi partials line params <*> restOfParts cmdi partials+ | pos == partIndent -> mappend <$> restOfLine cmdi partials line params <*> restOfParts cmdi partials | otherwise -> L.incorrectIndent EQ partIndent pos tryParam sym (SomeParam (p :: Proxy p) cur) = do@@ -241,7 +326,7 @@ ] tryParams _ _ _ _ [] = mzero -testLocal :: TestParser [TestStep]+testLocal :: TestParser (Expr TestBlock) testLocal = do ref <- L.indentLevel wsymbol "local"@@ -251,7 +336,7 @@ indent <- L.indentGuard scn GT ref localState $ testBlock indent -testWith :: TestParser [TestStep]+testWith :: TestParser (Expr TestBlock) testWith = do ref <- L.indentLevel wsymbol "with"@@ -259,12 +344,12 @@ off <- stateOffset <$> getParserState ctx@(SomeExpr (_ :: Expr ctxe)) <- someExpr let expected =- [ SomeExprType @Network Proxy- , SomeExprType @Node Proxy- , SomeExprType @Process Proxy+ [ ExprTypePrim @Network Proxy+ , ExprTypePrim @Node Proxy+ , ExprTypePrim @Process Proxy ] notAllowed <- flip allM expected $ \case- SomeExprType (Proxy :: Proxy a) | Just (Refl :: ctxe :~: a) <- eqT -> return False+ ExprTypePrim (Proxy :: Proxy a) | Just (Refl :: ctxe :~: a) <- eqT -> return False _ -> return True when notAllowed $ registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ "expected " <> T.intercalate ", " (map (("'"<>) . (<>"'") . textSomeExprType) expected) <> ", expression has type '" <> textExprType @ctxe Proxy <> "'"@@ -277,82 +362,70 @@ modify $ \s -> s { testContext = ctx } testBlock indent -testSubnet :: TestParser [TestStep]+testSubnet :: TestParser (Expr TestBlock) testSubnet = command "subnet" $ Subnet <$> param ""- <*> paramOrContext "of"- <*> innerBlock+ <*> (fromExprParam <$> paramOrContext "of")+ <*> innerBlockFun -testNode :: TestParser [TestStep]+testNode :: TestParser (Expr TestBlock) testNode = command "node" $ DeclNode <$> param ""- <*> paramOrContext "on"- <*> innerBlock+ <*> (fromExprParam <$> paramOrContext "on")+ <*> innerBlockFun -testSpawn :: TestParser [TestStep]+testSpawn :: TestParser (Expr TestBlock) testSpawn = command "spawn" $ Spawn <$> param "as"- <*> paramOrContext "on"- <*> innerBlock--testSend :: TestParser [TestStep]-testSend = command "send" $ Send- <$> paramOrContext "to"- <*> param ""+ <*> (bimap fromExprParam fromExprParam <$> paramOrContext "on")+ <*> innerBlockFun -testExpect :: TestParser [TestStep]+testExpect :: TestParser (Expr TestBlock) testExpect = command "expect" $ Expect <$> cmdLine- <*> paramOrContext "from"+ <*> (fromExprParam <$> paramOrContext "from") <*> param "" <*> param "capture"- <*> innerBlock--testFlush :: TestParser [TestStep]-testFlush = command "flush" $ Flush- <$> paramOrContext "from"- <*> param ""--testGuard :: TestParser [TestStep]-testGuard = command "guard" $ Guard- <$> cmdLine- <*> param ""+ <*> innerBlockFunList -testDisconnectNode :: TestParser [TestStep]+testDisconnectNode :: TestParser (Expr TestBlock) testDisconnectNode = command "disconnect_node" $ DisconnectNode- <$> paramOrContext ""+ <$> (fromExprParam <$> paramOrContext "") <*> innerBlock -testDisconnectNodes :: TestParser [TestStep]+testDisconnectNodes :: TestParser (Expr TestBlock) testDisconnectNodes = command "disconnect_nodes" $ DisconnectNodes- <$> paramOrContext ""+ <$> (fromExprParam <$> paramOrContext "") <*> innerBlock -testDisconnectUpstream :: TestParser [TestStep]+testDisconnectUpstream :: TestParser (Expr TestBlock) testDisconnectUpstream = command "disconnect_upstream" $ DisconnectUpstream- <$> paramOrContext ""+ <$> (fromExprParam <$> paramOrContext "") <*> innerBlock -testPacketLoss :: TestParser [TestStep]+testPacketLoss :: TestParser (Expr TestBlock) testPacketLoss = command "packet_loss" $ PacketLoss- <$> param ""- <*> paramOrContext "on"+ <$> (fromExprParam <$> paramOrContext "")+ <*> (fromExprParam <$> paramOrContext "on") <*> innerBlock -testBlock :: Pos -> TestParser [TestStep]-testBlock indent = concat <$> go+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 []- _ | pos < indent -> return []- | pos == indent -> (:) <$> testStep <*> go+ Just _ -> return mempty+ _ | pos < indent -> return mempty+ | pos == indent -> mappend <$> step <*> go | otherwise -> L.incorrectIndent EQ indent pos -testStep :: TestParser [TestStep]+testStep :: TestParser (Expr TestBlock) testStep = choice [ letStatement , forStatement@@ -361,10 +434,7 @@ , testSubnet , testNode , testSpawn- , testSend , testExpect- , testFlush- , testGuard , testDisconnectNode , testDisconnectNodes , testDisconnectUpstream
src/Process.hs view
@@ -33,7 +33,7 @@ import Network.Ip import Output import Run.Monad-import Test+import Script.Expr.Class data Process = Process { procName :: ProcName@@ -93,7 +93,8 @@ 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- , env = Just [("EREBOS_DIR", either netDir nodeDir target)]+ , cwd = Just (either netDir nodeDir target)+ , env = Just [ ( "EREBOS_DIR", "." ) ] } pout <- liftIO $ newTVarIO []
src/Run.hs view
@@ -1,6 +1,7 @@ module Run ( module Run.Monad, runTest,+ evalGlobalDefs, ) where import Control.Applicative@@ -8,9 +9,9 @@ import Control.Concurrent.STM import Control.Monad import Control.Monad.Except+import Control.Monad.Fix import Control.Monad.Reader -import Data.Either import Data.Map qualified as M import Data.Maybe import Data.Set qualified as S@@ -31,11 +32,12 @@ import Output import Process import Run.Monad+import Script.Expr import Test import Test.Builtins -runTest :: Output -> TestOptions -> Test -> IO Bool-runTest out opts test = 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@@ -60,8 +62,8 @@ , teGDB = fst <$> mgdb } tstate = TestState- { tsNetwork = error "network not initialized"- , tsVars = builtins+ { tsGlobals = gdefs+ , tsLocals = [] , tsNodePacketLoss = M.empty , tsDisconnectedUp = S.empty , tsDisconnectedBridge = S.empty@@ -84,9 +86,10 @@ Stopped sig -> err $ T.pack $ "child stopped with signal " ++ show sig oldHandler <- installHandler processStatusChanged (CatchInfo sigHandler) Nothing + resetOutputTime out res <- runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do withInternet $ \_ -> do- evalSteps (testSteps test)+ evalBlock =<< eval (testSteps test) when (optWait opts) $ do void $ outPromptGetLine $ "Test '" <> testName test <> "' completed, waiting..." @@ -103,99 +106,68 @@ return True _ -> return False -evalSteps :: [TestStep] -> TestRun ()-evalSteps = mapM_ $ \case- Let (SourceLine sline) (TypedVarName name) expr inner -> do- cur <- asks (lookup name . tsVars . snd)- when (isJust cur) $ do- outLine OutputError Nothing $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline- throwError Failed- value <- eval expr- withVar name value $ evalSteps inner - For (SourceLine sline) (TypedVarName name) expr inner -> do- cur <- asks (lookup name . tsVars . snd)- when (isJust cur) $ do- outLine OutputError Nothing $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline- throwError Failed- value <- eval expr- forM_ value $ \i -> do- withVar name i $ evalSteps inner-- ExprStatement expr -> do- TestBlock steps <- eval expr- evalSteps steps+evalGlobalDefs :: [ (( ModuleName, VarName ), SomeExpr ) ] -> GlobalDefs+evalGlobalDefs exprs = fix $ \gdefs ->+ builtins `M.union` M.fromList (map (fmap (evalSomeWith gdefs)) exprs) - Subnet name@(TypedVarName vname) parentExpr inner -> do- parent <- eval parentExpr- withSubnet parent (Just name) $ \net -> do- withVar vname net $ evalSteps inner+evalBlock :: TestBlock -> TestRun ()+evalBlock (TestBlock steps) = forM_ steps $ \case+ Subnet name parent inner -> do+ withSubnet parent (Just name) $ evalBlock . inner - DeclNode name@(TypedVarName vname) net inner -> do- withNode net (Left name) $ \node -> do- withVar vname node $ evalSteps inner+ DeclNode name net inner -> do+ withNode net (Left name) $ evalBlock . inner - Spawn tvname@(TypedVarName vname@(VarName tname)) target inner -> do+ Spawn tvname@(TypedVarName (VarName tname)) target inner -> do case target of Left net -> withNode net (Right tvname) go- Right node -> go =<< eval node+ Right node -> go node where go node = do opts <- asks $ teOptions . fst let pname = ProcName tname tool = fromMaybe (optDefaultTool opts) (lookup pname $ optProcTools opts)- withProcess (Right node) pname Nothing tool $ \p -> do- withVar vname p (evalSteps inner)+ withProcess (Right node) pname Nothing tool $ evalBlock . inner - Send pname expr -> do- p <- eval pname- line <- eval expr+ Send p line -> do outProc OutputChildStdin p line send p line - Expect line pname expr captures inner -> do- p <- eval pname- expect line p expr captures $ evalSteps inner+ Expect line p expr captures inner -> do+ expect line p expr captures $ evalBlock . inner - Flush pname expr -> do- p <- eval pname- flush p expr+ Flush p regex -> do+ flush p regex - Guard line expr -> do- testStepGuard line expr+ Guard line vars expr -> do+ testStepGuard line vars expr DisconnectNode node inner -> do- n <- eval node- withDisconnectedUp (nodeUpstream n) $ evalSteps inner+ withDisconnectedUp (nodeUpstream node) $ evalBlock inner DisconnectNodes net inner -> do- n <- eval net- withDisconnectedBridge (netBridge n) $ evalSteps inner+ withDisconnectedBridge (netBridge net) $ evalBlock inner DisconnectUpstream net inner -> do- n <- eval net- case netUpstream n of- Just link -> withDisconnectedUp link $ evalSteps inner- Nothing -> evalSteps inner+ case netUpstream net of+ Just link -> withDisconnectedUp link $ evalBlock inner+ Nothing -> evalBlock inner PacketLoss loss node inner -> do- l <- eval loss- n <- eval node- withNodePacketLoss n l $ evalSteps inner+ withNodePacketLoss node loss $ evalBlock inner Wait -> do void $ outPromptGetLine "Waiting..." -withVar :: ExprType e => VarName -> e -> TestRun a -> TestRun a-withVar name value = local (fmap $ \s -> s { tsVars = (name, SomeVarValue value) : tsVars s })- withInternet :: (Network -> TestRun a) -> TestRun a withInternet inner = do testDir <- asks $ optTestDir . teOptions . fst inet <- newInternet testDir res <- withNetwork (inetRoot inet) $ \net -> do- local (fmap $ \s -> s { tsNetwork = net }) $ inner net+ withTypedVar rootNetworkVar net $ do+ inner net delInternet inet return res @@ -208,14 +180,13 @@ withNetwork net inner = do tcpdump <- liftIO (findExecutable "tcpdump") >>= return . \case Just path -> withProcess (Left net) ProcNameTcpdump (Just softwareTermination)- (path ++ " -i br0 -w '" ++ netDir net ++ "/br0.pcap' -U -Z root") . const+ (path ++ " -i br0 -w './br0.pcap' -U -Z root") . const Nothing -> id tcpdump $ inner net -withNode :: Expr Network -> Either (TypedVarName Node) (TypedVarName Process) -> (Node -> TestRun a) -> TestRun a-withNode netexpr tvname inner = do- net <- eval netexpr+withNode :: Network -> Either (TypedVarName Node) (TypedVarName Process) -> (Node -> TestRun a) -> TestRun a+withNode net tvname inner = do node <- newNode net (either fromTypedVarName fromTypedVarName tvname) either (flip withVar node . fromTypedVarName) (const id) tvname $ inner node @@ -274,18 +245,19 @@ | otherwise = fmap (x:) <$> tryMatch re xs tryMatch _ [] = Nothing -exprFailed :: Text -> SourceLine -> Maybe ProcName -> Expr a -> TestRun ()-exprFailed desc (SourceLine sline) pname expr = do+exprFailed :: Text -> SourceLine -> Maybe ProcName -> EvalTrace -> TestRun ()+exprFailed desc sline pname exprVars = do let prompt = maybe T.empty textProcName pname- exprVars <- gatherVars expr- outLine OutputMatchFail (Just prompt) $ T.concat [desc, T.pack " failed on ", sline]+ 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), " = ", textSomeVarValue value]+ outLine OutputMatchFail (Just prompt) $ T.concat+ [ " ", textFqVarName name, T.concat (map ("."<>) sel)+ , " = ", textSomeVarValue sline value+ ] throwError Failed -expect :: SourceLine -> Process -> Expr Regex -> [TypedVarName Text] -> TestRun () -> TestRun ()-expect (SourceLine sline) p expr tvars inner = do- re <- eval expr+expect :: SourceLine -> Process -> Traced Regex -> [TypedVarName Text] -> ([ Text ] -> TestRun ()) -> TestRun ()+expect sline p (Traced trace re) tvars inner = do timeout <- asks $ optTimeout . teOptions . fst delay <- liftIO $ registerDelay $ ceiling $ 1000000 * timeout mbmatch <- atomicallyTest $ (Nothing <$ (check =<< readTVar delay)) <|> do@@ -300,29 +272,21 @@ let vars = map (\(TypedVarName n) -> n) tvars when (length vars /= length capture) $ do- outProc OutputMatchFail p $ T.pack "mismatched number of capture variables on " `T.append` sline+ 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` sline- throwError Failed- outProc OutputMatch p line- local (fmap $ \s -> s { tsVars = zip vars (map SomeVarValue capture) ++ tsVars s }) inner+ inner capture - Nothing -> exprFailed (T.pack "expect") (SourceLine sline) (Just $ procName p) expr+ Nothing -> exprFailed (T.pack "expect") sline (Just $ procName p) trace -flush :: Process -> Maybe (Expr Regex) -> TestRun ()-flush p mbexpr = do- mbre <- sequence $ fmap eval mbexpr+flush :: Process -> Maybe Regex -> TestRun ()+flush p mbre = do atomicallyTest $ do writeTVar (procOutput p) =<< case mbre of Nothing -> return []- Just re -> filter (isLeft . regexMatch re) <$> readTVar (procOutput p)+ Just re -> filter (either error isNothing . regexMatch re) <$> readTVar (procOutput p) -testStepGuard :: SourceLine -> Expr Bool -> TestRun ()-testStepGuard sline expr = do- x <- eval expr- when (not x) $ exprFailed (T.pack "guard") sline Nothing expr+testStepGuard :: SourceLine -> EvalTrace -> Bool -> TestRun ()+testStepGuard sline vars x = do+ when (not x) $ exprFailed (T.pack "guard") sline Nothing vars
src/Run/Monad.hs view
@@ -16,16 +16,15 @@ import Control.Monad.Reader 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 {-# SOURCE #-} Network import Network.Ip import Output import {-# SOURCE #-} Process-import Test+import Script.Expr newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT Failed IO) a } deriving (Functor, Applicative, Monad, MonadReader (TestEnv, TestState), MonadIO)@@ -39,8 +38,8 @@ } data TestState = TestState- { tsNetwork :: Network- , tsVars :: [(VarName, SomeVarValue)]+ { tsGlobals :: GlobalDefs+ , tsLocals :: [ ( VarName, SomeVarValue ) ] , tsDisconnectedUp :: Set NetworkNamespace , tsDisconnectedBridge :: Set NetworkNamespace , tsNodePacketLoss :: Map NetworkNamespace Scientific@@ -93,8 +92,9 @@ catchError (TestRun act) handler = TestRun $ catchError act $ fromTestRun . handler instance MonadEval TestRun where- lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackVarName name ++ "'") return =<< asks (lookup name . tsVars . snd)- rootNetwork = asks $ tsNetwork . snd+ 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
+ src/Script/Expr.hs view
@@ -0,0 +1,443 @@+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), 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.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>"++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]
+ src/Script/Expr/Class.hs view
@@ -0,0 +1,62 @@+module Script.Expr.Class (+ ExprType(..),+ RecordSelector(..),+ ExprListUnpacker(..),+ ExprEnumerator(..),+) where++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 = []++ 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)++ 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 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)
+ src/Script/Module.hs view
@@ -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
+ src/Script/Var.hs view
@@ -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>"
src/Test.hs view
@@ -1,235 +1,38 @@ module Test (- Module(..), Test(..), TestStep(..), TestBlock(..),- SourceLine(..),-- MonadEval(..),- VarName(..), TypedVarName(..), textVarName, unpackVarName,- ExprType(..), SomeExpr(..), SomeExprType(..), someExprType,- SomeVarValue(..), fromSomeVarValue, textSomeVarValue, someVarValueType,- RecordSelector(..),- ExprListUnpacker(..),- ExprEnumerator(..),- Expr(..), eval, gatherVars,- AppAnnotation(..),-- Regex(RegexPart, RegexString), regexMatch, ) where -import Data.Char-import Data.List import Data.Scientific import Data.Text (Text)-import qualified Data.Text as T-import Data.Typeable -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 ]- }+import Network+import Process+import Script.Expr data Test = Test { testName :: Text- , testSteps :: [TestStep]+ , testSteps :: Expr TestBlock } newtype TestBlock = TestBlock [ TestStep ]--data TestStep = forall a. ExprType a => Let SourceLine (TypedVarName a) (Expr a) [TestStep]- | forall a. ExprType a => For SourceLine (TypedVarName a) (Expr [a]) [TestStep]- | ExprStatement (Expr TestBlock)- | Subnet (TypedVarName Network) (Expr Network) [TestStep]- | DeclNode (TypedVarName Node) (Expr Network) [TestStep]- | Spawn (TypedVarName Process) (Either (Expr Network) (Expr Node)) [TestStep]- | Send (Expr Process) (Expr Text)- | Expect SourceLine (Expr Process) (Expr Regex) [TypedVarName Text] [TestStep]- | Flush (Expr Process) (Maybe (Expr Regex))- | Guard SourceLine (Expr Bool)- | DisconnectNode (Expr Node) [TestStep]- | DisconnectNodes (Expr Network) [TestStep]- | DisconnectUpstream (Expr Network) [TestStep]- | PacketLoss (Expr Scientific) (Expr Node) [TestStep]- | Wait--newtype SourceLine = SourceLine Text---class MonadFail m => MonadEval m where- lookupVar :: VarName -> m SomeVarValue- rootNetwork :: m Network---newtype VarName = VarName Text- deriving (Eq, Ord)--newtype TypedVarName a = TypedVarName { fromTypedVarName :: VarName }- deriving (Eq, Ord)--textVarName :: VarName -> Text-textVarName (VarName name ) = name--unpackVarName :: VarName -> String-unpackVarName = T.unpack . textVarName---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 a => ExprType [a] where- textExprType _ = "[" <> textExprType @a Proxy <> "]"- textExprValue x = "[" <> T.intercalate ", " (map textExprValue x) <> "]"+ deriving (Semigroup, Monoid) - exprListUnpacker _ = Just $ ExprListUnpacker id (const Proxy)+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 instance ExprType TestBlock where textExprType _ = "test block" textExprValue _ = "<test block>"---data SomeExpr = forall a. ExprType a => SomeExpr (Expr a)--data SomeExprType = forall a. ExprType a => SomeExprType (Proxy a)--someExprType :: SomeExpr -> SomeExprType-someExprType (SomeExpr (_ :: Expr a)) = SomeExprType (Proxy @a)---data SomeVarValue = forall a. ExprType a => SomeVarValue a--fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => VarName -> SomeVarValue -> m a-fromSomeVarValue name (SomeVarValue value) = maybe (fail err) return $ cast value- where err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textVarName name, T.pack "' has type ", textExprType (Just value) ]--textSomeVarValue :: SomeVarValue -> Text-textSomeVarValue (SomeVarValue value) = textExprValue value--someVarValueType :: SomeVarValue -> SomeExprType-someVarValueType (SomeVarValue (_ :: a)) = SomeExprType (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- Variable :: ExprType a => VarName -> Expr a- Pure :: a -> Expr a- App :: AppAnnotation b -> Expr (a -> b) -> Expr a -> Expr b- Concat :: [Expr Text] -> Expr Text- Regex :: [Expr Regex] -> Expr Regex- RootNetwork :: Expr Network- Undefined :: String -> Expr 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--eval :: MonadEval m => Expr a -> m a-eval (Variable name) = fromSomeVarValue name =<< lookupVar name-eval (Pure value) = return value-eval (App _ f x) = eval f <*> eval x-eval (Concat xs) = T.concat <$> mapM eval xs-eval (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-eval (RootNetwork) = rootNetwork-eval (Undefined err) = fail err--gatherVars :: forall a m. MonadEval m => Expr a -> m [((VarName, [Text]), SomeVarValue)]-gatherVars = fmap (uniqOn fst . sortOn fst) . helper- where- helper :: forall b. Expr b -> m [((VarName, [Text]), SomeVarValue)]- helper (Variable var) = (:[]) . ((var, []),) <$> lookupVar var- helper (Pure _) = return []- helper e@(App (AnnRecord sel) _ x)- | Just (var, sels) <- gatherSelectors x- = do val <- SomeVarValue <$> eval e- return [((var, sels ++ [sel]), val)]- | otherwise = helper x- helper (App _ f x) = (++) <$> helper f <*> helper x- helper (Concat es) = concat <$> mapM helper es- helper (Regex es) = concat <$> mapM helper es- helper (RootNetwork) = return []- helper (Undefined {}) = return []-- 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--data Regex = RegexCompiled Text RE.Regex- | RegexPart Text- | RegexString Text--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]
src/Test/Builtins.hs view
@@ -2,12 +2,56 @@ builtins, ) where +import Data.Map qualified as M+import Data.Maybe+import Data.Text (Text)++import Process (Process)+import Script.Expr import Test -builtins :: [ ( VarName, SomeVarValue ) ]-builtins =- [ ( VarName "wait", SomeVarValue builtinWait )+builtins :: GlobalDefs+builtins = M.fromList+ [ fq "send" builtinSend+ , fq "flush" builtinFlush+ , fq "guard" builtinGuard+ , fq "wait" builtinWait ]+ where+ fq name impl = (( ModuleName [ "$" ], VarName name ), impl ) -builtinWait :: TestBlock-builtinWait = TestBlock [ Wait ]+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 (LocalVarName (VarName "")) =<< M.lookup kw args++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) ]+ where+ atypes =+ [ ( Just "to", SomeArgumentType (ContextDefault @Process) )+ , ( Nothing, SomeArgumentType (RequiredArgument @Text) )+ ]++builtinFlush :: SomeVarValue+builtinFlush = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $+ \_ args -> TestBlock [ Flush (getArg args (Just "from")) (getArgMb args (Just "matching")) ]+ where+ atypes =+ [ ( Just "from", SomeArgumentType (ContextDefault @Process) )+ , ( Just "matching", SomeArgumentType (OptionalArgument @Regex) )+ ]++builtinGuard :: SomeVarValue+builtinGuard = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton Nothing (SomeArgumentType (RequiredArgument @Bool))) $+ \sline args -> TestBlock [ Guard sline (getArgVars args Nothing) (getArg args Nothing) ]++builtinWait :: SomeVarValue+builtinWait = someConstValue $ TestBlock [ Wait ]
− src/Wrapper.hs
@@ -1,45 +0,0 @@-module Main where--import Control.Monad--import GHC.Environment--import System.Directory-import System.Environment-import System.FilePath-import System.Linux.Namespaces-import System.Posix.Process-import System.Posix.User-import System.Process--main :: IO ()-main = do- -- we must get uid/gid before unshare- uid <- getEffectiveUserID- gid <- getEffectiveGroupID-- unshare [User, Network, Mount]- writeUserMappings Nothing [UserMapping 0 uid 1]- writeGroupMappings Nothing [GroupMapping 0 gid 1] True-- -- needed for creating /run/netns- callCommand "mount -t tmpfs tmpfs /run"-- epath <- takeDirectory <$> getExecutablePath -- directory containing executable- fpath <- map takeDirectory . filter (any isPathSeparator) . take 1 <$> getFullArgs- -- directory used for invocation, can differ from above for symlinked executable-- let dirs = concat- [ [ epath ]- , [ epath </> "../../../erebos-tester-core/build/erebos-tester-core" ]- , fpath- ]-- args <- getArgs- mapM_ (\file -> executeFile file False args Nothing) =<<- findExecutablesInDirectories dirs "erebos-tester-core"- when (null fpath) $- mapM_ (\file -> executeFile file False args Nothing) =<<- findExecutables "erebos-tester-core"-- fail "core binary not found"
+ src/main.c view
@@ -0,0 +1,81 @@+#include "HsFFI.h"++#if defined(__GLASGOW_HASKELL__)+#include "Main_stub.h"+#endif++#include <errno.h>+#include <fcntl.h>+#include <sched.h>+#include <stdbool.h>+#include <stdio.h>+#include <string.h>+#include <sys/mount.h>+#include <unistd.h>++/*+ * The unshare call with CLONE_NEWUSER needs to happen before starting+ * additional threads, which means before initializing the Haskell RTS.+ * To achieve that, replace Haskell main with a custom one here that does+ * the unshare work and then executes the Haskell code.+ */++static bool writeProcSelfFile( const char * file, const char * data, size_t size )+{+ char path[ 256 ];+ if( snprintf( path, sizeof( path ), "/proc/self/%s", file )+ >= sizeof( path ) ){+ fprintf( stderr, "buffer too small\n" );+ return false;+ }++ int fd = open( path, O_WRONLY );+ if( fd < 0 ){+ fprintf( stderr, "failed to open %s: %s", path, strerror( errno ));+ return false;+ }++ ssize_t written = write( fd, data, size );+ if( written < 0 )+ fprintf( stderr, "failed to write to %s: %s\n", path, strerror( errno ));++ close( fd );+ return written == size;+}++int main( int argc, char * argv[] )+{+ uid_t uid = geteuid();+ gid_t gid = getegid();+ unshare( CLONE_NEWUSER | CLONE_NEWNET | CLONE_NEWNS );++ char buf[ 256 ];+ int len;++ len = snprintf( buf, sizeof( buf ), "%d %d %d\n", 0, uid, 1 );+ if( len >= sizeof( buf ) ){+ fprintf( stderr, "buffer too small\n" );+ return 1;+ }+ if ( ! writeProcSelfFile( "uid_map", buf, len ) )+ return 1;++ if ( ! writeProcSelfFile( "setgroups", "deny\n", 5 ) )+ return 1;++ len = snprintf( buf, sizeof( buf ), "%d %d %d\n", 0, gid, 1 );+ if( len >= sizeof( buf ) ){+ fprintf( stderr, "buffer too small\n" );+ return 1;+ }+ if ( ! writeProcSelfFile( "gid_map", buf, len ) )+ return 1;++ mount( "tmpfs", "/run", "tmpfs", 0, "size=4m" );++ hs_init( &argc, &argv );+ testerMain();+ hs_exit();++ return 0;+}