summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--CHANGELOG.md23
-rw-r--r--README.md115
-rw-r--r--erebos-tester.cabal140
-rw-r--r--src/Asset.hs30
-rw-r--r--src/GDB.hs4
-rw-r--r--src/Main.hs39
-rw-r--r--src/Network.hs12
-rw-r--r--src/Network.hs-boot5
-rw-r--r--src/Output.hs22
-rw-r--r--src/Parser.hs197
-rw-r--r--src/Parser/Core.hs231
-rw-r--r--src/Parser/Expr.hs251
-rw-r--r--src/Parser/Shell.hs73
-rw-r--r--src/Parser/Statement.hs298
-rw-r--r--src/Process.hs34
-rw-r--r--src/Run.hs166
-rw-r--r--src/Run/Monad.hs20
-rw-r--r--src/Script/Expr.hs443
-rw-r--r--src/Script/Expr/Class.hs62
-rw-r--r--src/Script/Module.hs20
-rw-r--r--src/Script/Shell.hs89
-rw-r--r--src/Script/Var.hs56
-rw-r--r--src/Test.hs251
-rw-r--r--src/Test/Builtins.hs54
-rw-r--r--src/Wrapper.hs45
-rw-r--r--src/main.c81
26 files changed, 2050 insertions, 711 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index baa869c..d7872ef 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,5 +1,28 @@
# Revision history for erebos-tester
+## 0.3.1 -- 2025-03-03
+
+* Fix executing test tool given with relative path
+
+## 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
+* Fix type error reporting for some command parameters
+
## 0.2.3 -- 2024-08-10
* Added `network` member to the `node` object
diff --git a/README.md b/README.md
index 0cf5f21..2c11170 100644
--- a/README.md
+++ b/README.md
@@ -178,8 +178,11 @@ and used by `spawn` or network configuration commands.
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 @@ List elements can be of any type, but all elements of a particular list must hav
Used in the `for` command.
-### Build-in commands
+### Built-in commands
```
subnet <name> [of <network>]
@@ -248,10 +251,11 @@ In that case the expect command has to have the `capture` clause with matching n
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>
@@ -315,6 +319,111 @@ wait
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
---------------------
diff --git a/erebos-tester.cabal b/erebos-tester.cabal
index a980532..9d4e5ae 100644
--- a/erebos-tester.cabal
+++ b/erebos-tester.cabal
@@ -1,7 +1,7 @@
cabal-version: 3.0
name: erebos-tester
-version: 0.2.3
+version: 0.3.1
synopsis: Test framework with virtual network using Linux namespaces
description:
This framework is intended mainly for networking libraries/applications and
@@ -28,12 +28,14 @@ flag ci
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,70 @@ common common
-- 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 },
+ main-is:
+ Main.hs
-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
+ other-modules:
+ Asset
+ Config
+ GDB
+ Network
+ Network.Ip
+ Output
+ Parser
+ Parser.Core
+ Parser.Expr
+ Parser.Shell
+ Parser.Statement
+ Paths_erebos_tester
+ Process
+ Run
+ Run.Monad
+ Script.Expr
+ Script.Expr.Class
+ Script.Module
+ Script.Shell
+ Script.Var
+ Test
+ Test.Builtins
+ Util
+ Version
+ Version.Git
- 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
-
-executable erebos-tester-core
- import: common
- ghc-options:
- -threaded
+ autogen-modules:
+ Paths_erebos_tester
- main-is: Main.hs
+ c-sources:
+ src/main.c
- 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
+ other-extensions:
+ TemplateHaskell
+ default-extensions:
+ DefaultSignatures
+ DeriveTraversable
+ ExistentialQuantification
+ FlexibleContexts
+ FlexibleInstances
+ GADTs
+ GeneralizedNewtypeDeriving
+ ImportQualifiedPost
+ LambdaCase
+ MultiParamTypeClasses
+ MultiWayIf
+ OverloadedStrings
+ RankNTypes
+ RecordWildCards
+ ScopedTypeVariables
+ TupleSections
+ TypeApplications
+ TypeFamilies
+ TypeOperators
- autogen-modules: Paths_erebos_tester
-
- 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 +118,11 @@ executable erebos-tester-core
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
diff --git a/src/Asset.hs b/src/Asset.hs
new file mode 100644
index 0000000..550438b
--- /dev/null
+++ b/src/Asset.hs
@@ -0,0 +1,30 @@
+module Asset (
+ Asset(..),
+ AssetPath(..),
+) where
+
+import Data.Text (Text)
+import Data.Text qualified as T
+
+import Script.Expr.Class
+
+data Asset = Asset
+ { assetPath :: AssetPath
+ }
+
+newtype AssetPath = AssetPath FilePath
+
+textAssetPath :: AssetPath -> Text
+textAssetPath (AssetPath path) = T.pack path
+
+instance ExprType Asset where
+ textExprType _ = "asset"
+ textExprValue asset = "asset:" <> textAssetPath (assetPath asset)
+
+ recordMembers =
+ [ ( "path", RecordSelector $ assetPath )
+ ]
+
+instance ExprType AssetPath where
+ textExprType _ = "filepath"
+ textExprValue = ("filepath:" <>) . textAssetPath
diff --git a/src/GDB.hs b/src/GDB.hs
index 2862065..0819600 100644
--- a/src/GDB.hs
+++ b/src/GDB.hs
@@ -75,7 +75,7 @@ gdbStart onCrash = do
let process = Process
{ procName = ProcNameGDB
- , procHandle = handle
+ , procHandle = Left handle
, procStdin = hin
, procOutput = pout
, procKillWith = Nothing
@@ -144,7 +144,7 @@ gdbLine gdb rline = either (outProc OutputError (gdbProcess gdb) . T.pack . erro
addInferior :: MonadOutput m => GDB -> Process -> m ()
addInferior gdb process = do
- liftIO (getPid $ procHandle process) >>= \case
+ liftIO (either getPid (\_ -> return Nothing) $ procHandle process) >>= \case
Nothing -> outProc OutputError process $ "failed to get PID"
Just pid -> do
tgid <- liftIO (atomically $ tryReadTChan $ gdbThreadGroups gdb) >>= \case
diff --git a/src/Main.hs b/src/Main.hs
index 61afbd8..e69c672 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -2,8 +2,10 @@ module Main (main) where
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 Output
import Parser
import Process
import Run
+import Script.Module
import Test
import Util
import Version
@@ -130,9 +133,11 @@ main = do
putStrLn versionLine
exitSuccess
- getPermissions (head $ words $ optDefaultTool $ optTest opts) >>= \perms -> do
- when (not $ executable perms) $ do
- fail $ optDefaultTool (optTest opts) <> " is not executable"
+ case words $ optDefaultTool $ optTest opts of
+ (path : _) -> getPermissions path >>= \perms -> do
+ when (not $ executable perms) $ do
+ fail $ "‘" <> path <> "’ is not executable"
+ _ -> fail $ "invalid tool argument: ‘" <> optDefaultTool (optTest opts) <> "’"
files <- if not (null ofiles)
then return $ flip map ofiles $ \ofile ->
@@ -148,12 +153,24 @@ main = do
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
-
- ok <- allM (runTest out $ optTest opts) $
+ ( 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
+
+ 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
diff --git a/src/Network.hs b/src/Network.hs
index aa06952..e12231d 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -5,6 +5,7 @@ module Network (
NodeName(..), textNodeName, unpackNodeName,
nextNodeName,
+ rootNetworkVar,
newInternet, delInternet,
newSubnet,
newNode,
@@ -25,7 +26,8 @@ import System.FilePath
import System.Process
import Network.Ip
-import Test
+import Script.Expr
+import Script.Expr.Class
{-
NETWORK STRUCTURE
@@ -107,11 +109,15 @@ instance ExprType Node where
textExprValue n = T.pack "n:" <> textNodeName (nodeName n)
recordMembers = map (first T.pack)
- [ ("ip", RecordSelector $ textIpAddress . nodeIp)
- , ("network", RecordSelector $ nodeNetwork)
+ [ ( "ifname", RecordSelector $ const ("veth0" :: Text) )
+ , ( "ip", RecordSelector $ textIpAddress . nodeIp )
+ , ( "network", RecordSelector $ nodeNetwork )
]
+rootNetworkVar :: TypedVarName Network
+rootNetworkVar = TypedVarName (VarName "$ROOT_NET")
+
nextPrefix :: IpPrefix -> [Word8] -> Word8
nextPrefix _ used = maximum (0 : used) + 1
diff --git a/src/Network.hs-boot b/src/Network.hs-boot
deleted file mode 100644
index 1b5e9c4..0000000
--- a/src/Network.hs-boot
+++ /dev/null
@@ -1,5 +0,0 @@
-module Network where
-
-data Network
-data Node
-data NodeName
diff --git a/src/Output.hs b/src/Output.hs
index 135e6e0..1555e54 100644
--- a/src/Output.hs
+++ b/src/Output.hs
@@ -2,6 +2,7 @@ module Output (
Output, OutputType(..),
MonadOutput(..),
startOutput,
+ resetOutputTime,
outLine,
outPromptGetLine,
outPromptGetLineCompletion,
@@ -19,10 +20,14 @@ import Data.Text.Lazy.IO qualified as TL
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,9 +57,15 @@ instance MonadIO m => MonadOutput (ReaderT Output m) where
getOutput = ask
startOutput :: Bool -> Bool -> IO Output
-startOutput outVerbose outUseColor = Output
- <$> newMVar OutputState { outPrint = TL.putStrLn, outHistory = emptyHistory }
- <*> pure OutputConfig { .. }
+startOutput 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"
@@ -97,9 +108,12 @@ ioWithOutput act = liftIO . act =<< getOutput
outLine :: MonadOutput m => OutputType -> Maybe Text -> Text -> m ()
outLine otype prompt line = ioWithOutput $ \out ->
when (outVerbose (outConfig out) || printWhenQuiet otype) $ do
+ 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 ]
diff --git a/src/Parser.hs b/src/Parser.hs
index 3c43a69..4afca09 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -1,74 +1,213 @@
{-# 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 Asset
+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
+
+parseAsset :: TestParser ( VarName, SomeExpr )
+parseAsset = label "asset definition" $ do
+ wsymbol "asset"
+ name <- varName
+ osymbol ":"
+ void eol
+ ref <- L.indentGuard scn GT pos1
+ wsymbol "path"
+ osymbol ":"
+ assetPath <- AssetPath . TL.unpack <$> takeWhile1P Nothing (/= '\n')
+ void $ L.indentGuard scn LT ref
+ return ( name, SomeExpr $ Pure Asset {..} )
+
+parseExport :: TestParser [ Toplevel ]
+parseExport = label "export declaration" $ toplevel id $ do
+ wsymbol "export"
+ choice
+ [ do
+ def@( name, _ ) <- parseDefinition <|> parseAsset
+ 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
+ , (: []) <$> toplevel ToplevelDefinition parseAsset
+ , 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
diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs
index 2a74d3d..d90f227 100644
--- a/src/Parser/Core.hs
+++ b/src/Parser/Core.hs
@@ -1,37 +1,210 @@
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 :: 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 <> "'"
-lookupVarType :: VarName -> TestParser SomeExprType
-lookupVarType name = maybe (fail $ "variable not in scope: '" ++ unpackVarName name ++ "'") return =<< gets (lookup name . testVars)
skipLineComment :: TestParser ()
skipLineComment = L.skipLineComment $ TL.pack "#"
@@ -61,11 +234,12 @@ localState :: TestParser a -> TestParser a
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,34 @@ listOf :: TestParser a -> TestParser [a]
listOf item = do
x <- item
(x:) <$> choice [ symbol "," >> listOf item, return [] ]
+
+blockOf :: Monoid a => Pos -> TestParser a -> TestParser a
+blockOf indent step = go
+ where
+ go = do
+ scn
+ pos <- L.indentLevel
+ optional eof >>= \case
+ Just _ -> return mempty
+ _ | pos < indent -> return mempty
+ | pos == indent -> mappend <$> step <*> go
+ | otherwise -> L.incorrectIndent EQ indent pos
+
+
+getSourceLine :: TestParser SourceLine
+getSourceLine = do
+ 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
diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs
index 8ea3ace..54f2757 100644
--- a/src/Parser/Expr.hs
+++ b/src/Parser/Expr.hs
@@ -1,5 +1,6 @@
module Parser.Expr (
identifier,
+ parseModuleName,
varName,
newVarName,
@@ -7,6 +8,13 @@ module Parser.Expr (
someExpr,
typedExpr,
+ literal,
+ variable,
+
+ stringExpansion,
+
+ checkFunctionArguments,
+ functionArguments,
) where
import Control.Applicative (liftA2)
@@ -15,30 +23,52 @@ import Control.Monad
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,20 +83,21 @@ addVarName off (TypedVarName name) = do
Just _ -> registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
T.pack "variable '" <> textVarName name <> T.pack "' already exists"
Nothing -> return ()
- modify $ \s -> s { testVars = (name, 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
]
-stringExpansion :: ExprType a => Text -> (forall b. ExprType b => Expr b -> [Maybe (Expr a)]) -> TestParser (Expr a)
-stringExpansion tname conv = do
+expressionExpansion :: ExprType a => Text -> (forall b. ExprType b => Expr b -> [ Maybe (Expr a) ]) -> TestParser (Expr a)
+expressionExpansion tname conv = do
off <- stateOffset <$> getParserState
SomeExpr e <- someExpansion
let err = do
@@ -76,6 +107,13 @@ stringExpansion tname conv = do
maybe err return $ listToMaybe $ catMaybes $ conv e
+stringExpansion :: TestParser (Expr Text)
+stringExpansion = expressionExpansion (T.pack "string") $ \e ->
+ [ cast e
+ , fmap (T.pack . show @Integer) <$> cast e
+ , fmap (T.pack . show @Scientific) <$> cast e
+ ]
+
numberLiteral :: TestParser SomeExpr
numberLiteral = label "number" $ lexeme $ do
x <- L.scientific
@@ -102,11 +140,7 @@ quotedString = label "string" $ lexeme $ do
, char 't' >> return '\t'
]
(Pure (T.singleton c) :) <$> inner
- ,do e <- stringExpansion (T.pack "string") $ \e ->
- [ cast e
- , fmap (T.pack . show @Integer) <$> cast e
- , fmap (T.pack . show @Scientific) <$> cast e
- ]
+ ,do e <- stringExpansion
(e:) <$> inner
]
Concat <$> inner
@@ -124,7 +158,7 @@ regex = label "regular expression" $ lexeme $ do
, anySingle >>= \c -> return (Pure $ RegexPart $ T.pack ['\\', c])
]
(s:) <$> inner
- ,do e <- stringExpansion (T.pack "regex") $ \e ->
+ ,do e <- expressionExpansion (T.pack "regex") $ \e ->
[ cast e
, fmap RegexString <$> cast e
, fmap (RegexString . T.pack . show @Integer) <$> cast e
@@ -186,20 +220,20 @@ data SomeUnOp = forall a b. (ExprType a, ExprType b) => SomeUnOp (a -> b)
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 +242,13 @@ someExpr = join inner <?> "expression"
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 +278,22 @@ someExpr = join inner <?> "expression"
, 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,9 +303,11 @@ someExpr = join inner <?> "expression"
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)
@@ -278,53 +332,108 @@ someExpr = join inner <?> "expression"
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
-
- 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
+ region (const err) $
+ foldl1 (<|>) $ map (\(SomeBinOp op) -> tryop op (proxyOf e) (proxyOf f)) ops
+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
diff --git a/src/Parser/Shell.hs b/src/Parser/Shell.hs
new file mode 100644
index 0000000..0f34fee
--- /dev/null
+++ b/src/Parser/Shell.hs
@@ -0,0 +1,73 @@
+module Parser.Shell (
+ ShellScript,
+ shellScript,
+) where
+
+import Control.Monad
+
+import Data.Char
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Text.Lazy qualified as TL
+
+import Text.Megaparsec
+import Text.Megaparsec.Char
+import Text.Megaparsec.Char.Lexer qualified as L
+
+import Parser.Core
+import Parser.Expr
+import Script.Expr
+import Script.Shell
+
+parseArgument :: TestParser (Expr Text)
+parseArgument = lexeme $ fmap (App AnnNone (Pure T.concat) <$> foldr (liftA2 (:)) (Pure [])) $ some $ choice
+ [ doubleQuotedString
+ , escapedChar
+ , stringExpansion
+ , unquotedString
+ ]
+ where
+ specialChars = [ '\"', '\\', '$' ]
+
+ unquotedString :: TestParser (Expr Text)
+ unquotedString = do
+ Pure . TL.toStrict <$> takeWhile1P Nothing (\c -> not (isSpace c) && c `notElem` specialChars)
+
+ doubleQuotedString :: TestParser (Expr Text)
+ doubleQuotedString = do
+ void $ char '"'
+ let inner = choice
+ [ char '"' >> return []
+ , (:) <$> (Pure . TL.toStrict <$> takeWhile1P Nothing (`notElem` specialChars)) <*> inner
+ , (:) <$> escapedChar <*> inner
+ , (:) <$> stringExpansion <*> inner
+ ]
+ App AnnNone (Pure T.concat) . foldr (liftA2 (:)) (Pure []) <$> inner
+
+ escapedChar :: TestParser (Expr Text)
+ escapedChar = do
+ void $ char '\\'
+ Pure <$> choice
+ [ char '\\' >> return "\\"
+ , char '"' >> return "\""
+ , char '$' >> return "$"
+ , char 'n' >> return "\n"
+ , char 'r' >> return "\r"
+ , char 't' >> return "\t"
+ ]
+
+parseArguments :: TestParser (Expr [ Text ])
+parseArguments = foldr (liftA2 (:)) (Pure []) <$> many parseArgument
+
+shellStatement :: TestParser (Expr [ ShellStatement ])
+shellStatement = label "shell statement" $ do
+ command <- parseArgument
+ args <- parseArguments
+ return $ fmap (: []) $ ShellStatement
+ <$> command
+ <*> args
+
+shellScript :: TestParser (Expr ShellScript)
+shellScript = do
+ indent <- L.indentLevel
+ fmap ShellScript <$> blockOf indent shellStatement
diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs
index b2f3cd6..7c2977d 100644
--- a/src/Parser/Statement.hs
+++ b/src/Parser/Statement.hs
@@ -6,12 +6,13 @@ import Control.Monad
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
@@ -20,21 +21,14 @@ import qualified Text.Megaparsec.Char.Lexer as L
import Network (Network, Node)
import Parser.Core
import Parser.Expr
+import Parser.Shell
import Process (Process)
+import Script.Expr
+import Script.Expr.Class
import Test
import Util
-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 +43,10 @@ letStatement = do
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 +66,52 @@ forStatement = do
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 ]
+shellStatement :: TestParser (Expr (TestBlock ()))
+shellStatement = do
+ ref <- L.indentLevel
+ wsymbol "shell"
+ wsymbol "as"
+ pname <- newVarName
+ wsymbol "on"
+ node <- typedExpr
+ symbol ":"
+ void eol
+ void $ L.indentGuard scn GT ref
+ script <- shellScript
+ cont <- testBlock ref
+ return $ TestBlockStep EmptyTestBlock <$>
+ (SpawnShell pname <$> node <*> script <*> LambdaAbstraction pname cont)
+
+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 +123,18 @@ class (Typeable a, Typeable (ParamRep a)) => ParamType a where
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 +142,14 @@ instance ParamType SourceLine where
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 +157,20 @@ instance ParamType a => ParamType [a] where
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 +183,106 @@ instance (ParamType a, ParamType b) => ParamType (Either a b) where
(_ : _) -> 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
+
+innerBlockFun :: ExprType a => CommandDef (a -> TestBlock ())
+innerBlockFun = (\f x -> f [ x ]) <$> innerBlockFunList
-command :: String -> CommandDef TestStep -> TestParser [TestStep]
+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 +290,24 @@ command name (CommandDef types ctor) = do
localState $ do
restOfLine indent [] line $ map (fmap $ \(SomeParam p@(_ :: Proxy p) Proxy) -> SomeParam p $ Nothing @(ParamRep p)) types
where
- restOfLine :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> SourceLine -> [(String, SomeParam Maybe)] -> TestParser [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 $ (TestBlockStep EmptyTestBlock) <$> ctor iparams
,do symbol ":"
scn
@@ -215,16 +317,16 @@ command name (CommandDef types ctor) = do
,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 +343,7 @@ command name (CommandDef types ctor) = do
]
tryParams _ _ _ _ [] = mzero
-testLocal :: TestParser [TestStep]
+testLocal :: TestParser (Expr (TestBlock ()))
testLocal = do
ref <- L.indentLevel
wsymbol "local"
@@ -251,7 +353,7 @@ testLocal = do
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 +361,12 @@ testWith = do
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,94 +379,68 @@ testWith = do
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
- where
- go = do
- scn
- pos <- L.indentLevel
- optional eof >>= \case
- Just _ -> return []
- _ | pos < indent -> return []
- | pos == indent -> (:) <$> testStep <*> go
- | otherwise -> L.incorrectIndent EQ indent pos
+testBlock :: Pos -> TestParser (Expr (TestBlock ()))
+testBlock indent = blockOf indent testStep
-testStep :: TestParser [TestStep]
+testStep :: TestParser (Expr (TestBlock ()))
testStep = choice
[ letStatement
, forStatement
+ , shellStatement
, testLocal
, testWith
, testSubnet
, testNode
, testSpawn
- , testSend
, testExpect
- , testFlush
- , testGuard
, testDisconnectNode
, testDisconnectNodes
, testDisconnectUpstream
diff --git a/src/Process.hs b/src/Process.hs
index 48ed40f..92bbab1 100644
--- a/src/Process.hs
+++ b/src/Process.hs
@@ -22,7 +22,9 @@ import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
+import System.Directory
import System.Exit
+import System.FilePath
import System.IO
import System.IO.Error
import System.Posix.Signals
@@ -33,11 +35,11 @@ import Network
import Network.Ip
import Output
import Run.Monad
-import Test
+import Script.Expr.Class
data Process = Process
{ procName :: ProcName
- , procHandle :: ProcessHandle
+ , procHandle :: Either ProcessHandle ( ThreadId, MVar ExitCode )
, procStdin :: Handle
, procOutput :: TVar [Text]
, procKillWith :: Maybe Signal
@@ -89,27 +91,39 @@ lineReadingLoop process h act =
spawnOn :: Either Network Node -> ProcName -> Maybe Signal -> String -> TestRun Process
spawnOn target pname killWith cmd = do
+ -- When executing command given with relative path, turn it to absolute one,
+ -- because working directory will be changed for the "ip netns exec" wrapper.
+ cmd' <- liftIO $ do
+ case span (/= ' ') cmd of
+ ( path, rest )
+ | any isPathSeparator path && isRelative path
+ -> do
+ path' <- makeAbsolute path
+ return (path' ++ rest)
+ _ -> return cmd
+
let netns = either getNetns getNetns target
let prefix = T.unpack $ "ip netns exec \"" <> textNetnsName netns <> "\" "
- (Just hin, Just hout, Just herr, handle) <- liftIO $ createProcess (shell $ prefix ++ cmd)
+ (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 []
let process = Process
{ procName = pname
- , procHandle = handle
+ , procHandle = Left handle
, procStdin = hin
, procOutput = pout
, procKillWith = killWith
, procNode = either (const undefined) id target
}
- forkTest $ lineReadingLoop process hout $ \line -> do
+ void $ forkTest $ lineReadingLoop process hout $ \line -> do
outProc OutputChildStdout process line
liftIO $ atomically $ modifyTVar pout (++[line])
- forkTest $ lineReadingLoop process herr $ \line -> do
+ void $ forkTest $ lineReadingLoop process herr $ \line -> do
case pname of
ProcNameTcpdump -> return ()
_ -> outProc OutputChildStderr process line
@@ -125,14 +139,14 @@ closeProcess p = do
liftIO $ hClose $ procStdin p
case procKillWith p of
Nothing -> return ()
- Just sig -> liftIO $ getPid (procHandle p) >>= \case
+ Just sig -> liftIO $ either getPid (\_ -> return Nothing) (procHandle p) >>= \case
Nothing -> return ()
Just pid -> signalProcess sig pid
liftIO $ void $ forkIO $ do
threadDelay 1000000
- terminateProcess $ procHandle p
- liftIO (waitForProcess (procHandle p)) >>= \case
+ either terminateProcess (killThread . fst) $ procHandle p
+ liftIO (either waitForProcess (takeMVar . snd) (procHandle p)) >>= \case
ExitSuccess -> return ()
ExitFailure code -> do
outProc OutputChildFail p $ T.pack $ "exit code: " ++ show code
diff --git a/src/Run.hs b/src/Run.hs
index 2bee6ec..b7093f4 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -1,6 +1,7 @@
module Run (
module Run.Monad,
runTest,
+ evalGlobalDefs,
) where
import Control.Applicative
@@ -8,9 +9,9 @@ import Control.Concurrent
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,13 @@ import Network.Ip
import Output
import Process
import Run.Monad
+import Script.Expr
+import Script.Shell
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 +63,8 @@ runTest out opts test = do
, teGDB = fst <$> mgdb
}
tstate = TestState
- { tsNetwork = error "network not initialized"
- , tsVars = builtins
+ { tsGlobals = gdefs
+ , tsLocals = []
, tsNodePacketLoss = M.empty
, tsDisconnectedUp = S.empty
, tsDisconnectedBridge = S.empty
@@ -70,7 +73,7 @@ runTest out opts test = do
let sigHandler SignalInfo { siginfoSpecific = chld } = do
processes <- readMVar procVar
forM_ processes $ \p -> do
- mbpid <- getPid (procHandle p)
+ mbpid <- either getPid (\_ -> return Nothing) (procHandle p)
when (mbpid == Just (siginfoPid chld)) $ flip runReaderT out $ do
let err detail = outProc OutputChildFail p detail
case siginfoStatus chld of
@@ -84,9 +87,10 @@ runTest out opts test = do
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 +107,73 @@ runTest out opts test = do
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
-
- Subnet name@(TypedVarName vname) parentExpr inner -> do
- parent <- eval parentExpr
- withSubnet parent (Just name) $ \net -> do
- withVar vname net $ evalSteps inner
-
- DeclNode name@(TypedVarName vname) net inner -> do
- withNode net (Left name) $ \node -> do
- withVar vname node $ evalSteps inner
-
- Spawn tvname@(TypedVarName vname@(VarName tname)) target inner -> do
+
+evalGlobalDefs :: [ (( ModuleName, VarName ), SomeExpr ) ] -> GlobalDefs
+evalGlobalDefs exprs = fix $ \gdefs ->
+ builtins `M.union` M.fromList (map (fmap (evalSomeWith gdefs)) exprs)
+
+evalBlock :: TestBlock () -> TestRun ()
+evalBlock EmptyTestBlock = return ()
+evalBlock (TestBlockStep prev step) = evalBlock prev >> case step of
+ Subnet name parent inner -> do
+ withSubnet parent (Just name) $ evalBlock . inner
+
+ DeclNode name net inner -> do
+ withNode net (Left name) $ evalBlock . inner
+
+ 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
+ SpawnShell (TypedVarName (VarName tname)) node script inner -> do
+ let pname = ProcName tname
+ withShellProcess node pname script $ evalBlock . inner
+
+ 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 +186,13 @@ withNetwork :: Network -> (Network -> TestRun a) -> TestRun a
withNetwork net inner = do
tcpdump <- liftIO (findExecutable "tcpdump") >>= return . \case
Just path -> withProcess (Left net) ProcNameTcpdump (Just softwareTermination)
- (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 +251,19 @@ tryMatch re (x:xs) | Right (Just (_, _, _, capture)) <- regexMatch re x = Just (
| 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 +278,21 @@ expect (SourceLine sline) p expr tvars inner = do
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
diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs
index 9ec9065..e107017 100644
--- a/src/Run/Monad.hs
+++ b/src/Run/Monad.hs
@@ -16,16 +16,15 @@ import Control.Monad.Except
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 TestEnv = TestEnv
}
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 @@ instance MonadError Failed TestRun where
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
@@ -109,10 +109,10 @@ finally act handler = do
void handler
return x
-forkTest :: TestRun () -> TestRun ()
+forkTest :: TestRun () -> TestRun ThreadId
forkTest act = do
tenv <- ask
- void $ liftIO $ forkIO $ do
+ liftIO $ forkIO $ do
runExceptT (flip runReaderT tenv $ fromTestRun act) >>= \case
Left e -> atomically $ writeTVar (teFailed $ fst tenv) (Just e)
Right () -> return ()
diff --git a/src/Script/Expr.hs b/src/Script/Expr.hs
new file mode 100644
index 0000000..e8f6993
--- /dev/null
+++ b/src/Script/Expr.hs
@@ -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]
diff --git a/src/Script/Expr/Class.hs b/src/Script/Expr/Class.hs
new file mode 100644
index 0000000..64b4241
--- /dev/null
+++ b/src/Script/Expr/Class.hs
@@ -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)
diff --git a/src/Script/Module.hs b/src/Script/Module.hs
new file mode 100644
index 0000000..3ea59bf
--- /dev/null
+++ b/src/Script/Module.hs
@@ -0,0 +1,20 @@
+module Script.Module (
+ Module(..),
+ ModuleName(..), textModuleName,
+ moduleExportedDefinitions,
+) where
+
+import Script.Expr
+import Test
+
+data Module = Module
+ { moduleName :: ModuleName
+ , moduleTests :: [ Test ]
+ , moduleDefinitions :: [ ( VarName, SomeExpr ) ]
+ , moduleExports :: [ VarName ]
+ }
+
+moduleExportedDefinitions :: Module -> [ ( VarName, ( FqVarName, SomeExpr )) ]
+moduleExportedDefinitions Module {..} =
+ map (\( var, expr ) -> ( var, ( GlobalVarName moduleName var, expr ))) $
+ filter ((`elem` moduleExports) . fst) moduleDefinitions
diff --git a/src/Script/Shell.hs b/src/Script/Shell.hs
new file mode 100644
index 0000000..60ec929
--- /dev/null
+++ b/src/Script/Shell.hs
@@ -0,0 +1,89 @@
+module Script.Shell (
+ ShellStatement(..),
+ ShellScript(..),
+ withShellProcess,
+) where
+
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.IO.Class
+import Control.Monad.Reader
+
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Text.IO qualified as T
+
+import System.Exit
+import System.IO
+import System.Process hiding (ShellCommand)
+
+import Network
+import Output
+import Process
+import Run.Monad
+
+
+data ShellStatement = ShellStatement
+ { shellCommand :: Text
+ , shellArguments :: [ Text ]
+ }
+
+newtype ShellScript = ShellScript [ ShellStatement ]
+
+
+executeScript :: Node -> ProcName -> Handle -> Handle -> Handle -> ShellScript -> TestRun ()
+executeScript node pname pstdin pstdout pstderr (ShellScript statements) = do
+ forM_ statements $ \ShellStatement {..} -> case shellCommand of
+ "echo" -> liftIO $ do
+ T.hPutStrLn pstdout $ T.intercalate " " shellArguments
+ hFlush pstdout
+ cmd -> do
+ (_, _, _, phandle) <- liftIO $ createProcess_ "shell"
+ (proc (T.unpack cmd) (map T.unpack shellArguments))
+ { std_in = UseHandle pstdin
+ , std_out = UseHandle pstdout
+ , std_err = UseHandle pstderr
+ , cwd = Just (nodeDir node)
+ , env = Just []
+ }
+ liftIO (waitForProcess phandle) >>= \case
+ ExitSuccess -> return ()
+ ExitFailure code -> do
+ outLine OutputChildFail (Just $ textProcName pname) $ T.pack $ "exit code: " ++ show code
+ throwError Failed
+
+spawnShell :: Node -> ProcName -> ShellScript -> TestRun Process
+spawnShell procNode procName script = do
+ procOutput <- liftIO $ newTVarIO []
+ statusVar <- liftIO $ newEmptyMVar
+ ( pstdin, procStdin ) <- liftIO $ createPipe
+ ( hout, pstdout ) <- liftIO $ createPipe
+ ( herr, pstderr ) <- liftIO $ createPipe
+ procHandle <- fmap (Right . (, statusVar)) $ forkTest $ do
+ executeScript procNode procName pstdin pstdout pstderr script
+ liftIO $ putMVar statusVar ExitSuccess
+
+ let procKillWith = Nothing
+ let process = Process {..}
+
+ void $ forkTest $ lineReadingLoop process hout $ \line -> do
+ outProc OutputChildStdout process line
+ liftIO $ atomically $ modifyTVar procOutput (++ [ line ])
+ void $ forkTest $ lineReadingLoop process herr $ \line -> do
+ outProc OutputChildStderr process line
+
+ return process
+
+withShellProcess :: Node -> ProcName -> ShellScript -> (Process -> TestRun a) -> TestRun a
+withShellProcess node pname script inner = do
+ procVar <- asks $ teProcesses . fst
+
+ process <- spawnShell node pname script
+ liftIO $ modifyMVar_ procVar $ return . (process:)
+
+ inner process `finally` do
+ ps <- liftIO $ takeMVar procVar
+ closeProcess process `finally` do
+ liftIO $ putMVar procVar $ filter (/=process) ps
diff --git a/src/Script/Var.hs b/src/Script/Var.hs
new file mode 100644
index 0000000..668060c
--- /dev/null
+++ b/src/Script/Var.hs
@@ -0,0 +1,56 @@
+module Script.Var (
+ VarName(..), textVarName, unpackVarName,
+ FqVarName(..), textFqVarName, unpackFqVarName, unqualifyName,
+ TypedVarName(..),
+ ModuleName(..), textModuleName,
+ SourceLine(..), textSourceLine,
+) where
+
+import Data.Text (Text)
+import Data.Text qualified as T
+
+
+newtype VarName = VarName Text
+ deriving (Eq, Ord)
+
+textVarName :: VarName -> Text
+textVarName (VarName name) = name
+
+unpackVarName :: VarName -> String
+unpackVarName = T.unpack . textVarName
+
+
+data FqVarName
+ = GlobalVarName ModuleName VarName
+ | LocalVarName VarName
+ deriving (Eq, Ord)
+
+textFqVarName :: FqVarName -> Text
+textFqVarName (GlobalVarName mname vname) = textModuleName mname <> "." <> textVarName vname
+textFqVarName (LocalVarName vname) = textVarName vname
+
+unpackFqVarName :: FqVarName -> String
+unpackFqVarName = T.unpack . textFqVarName
+
+unqualifyName :: FqVarName -> VarName
+unqualifyName (GlobalVarName _ name) = name
+unqualifyName (LocalVarName name) = name
+
+
+newtype TypedVarName a = TypedVarName { fromTypedVarName :: VarName }
+ deriving (Eq, Ord)
+
+
+newtype ModuleName = ModuleName [ Text ]
+ deriving (Eq, Ord, Show)
+
+textModuleName :: ModuleName -> Text
+textModuleName (ModuleName parts) = T.intercalate "." parts
+
+data SourceLine
+ = SourceLine Text
+ | SourceLineBuiltin
+
+textSourceLine :: SourceLine -> Text
+textSourceLine (SourceLine text) = text
+textSourceLine SourceLineBuiltin = "<builtin>"
diff --git a/src/Test.hs b/src/Test.hs
index ba27153..b8c5049 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -1,235 +1,50 @@
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
+import Script.Shell
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) <> "]"
-
- exprListUnpacker _ = Just $ ExprListUnpacker id (const Proxy)
-
-instance ExprType TestBlock where
+data TestBlock a where
+ EmptyTestBlock :: TestBlock ()
+ TestBlockStep :: TestBlock () -> TestStep a -> TestBlock a
+
+instance Semigroup (TestBlock ()) where
+ EmptyTestBlock <> block = block
+ block <> EmptyTestBlock = block
+ block <> TestBlockStep block' step = TestBlockStep (block <> block') step
+
+instance Monoid (TestBlock ()) where
+ mempty = EmptyTestBlock
+
+data TestStep a where
+ Subnet :: TypedVarName Network -> Network -> (Network -> TestBlock a) -> TestStep a
+ DeclNode :: TypedVarName Node -> Network -> (Node -> TestBlock a) -> TestStep a
+ Spawn :: TypedVarName Process -> Either Network Node -> (Process -> TestBlock a) -> TestStep a
+ SpawnShell :: TypedVarName Process -> Node -> ShellScript -> (Process -> TestBlock a) -> TestStep a
+ Send :: Process -> Text -> TestStep ()
+ Expect :: SourceLine -> Process -> Traced Regex -> [ TypedVarName Text ] -> ([ Text ] -> TestBlock a) -> TestStep a
+ Flush :: Process -> Maybe Regex -> TestStep ()
+ Guard :: SourceLine -> EvalTrace -> Bool -> TestStep ()
+ DisconnectNode :: Node -> TestBlock a -> TestStep a
+ DisconnectNodes :: Network -> TestBlock a -> TestStep a
+ DisconnectUpstream :: Network -> TestBlock a -> TestStep a
+ PacketLoss :: Scientific -> Node -> TestBlock a -> TestStep a
+ Wait :: TestStep ()
+
+instance Typeable a => ExprType (TestBlock a) 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]
diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs
index 9deb2df..69579bc 100644
--- a/src/Test/Builtins.hs
+++ b/src/Test/Builtins.hs
@@ -2,12 +2,56 @@ module Test.Builtins (
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 )
+
+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 -> TestBlockStep EmptyTestBlock $ 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 -> TestBlockStep EmptyTestBlock $ 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 -> TestBlockStep EmptyTestBlock $ Guard sline (getArgVars args Nothing) (getArg args Nothing)
-builtinWait :: TestBlock
-builtinWait = TestBlock [ Wait ]
+builtinWait :: SomeVarValue
+builtinWait = someConstValue $ TestBlockStep EmptyTestBlock Wait
diff --git a/src/Wrapper.hs b/src/Wrapper.hs
deleted file mode 100644
index 544e37c..0000000
--- a/src/Wrapper.hs
+++ /dev/null
@@ -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"
diff --git a/src/main.c b/src/main.c
new file mode 100644
index 0000000..98daf2c
--- /dev/null
+++ b/src/main.c
@@ -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;
+}
generated by cgit v1.2.3 (git 2.25.1) at 2025-07-12 01:34:14 +0000