summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Config.hs54
-rw-r--r--src/GDB.hs7
-rw-r--r--src/Main.hs97
-rw-r--r--src/Network.hs4
-rw-r--r--src/Network/Ip.hs40
-rw-r--r--src/Output.hs154
-rw-r--r--src/Parser.hs53
-rw-r--r--src/Parser/Core.hs227
-rw-r--r--src/Parser/Expr.hs227
-rw-r--r--src/Parser/Shell.hs98
-rw-r--r--src/Parser/Statement.hs76
-rw-r--r--src/Process.hs195
-rw-r--r--src/Process/Signal.hs88
-rw-r--r--src/Run.hs249
-rw-r--r--src/Run/Monad.hs39
-rw-r--r--src/Sandbox.hs16
-rw-r--r--src/Script/Expr.hs312
-rw-r--r--src/Script/Expr/Class.hs35
-rw-r--r--src/Script/Object.hs53
-rw-r--r--src/Script/Shell.hs224
-rw-r--r--src/Script/Var.hs10
-rw-r--r--src/Test.hs80
-rw-r--r--src/Test/Builtins.hs91
-rw-r--r--src/TestMode.hs117
-rw-r--r--src/main.c126
-rw-r--r--src/shell.c8
26 files changed, 2078 insertions, 602 deletions
diff --git a/src/Config.hs b/src/Config.hs
index 7f5895c..af2161a 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -2,11 +2,14 @@ module Config (
Config(..),
findConfig,
parseConfig,
+ getConfigTestFiles,
) where
import Control.Monad.Combinators
import Data.ByteString.Lazy qualified as BS
+import Data.Scientific
+import Data.Text (Text)
import Data.Text qualified as T
import Data.YAML
@@ -16,31 +19,41 @@ import System.FilePath
import System.FilePath.Glob
data Config = Config
- { configTool :: Maybe FilePath
- , configTests :: [Pattern]
+ { configDir :: FilePath
+ , configTool :: Maybe FilePath
+ , configTests :: [ Pattern ]
+ , configSelect :: Maybe [ Text ]
+ , configExclude :: [ Text ]
+ , configTimeout :: Maybe Scientific
}
deriving (Show)
-instance Semigroup Config where
- a <> b = Config
- { configTool = maybe (configTool b) Just (configTool a)
- , configTests = configTests a ++ configTests b
- }
-
-instance Monoid Config where
- mempty = Config
- { configTool = Nothing
- , configTests = []
- }
-
-instance FromYAML Config where
- parseYAML = withMap "Config" $ \m -> Config
- <$> (fmap T.unpack <$> m .:? "tool")
- <*> (map (compile . T.unpack) <$> foldr1 (<|>)
+instance FromYAML (FilePath -> Config) where
+ parseYAML = withMap "Config" $ \m -> do
+ configTool <- (fmap T.unpack <$> m .:? "tool")
+ configTests <- (map (compile . T.unpack) <$> foldr1 (<|>)
[ fmap (:[]) (m .: "tests") -- single pattern
, m .:? "tests" .!= [] -- list of patterns
]
)
+ configSelect <- foldr1 (<|>)
+ [ fmap (Just . (: [])) (m .: "select") -- single item
+ , m .:? "select" -- list of items
+ ]
+ configExclude <- foldr1 (<|>)
+ [ fmap (: []) (m .: "exclude") -- single item
+ , m .:? "exclude" .!= [] -- list of items
+ ]
+ configTimeout <- fmap fromNumber <$> m .:! "timeout"
+ return $ \configDir -> Config {..}
+
+newtype Number = Number { fromNumber :: Scientific }
+
+instance FromYAML Number where
+ parseYAML = \case
+ Scalar _ (SFloat x) -> return $ Number $ realToFrac x
+ Scalar _ (SInt x) -> return $ Number $ fromIntegral x
+ node -> typeMismatch "int or float" node
findConfig :: IO (Maybe FilePath)
findConfig = go "."
@@ -63,4 +76,7 @@ parseConfig path = do
Left (pos, err) -> do
putStr $ prettyPosWithSource pos contents err
exitFailure
- Right conf -> return conf
+ Right conf -> return $ conf $ takeDirectory path
+
+getConfigTestFiles :: Config -> IO [ FilePath ]
+getConfigTestFiles config = concat <$> mapM (flip globDir1 $ configDir config) (configTests config)
diff --git a/src/GDB.hs b/src/GDB.hs
index 0819600..4151946 100644
--- a/src/GDB.hs
+++ b/src/GDB.hs
@@ -72,14 +72,19 @@ gdbStart onCrash = do
{ std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe
}
pout <- liftIO $ newTVarIO []
+ ignore <- liftIO $ newTVarIO ( 0, [] )
+ pid <- liftIO $ getPid handle
let process = Process
- { procName = ProcNameGDB
+ { procId = ProcessId (-2)
+ , procName = ProcNameGDB
, procHandle = Left handle
, procStdin = hin
, procOutput = pout
+ , procIgnore = ignore
, procKillWith = Nothing
, procNode = undefined
+ , procPid = pid
}
gdb <- GDB
<$> pure process
diff --git a/src/Main.hs b/src/Main.hs
index 48f95df..7adf71d 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -2,31 +2,27 @@ module Main (main) where
import Control.Monad
-import Data.Bifunctor
-import Data.List
+import Data.Char
import Data.Maybe
+import Data.Text (Text)
import Data.Text qualified as T
import Text.Read (readMaybe)
-import Text.Megaparsec (errorBundlePretty, showErrorComponent)
import System.Console.GetOpt
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
-import System.FilePath.Glob
import System.IO
import System.Posix.Terminal
import System.Posix.Types
import Config
import Output
-import Parser
+import Parser.Core
import Process
import Run
-import Script.Module
-import Test
import TestMode
import Util
import Version
@@ -34,24 +30,34 @@ import Version
data CmdlineOptions = CmdlineOptions
{ optTest :: TestOptions
, optRepeat :: Int
+ , optExclude :: [ Text ]
, optVerbose :: Bool
, optColor :: Maybe Bool
, optShowHelp :: Bool
, optShowVersion :: Bool
, optTestMode :: Bool
+ , optCmdlineTcpdump :: TcpdumpOption
}
defaultCmdlineOptions :: CmdlineOptions
defaultCmdlineOptions = CmdlineOptions
{ optTest = defaultTestOptions
, optRepeat = 1
+ , optExclude = []
, optVerbose = False
, optColor = Nothing
, optShowHelp = False
, optShowVersion = False
, optTestMode = False
+ , optCmdlineTcpdump = TcpdumpAuto
}
+data TcpdumpOption
+ = TcpdumpAuto
+ | TcpdumpManual FilePath
+ | TcpdumpOff
+
+
options :: [ OptDescr (CmdlineOptions -> CmdlineOptions) ]
options =
[ Option ['T'] ["tool"]
@@ -86,9 +92,18 @@ options =
, Option ['r'] ["repeat"]
(ReqArg (\str opts -> opts { optRepeat = read str }) "<count>")
"number of times to repeat the test(s)"
+ , Option [ 'e' ] [ "exclude" ]
+ (ReqArg (\str opts -> opts { optExclude = T.pack str : optExclude opts }) "<test|tag>")
+ "exclude given test or test tag from execution"
, Option [] ["wait"]
(NoArg $ to $ \opts -> opts { optWait = True })
"wait at the end of each test"
+ , Option [] [ "no-tcpdump" ]
+ (NoArg (\opts -> opts { optCmdlineTcpdump = TcpdumpOff }))
+ "do not run tcpdump to capture network traffic"
+ , Option [] [ "tcpdump" ]
+ (OptArg (\str opts -> opts { optCmdlineTcpdump = maybe TcpdumpAuto TcpdumpManual str }) "<path>")
+ "use tcpdump to capture network traffic, at given <path> or found in PATH"
, Option ['h'] ["help"]
(NoArg $ \opts -> opts { optShowHelp = True })
"show this help and exit"
@@ -108,9 +123,8 @@ hiddenOptions =
main :: IO ()
main = do
- configPath <- findConfig
- config <- mapM parseConfig configPath
- let baseDir = maybe "." dropFileName configPath
+ config <- mapM parseConfig =<< findConfig
+ let baseDir = maybe "." configDir config
envtool <- lookupEnv "EREBOS_TEST_TOOL" >>= \mbtool ->
return $ fromMaybe (error "No test tool defined") $ mbtool `mplus` (return . (baseDir </>) =<< configTool =<< config)
@@ -119,6 +133,7 @@ main = do
{ optTest = defaultTestOptions
{ optDefaultTool = envtool
, optTestDir = normalise $ baseDir </> optTestDir defaultTestOptions
+ , optTimeout = fromMaybe (optTimeout defaultTestOptions) $ configTimeout =<< config
}
}
@@ -151,7 +166,7 @@ main = do
exitSuccess
when (optTestMode opts) $ do
- testMode
+ testMode config
exitSuccess
case words $ optDefaultTool $ optTest opts of
@@ -165,7 +180,7 @@ main = do
case span (/= ':') ofile of
(path, ':':test) -> (path, Just $ T.pack test)
(path, _) -> (path, Nothing)
- else map (, Nothing) . concat <$> mapM (flip globDir1 baseDir) (maybe [] configTests config)
+ else map (, Nothing) <$> maybe (return []) (getConfigTestFiles) config
when (null files) $ fail $ "No test files"
@@ -177,43 +192,35 @@ main = do
| otherwise = OutputStyleQuiet
out <- startOutput outputStyle useColor
- ( modules, allModules ) <- parseTestFiles (map fst files) >>= \case
- Right res -> do
- return res
- Left err -> do
- case err of
- ImportModuleError bundle ->
- putStr (errorBundlePretty bundle)
- _ -> do
- putStrLn (showErrorComponent err)
- exitFailure
+ lm@LoadedModules {..} <- exitOnError =<< loadModules files
+
+ let tfSelect = if null otests then Nothing else Just otests
+ tfExclude = optExclude opts
+ tfilter = maybe mempty testFilterFromConfig config <> TestFilter {..}
+ tests <- exitOnError $ filterTests tfilter lm
- tests <- if null otests
- then fmap concat $ forM (zip modules files) $ \( Module {..}, ( filePath, mbTestName )) -> do
- case mbTestName of
- Nothing -> return moduleTests
- Just name
- | Just test <- find ((name ==) . testName) moduleTests
- -> return [ test ]
- | otherwise
- -> do
- hPutStrLn stderr $ "Test ‘" <> T.unpack name <> "’ not found in ‘" <> filePath <> "’"
- exitFailure
- else forM otests $ \name -> if
- | Just test <- find ((name ==) . testName) $ concatMap moduleTests modules
- -> return test
- | otherwise
- -> do
- hPutStrLn stderr $ "Test ‘" <> T.unpack name <> "’ not found"
- exitFailure
-
-
- let globalDefs = evalGlobalDefs $ concatMap (\m -> map (first ( moduleName m, )) $ moduleDefinitions m) allModules
-
- ok <- allM (runTest out (optTest opts) globalDefs) $
+ tcpdump <- case optCmdlineTcpdump opts of
+ TcpdumpAuto -> findExecutable "tcpdump"
+ TcpdumpManual path -> return (Just path)
+ TcpdumpOff -> return Nothing
+
+ let topts = (optTest opts)
+ { optTcpdump = tcpdump
+ }
+ ok <- allM (runTest out topts lmGlobalDefs) $
concat $ replicate (optRepeat opts) tests
when (not ok) exitFailure
+exitOnError :: Either CustomTestError a -> IO a
+exitOnError (Left err) = do
+ hPutStrLn stderr $ capitalize $ showCustomTestError err
+ exitFailure
+ where
+ capitalize (c : cs) = toUpper c : cs
+ capitalize [] = []
+exitOnError (Right x) = do
+ return x
+
foreign export ccall testerMain :: IO ()
testerMain :: IO ()
testerMain = main
diff --git a/src/Network.hs b/src/Network.hs
index e12231d..fdc83c6 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -102,11 +102,11 @@ instance HasNetns Node where getNetns = nodeNetns
instance ExprType Network where
textExprType _ = T.pack "network"
- textExprValue n = "s:" <> textNetworkName (netPrefix n)
+ textExprValue n = "<network:" <> textNetworkName (netPrefix n) <> ">"
instance ExprType Node where
textExprType _ = T.pack "node"
- textExprValue n = T.pack "n:" <> textNodeName (nodeName n)
+ textExprValue n = T.pack "<node:" <> textNodeName (nodeName n) <> ">"
recordMembers = map (first T.pack)
[ ( "ifname", RecordSelector $ const ("veth0" :: Text) )
diff --git a/src/Network/Ip.hs b/src/Network/Ip.hs
index 8f0887a..69a6b43 100644
--- a/src/Network/Ip.hs
+++ b/src/Network/Ip.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
module Network.Ip (
IpPrefix(..),
textIpNetwork,
@@ -17,7 +19,9 @@ module Network.Ip (
NetworkNamespace,
HasNetns(..),
addNetworkNamespace,
+ setNetworkNamespace,
textNetnsName,
+ runInNetworkNamespace,
callOn,
Link(..),
@@ -32,7 +36,9 @@ module Network.Ip (
addRoute,
) where
+import Control.Concurrent
import Control.Concurrent.STM
+import Control.Exception
import Control.Monad
import Control.Monad.Writer
@@ -42,6 +48,11 @@ import Data.Text qualified as T
import Data.Typeable
import Data.Word
+import Foreign.C.Error
+import Foreign.C.Types
+
+import System.Posix.IO
+import System.Posix.Types
import System.Process
newtype IpPrefix = IpPrefix [Word8]
@@ -122,12 +133,37 @@ addNetworkNamespace netnsName = do
netnsRoutesActive <- liftSTM $ newTVar []
return $ NetworkNamespace {..}
+setNetworkNamespace :: MonadIO m => NetworkNamespace -> m ()
+setNetworkNamespace netns = liftIO $ do
+ let path = "/var/run/netns/" <> T.unpack (textNetnsName netns)
+#if MIN_VERSION_unix(2,8,0)
+ open = openFd path ReadOnly defaultFileFlags { cloexec = True }
+#else
+ open = openFd path ReadOnly Nothing defaultFileFlags
+#endif
+ res <- bracket open closeFd $ \(Fd fd) -> do
+ c_setns fd c_CLONE_NEWNET
+ when (res /= 0) $ do
+ throwErrno "setns failed"
+
+foreign import ccall unsafe "sched.h setns" c_setns :: CInt -> CInt -> IO CInt
+c_CLONE_NEWNET :: CInt
+c_CLONE_NEWNET = 0x40000000
+
+runInNetworkNamespace :: NetworkNamespace -> IO a -> IO a
+runInNetworkNamespace netns act = do
+ mvar <- newEmptyMVar
+ void $ forkOS $ do
+ setNetworkNamespace netns
+ putMVar mvar =<< act
+ takeMVar mvar
+
+
textNetnsName :: NetworkNamespace -> Text
textNetnsName = netnsName
callOn :: HasNetns a => a -> Text -> IO ()
-callOn n cmd = callCommand $ T.unpack $ "ip netns exec \"" <> ns <> "\" " <> cmd
- where ns = textNetnsName $ getNetns n
+callOn n cmd = runInNetworkNamespace (getNetns n) $ callCommand $ T.unpack cmd
data Link a = Link
diff --git a/src/Output.hs b/src/Output.hs
index 7c4a8a5..1201d72 100644
--- a/src/Output.hs
+++ b/src/Output.hs
@@ -9,6 +9,7 @@ module Output (
) where
import Control.Concurrent.MVar
+import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
@@ -24,6 +25,8 @@ import System.IO
import Text.Printf
+import Script.Expr
+
data Output = Output
{ outState :: MVar OutputState
, outConfig :: OutputConfig
@@ -47,13 +50,17 @@ data OutputStyle
deriving (Eq)
data OutputType
- = OutputChildStdout
+ = OutputGlobalInfo
+ | OutputGlobalError
+ | OutputChildStdout
| OutputChildStderr
| OutputChildStdin
+ | OutputChildExec
| OutputChildInfo
| OutputChildFail
| OutputMatch
- | OutputMatchFail
+ | OutputMatchFail CallStack
+ | OutputIgnored
| OutputError
| OutputAlways
| OutputTestRaw
@@ -77,55 +84,79 @@ resetOutputTime Output {..} = do
modifyMVar_ outStartedAt . const $ getTime Monotonic
outColor :: OutputType -> Text
-outColor OutputChildStdout = T.pack "0"
-outColor OutputChildStderr = T.pack "31"
-outColor OutputChildStdin = T.pack "0"
-outColor OutputChildInfo = T.pack "0"
-outColor OutputChildFail = T.pack "31"
-outColor OutputMatch = T.pack "32"
-outColor OutputMatchFail = T.pack "31"
-outColor OutputError = T.pack "31"
-outColor OutputAlways = "0"
-outColor OutputTestRaw = "0"
+outColor = \case
+ OutputGlobalInfo -> "0"
+ OutputGlobalError -> "31"
+ OutputChildStdout -> "0"
+ OutputChildStderr -> "31"
+ OutputChildStdin -> "0"
+ OutputChildExec -> "33"
+ OutputChildInfo -> "0"
+ OutputChildFail -> "31"
+ OutputMatch -> "32"
+ OutputMatchFail {} -> "31"
+ OutputIgnored -> "90"
+ OutputError -> "31"
+ OutputAlways -> "0"
+ OutputTestRaw -> "0"
outSign :: OutputType -> Text
-outSign OutputChildStdout = T.empty
-outSign OutputChildStderr = T.pack "!"
-outSign OutputChildStdin = T.empty
-outSign OutputChildInfo = T.pack "."
-outSign OutputChildFail = T.pack "!!"
-outSign OutputMatch = T.pack "+"
-outSign OutputMatchFail = T.pack "/"
-outSign OutputError = T.pack "!!"
-outSign OutputAlways = T.empty
-outSign OutputTestRaw = T.empty
+outSign = \case
+ OutputGlobalInfo -> ""
+ OutputGlobalError -> ""
+ OutputChildStdout -> " "
+ OutputChildStderr -> "!"
+ OutputChildStdin -> T.empty
+ OutputChildExec -> "*"
+ OutputChildInfo -> "."
+ OutputChildFail -> "!!"
+ OutputMatch -> "+"
+ OutputMatchFail {} -> "/"
+ OutputIgnored -> "-"
+ OutputError -> "!!"
+ OutputAlways -> T.empty
+ OutputTestRaw -> T.empty
outArr :: OutputType -> Text
-outArr OutputChildStdin = "<"
-outArr _ = ">"
+outArr = \case
+ OutputGlobalInfo -> ""
+ OutputGlobalError -> ""
+ OutputChildStdin -> "<"
+ _ -> ">"
outTestLabel :: OutputType -> Text
outTestLabel = \case
+ OutputGlobalInfo -> "global-info"
+ OutputGlobalError -> "global-error"
OutputChildStdout -> "child-stdout"
OutputChildStderr -> "child-stderr"
OutputChildStdin -> "child-stdin"
+ OutputChildExec -> "child-exec"
OutputChildInfo -> "child-info"
OutputChildFail -> "child-fail"
OutputMatch -> "match"
- OutputMatchFail -> "match-fail"
+ OutputMatchFail {} -> "match-fail"
+ OutputIgnored -> "ignored"
OutputError -> "error"
OutputAlways -> "other"
OutputTestRaw -> ""
printWhenQuiet :: OutputType -> Bool
printWhenQuiet = \case
+ OutputGlobalError -> True
OutputChildStderr -> True
OutputChildFail -> True
- OutputMatchFail -> True
+ OutputMatchFail {} -> True
OutputError -> True
OutputAlways -> True
_ -> False
+includeTestTime :: OutputType -> Bool
+includeTestTime = \case
+ OutputGlobalInfo -> False
+ OutputGlobalError -> False
+ _ -> True
+
ioWithOutput :: MonadOutput m => (Output -> IO a) -> m a
ioWithOutput act = liftIO . act =<< getOutput
@@ -142,27 +173,62 @@ outLine otype prompt line = ioWithOutput $ \out ->
stime <- readMVar (outStartedAt out)
nsecs <- toNanoSecs . (`diffTimeSpec` stime) <$> getTime Monotonic
withMVar (outState out) $ \st -> do
- outPrint st $ TL.fromChunks $ concat
- [ [ 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 ]
- , [ line ]
- , if outUseColor (outConfig out)
- then [ T.pack "\ESC[0m" ]
- else []
- ]
+ forM_ (normalOutputLines otype line) $ \line' -> do
+ outPrint st $ TL.fromChunks $ concat
+ [ if includeTestTime otype
+ then [ T.pack $ printf "[% 2d.%03d] " (nsecs `quot` 1000000000) ((nsecs `quot` 1000000) `rem` 1000) ]
+ else []
+ , if outUseColor (outConfig out)
+ then [ T.pack "\ESC[", outColor otype, T.pack "m" ]
+ else []
+ , [ maybe "" (<> outSign otype <> outArr otype <> " ") prompt ]
+ , [ line' ]
+ , if outUseColor (outConfig out)
+ then [ T.pack "\ESC[0m" ]
+ else []
+ ]
testOutput out = do
withMVar (outState out) $ \st -> do
- outPrint st $ case otype of
- OutputTestRaw -> TL.fromStrict line
- _ -> TL.fromChunks
- [ outTestLabel otype, " "
- , maybe "-" id prompt, " "
- , line
- ]
+ case otype of
+ OutputTestRaw -> outPrint st $ TL.fromStrict line
+ _ -> forM_ (testOutputLines otype (maybe "-" id prompt) line) $ outPrint st . TL.fromStrict
+
+
+normalOutputLines :: OutputType -> Text -> [ Text ]
+normalOutputLines (OutputMatchFail (CallStack stack)) msg = concat
+ [ msg <> " on " <> textSourceLine stackTopLine : showVars stackTopVars
+ , concat $ flip map stackRest $ \( sline, vars ) ->
+ " called from " <> textSourceLine sline : showVars vars
+ ]
+ where
+ showVars =
+ map $ \(( name, sel ), value ) -> T.concat
+ [ " ", textFqVarName name, T.concat (map ("."<>) sel)
+ , " = ", textSomeVarValue value
+ ]
+ (( stackTopLine, stackTopVars ), stackRest ) =
+ case stack of
+ (stop : srest) -> ( stop, srest )
+ [] -> (( SourceLine "unknown", [] ), [] )
+normalOutputLines _ msg = [ msg ]
+
+
+testOutputLines :: OutputType -> Text -> Text -> [ Text ]
+testOutputLines otype@(OutputMatchFail (CallStack stack)) _ msg = concat
+ [ [ T.concat [ outTestLabel otype, " ", msg ] ]
+ , concat $ flip map stack $ \( sline, vars ) ->
+ T.concat [ outTestLabel otype, "-line ", textSourceLine sline ] : showVars vars
+ , [ T.concat [ outTestLabel otype, "-done" ] ]
+ ]
+ where
+ showVars =
+ map $ \(( name, sel ), value ) -> T.concat
+ [ outTestLabel otype, "-var ", textFqVarName name, T.concat (map ("."<>) sel)
+ , " ", textSomeVarValue value
+ ]
+testOutputLines otype prompt msg = [ T.concat [ outTestLabel otype, " ", prompt, " ", msg ] ]
+
outPromptGetLine :: MonadOutput m => Text -> m (Maybe Text)
outPromptGetLine = outPromptGetLineCompletion noCompletion
diff --git a/src/Parser.hs b/src/Parser.hs
index 0716457..ed03f3f 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -43,12 +43,35 @@ parseTestDefinition = label "test definition" $ toplevel ToplevelTest $ do
modify $ \s -> s
{ testContext = SomeExpr $ varExpr SourceLineBuiltin rootNetworkVar
}
- block (\name steps -> return $ Test name $ mconcat steps) header testStep
+ href <- L.indentLevel
+ testName <- header
+ osymbol ":" <* eol <* scn
+
+ ref <- L.indentGuard scn GT href
+ testTags <- preamble ref
+ testSteps <- fmap Scope <$> testBlock ref
+ return Test {..}
+
where
header = do
wsymbol "test"
lexeme $ TL.toStrict <$> takeWhileP (Just "test name") (/=':')
+ preamble :: Pos -> TestParser [ Expr Tag ]
+ preamble ref = fmap catMaybes $ many $ do
+ void $ L.indentGuard scn EQ ref
+ off <- stateOffset <$> getParserState
+ name <- try $ identifier <* osymbol ":"
+ <* ((eol >> mzero) <|> return ()) -- continue only if not on EOL
+ case name of
+ "tag" -> do
+ Just <$> typedExpr FunctionTerm <* eol <* scn
+ _ -> do
+ registerParseError $ FancyError off $ S.singleton $ ErrorFail $
+ "unexpected test metadata ‘" <> T.unpack name <> "’"
+ takeWhileP Nothing (/= '\n') *> eol *> scn *> return Nothing
+
+
parseDefinition :: Pos -> TestParser ( VarName, SomeExpr )
parseDefinition href = label "symbol definition" $ do
def@( name, expr ) <- localState $ do
@@ -64,10 +87,10 @@ parseDefinition href = label "symbol definition" $ do
osymbol ":"
scn
ref <- L.indentGuard scn GT href
- SomeExpr <$> blockOf ref testStep
+ SomeExpr <$> testBlock ref
, do
osymbol "="
- someExpr <* eol
+ someExpr FunctionTerm <* eol
]
scn
atypes' <- getInferredTypes atypes
@@ -79,11 +102,9 @@ parseDefinition href = label "symbol definition" $ do
getInferredTypes atypes = forM atypes $ \( off, vname, tvar@(TypeVar tvarname) ) -> do
let err msg = do
registerParseError . FancyError off . S.singleton . ErrorFail $ T.unpack msg
- return ( vname, SomeArgumentType (OptionalArgument @DynamicType) )
+ return ( vname, SomeArgumentType OptionalArgument (ExprTypeForall (TypeVar "a") (ExprTypeVar (TypeVar "a"))) )
gets (M.lookup tvar . testTypeUnif) >>= \case
- Just (ExprTypePrim (_ :: Proxy a)) -> return ( vname, SomeArgumentType (RequiredArgument @a) )
- Just (ExprTypeVar (TypeVar tvar')) -> err $ "ambiguous type for ‘" <> textVarName vname <> " : " <> tvar' <> "’"
- Just (ExprTypeFunction {}) -> err $ "unsupported function type of ‘" <> textVarName vname <> "’"
+ Just t -> return ( vname, SomeArgumentType RequiredArgument t )
Nothing -> err $ "ambiguous type for ‘" <> textVarName vname <> " : " <> tvarname <> "’"
replaceDynArgs :: forall a. Expr a -> TestParser (Expr a)
@@ -95,7 +116,7 @@ parseDefinition href = label "symbol definition" $ do
go unif = \case
ArgsApp args body -> ArgsApp (fmap replaceArgs args) body
where
- replaceArgs (SomeExpr (DynVariable tvar sline vname))
+ replaceArgs (SomeExpr (DynVariable (ExprTypeVar tvar) sline vname))
| Just (ExprTypePrim (Proxy :: Proxy v)) <- M.lookup tvar unif
= SomeExpr (Variable sline vname :: Expr v)
replaceArgs (SomeExpr e) = SomeExpr (go unif e)
@@ -125,13 +146,24 @@ parseAsset href = label "asset definition" $ do
modify $ \s -> s { testVars = ( name, ( GlobalVarName (testCurrentModuleName s) name, someExprType expr )) : testVars s }
return ( name, expr )
+parseTag :: Pos -> TestParser ( VarName, SomeExpr )
+parseTag _ = label "tag definition" $ do
+ wsymbol "tag"
+ name <- constrName
+ void eol
+ cmn <- gets testCurrentModuleName
+ let expr = SomeExpr $ Pure $ Tag cmn name
+ modify $ \s -> s { testVars = ( name, ( GlobalVarName cmn name, someExprType expr )) : testVars s }
+ scn
+ return ( name, expr )
+
parseExport :: TestParser [ Toplevel ]
parseExport = label "export declaration" $ toplevel id $ do
ref <- L.indentLevel
wsymbol "export"
choice
[ do
- def@( name, _ ) <- parseDefinition ref <|> parseAsset ref
+ def@( name, _ ) <- parseDefinition ref <|> parseAsset ref <|> parseTag ref
return [ ToplevelDefinition def, ToplevelExport name ]
, do
names <- listOf varName
@@ -168,6 +200,7 @@ parseTestModule absPath = do
[ (: []) <$> parseTestDefinition
, (: []) <$> toplevel ToplevelDefinition (parseDefinition pos1)
, (: []) <$> toplevel ToplevelDefinition (parseAsset pos1)
+ , (: []) <$> toplevel ToplevelDefinition (parseTag pos1)
, parseExport
, parseImport
]
@@ -201,7 +234,7 @@ parseTestFile parsedModules mbModuleName path = do
let initState = TestParserState
{ testSourcePath = path
, testVars = concat
- [ map (\(( mname, name ), value ) -> ( name, ( GlobalVarName mname name, someVarValueType value ))) $ M.toList builtins
+ [ map (\(( mname, name ), value ) -> ( name, ( GlobalVarName mname name, someExprType value ))) $ M.toList builtins
]
, testContext = SomeExpr (Undefined "void" :: Expr Void)
, testNextTypeVar = 0
diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs
index 132dbc8..25c7346 100644
--- a/src/Parser/Core.hs
+++ b/src/Parser/Core.hs
@@ -1,6 +1,7 @@
module Parser.Core where
import Control.Applicative
+import Control.Arrow
import Control.Monad
import Control.Monad.State
@@ -8,6 +9,7 @@ import Data.Map (Map)
import Data.Map qualified as M
import Data.Maybe
import Data.Set qualified as S
+import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Data.Typeable
@@ -18,6 +20,7 @@ import qualified Text.Megaparsec.Char.Lexer as L
import Network ()
import Script.Expr
+import Script.Expr.Class
import Script.Module
import Test
@@ -38,6 +41,8 @@ type TestParseError = ParseError TestStream CustomTestError
data CustomTestError
= ModuleNotFound ModuleName
| FileNotFound FilePath
+ | TestNotFound Text (Maybe FilePath)
+ | TestOrTagNotFound Text (Maybe FilePath)
| ImportModuleError (ParseErrorBundle TestStream CustomTestError)
deriving (Eq)
@@ -50,15 +55,30 @@ instance Ord CustomTestError where
compare (FileNotFound _) _ = LT
compare _ (FileNotFound _) = GT
+ compare (TestNotFound a a') (TestNotFound b b') = compare ( a, a' ) ( b, b' )
+ compare (TestNotFound _ _ ) _ = LT
+ compare _ (TestNotFound _ _ ) = GT
+
+ compare (TestOrTagNotFound a a') (TestOrTagNotFound b b') = compare ( a, a' ) ( b, b' )
+ compare (TestOrTagNotFound _ _ ) _ = LT
+ compare _ (TestOrTagNotFound _ _ ) = GT
+
-- Ord instance is required to store errors in Set, but there shouldn't be
-- two ImportModuleErrors at the same possition, so "dummy" comparison
-- should be ok.
compare (ImportModuleError _) (ImportModuleError _) = EQ
instance ShowErrorComponent CustomTestError where
- showErrorComponent (ModuleNotFound name) = "module ‘" <> T.unpack (textModuleName name) <> "’ not found"
- showErrorComponent (FileNotFound path) = "file ‘" <> path <> "’ not found"
showErrorComponent (ImportModuleError bundle) = "error parsing imported module:\n" <> errorBundlePretty bundle
+ showErrorComponent err = showCustomTestError err
+
+showCustomTestError :: CustomTestError -> String
+showCustomTestError = \case
+ ModuleNotFound name -> "module ‘" <> T.unpack (textModuleName name) <> "’ not found"
+ FileNotFound path -> "file ‘" <> path <> "’ not found"
+ TestNotFound tname mbpath -> "test ‘" <> T.unpack tname <> "’ not found" <> maybe "" (\path -> " in ‘" <> path <> "’") mbpath
+ TestOrTagNotFound tname mbpath -> "test or tag ‘" <> T.unpack tname <> "’ not found" <> maybe "" (\path -> " in ‘" <> path <> "’") mbpath
+ ImportModuleError bundle -> errorBundlePretty bundle
runTestParser :: TestStream -> TestParserState -> TestParser a -> IO (Either (ParseErrorBundle TestStream CustomTestError) a)
runTestParser content initState (TestParser parser) = flip (flip runParserT (testSourcePath initState)) content . flip evalStateT initState $ parser
@@ -104,17 +124,39 @@ 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))
+ ExprTypeConstr1 _ -> return $ SomeExpr $ (Undefined "incomplete type" :: Expr DynamicType)
+ ExprTypeFunction args (ExprTypePrim (_ :: Proxy a)) -> return $ SomeExpr $ (FunVariable args sline fqn :: Expr (FunctionType a))
+ stype -> return $ SomeExpr $ DynVariable stype sline fqn
lookupScalarVarExpr :: Int -> SourceLine -> VarName -> TestParser SomeExpr
lookupScalarVarExpr off sline name = do
( fqn, etype ) <- lookupVarType off name
case etype of
ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable sline fqn :: Expr a)
- ExprTypeVar tvar -> return $ SomeExpr $ DynVariable tvar sline fqn
- ExprTypeFunction args (pa :: Proxy a) -> do
+ ExprTypeConstr1 _ -> return $ SomeExpr $ (Undefined "incomplete type" :: Expr DynamicType)
+ ExprTypeFunction args (ExprTypePrim (pa :: Proxy a)) -> do
SomeExpr <$> unifyExpr off pa (FunVariable args sline fqn :: Expr (FunctionType a))
+ stype -> return $ SomeExpr $ DynVariable stype sline fqn
+
+
+resolveKnownTypeVars :: SomeExprType -> TestParser SomeExprType
+resolveKnownTypeVars stype = case stype of
+ ExprTypePrim {} -> return stype
+ ExprTypeConstr1 {} -> return stype
+ ExprTypeVar tvar -> do
+ gets (M.lookup tvar . testTypeUnif) >>= \case
+ Just stype' -> resolveKnownTypeVars stype'
+ Nothing -> return stype
+ ExprTypeFunction args body -> ExprTypeFunction <$> resolveKnownTypeVars args <*> resolveKnownTypeVars body
+ ExprTypeArguments args -> ExprTypeArguments <$> mapM (\(SomeArgumentType a t) -> SomeArgumentType a <$> resolveKnownTypeVars t) args
+ ExprTypeApp ctor params -> do
+ ctor' <- resolveKnownTypeVars ctor
+ params' <- mapM resolveKnownTypeVars params
+ return $ case ( ctor', params' ) of
+ ( ExprTypeConstr1 (Proxy :: Proxy c'), [ ExprTypePrim (Proxy :: Proxy p') ] )
+ -> ExprTypePrim (Proxy :: Proxy (c' p'))
+ _ -> ExprTypeApp ctor' params'
+ ExprTypeForall tvar inner -> ExprTypeForall tvar <$> resolveKnownTypeVars inner
unify :: Int -> SomeExprType -> SomeExprType -> TestParser SomeExprType
unify _ (ExprTypeVar aname) (ExprTypeVar bname) | aname == bname = do
@@ -171,9 +213,53 @@ unify _ res@(ExprTypePrim (Proxy :: Proxy a)) (ExprTypePrim (Proxy :: Proxy b))
| Just (Refl :: a :~: b) <- eqT
= return res
+unify _ res@(ExprTypeConstr1 (Proxy :: Proxy a)) (ExprTypeConstr1 (Proxy :: Proxy b))
+ | Just (Refl :: a :~: b) <- eqT
+ = return res
+
+unify off (ExprTypeFunction args res) (ExprTypeFunction args' res')
+ = ExprTypeFunction
+ <$> unify off args args'
+ <*> unify off res res'
+
+unify off (ExprTypeApp ac aparams) (ExprTypeApp bc bparams)
+ | length aparams == length bparams
+ = do
+ c <- unify off ac bc
+ params <- zipWithM (unify off) aparams bparams
+ return $ case ( c, params ) of
+ ( ExprTypeConstr1 (Proxy :: Proxy c'), [ ExprTypePrim (Proxy :: Proxy p') ] )
+ -> ExprTypePrim (Proxy :: Proxy (c' p'))
+ _ -> ExprTypeApp c params
+
+unify off a@(ExprTypeApp {}) (ExprTypePrim bproxy)
+ | TypeDeconstructor1 c p <- matchTypeConstructor bproxy
+ = unify off a (ExprTypeApp (ExprTypeConstr1 c) [ ExprTypePrim p ])
+
+unify off (ExprTypePrim aproxy) b@(ExprTypeApp {})
+ | TypeDeconstructor1 c p <- matchTypeConstructor aproxy
+ = unify off (ExprTypeApp (ExprTypeConstr1 c) [ ExprTypePrim p ]) b
+
unify off a b = do
parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
- "couldn't match expected type `" <> textSomeExprType a <> "' with actual type `" <> textSomeExprType b <> "'"
+ "couldn't match expected type ‘" <> textSomeExprType a <> "’ with actual type ‘" <> textSomeExprType b <> "’"
+
+
+unifyArguments
+ :: FunctionArguments SomeArgumentType
+ -> FunctionArguments ( Int, SomeExpr )
+ -> TestParser ( FunctionArguments SomeExpr, ( FunctionArguments SomeArgumentType, FunctionArguments ( Int, SomeExpr ) ) )
+unifyArguments (FunctionArguments am) (FunctionArguments bm) = (toArgs *** (toArgs *** toArgs)) <$> go (M.toAscList am) (M.toAscList bm)
+ where
+ toArgs = FunctionArguments . M.fromAscList
+ go [] bs = return ( [], ( [], bs ) )
+ go as [] = return ( [], ( as, [] ) )
+ go (a@( ak, SomeArgumentType _ at ) : as) (b@( bk, ( off, expr ) ) : bs)
+ | ak < bk = second (first (a :)) <$> go as (b : bs)
+ | bk < ak = second (second (b :)) <$> go (a : as) bs
+ | otherwise = do
+ expr' <- unifySomeExpr off at expr
+ first (( ak, expr' ) :) <$> go as bs
unifyExpr :: forall a b proxy. (ExprType a, ExprType b) => Int -> proxy a -> Expr b -> TestParser (Expr a)
@@ -181,27 +267,33 @@ unifyExpr off pa expr = if
| Just (Refl :: a :~: b) <- eqT
-> return expr
- | DynVariable tvar sline name <- expr
+ | DynVariable stype sline name <- expr
+ , ExprTypeForall qvar itype <- stype
-> do
- _ <- unify off (ExprTypePrim (Proxy :: Proxy a)) (ExprTypeVar tvar)
+ tvar <- newTypeVar
+ res <- unify off (ExprTypePrim (Proxy :: Proxy a)) $ renameVarInType qvar tvar itype
+ rtype <- M.lookup tvar <$> gets testTypeUnif
+ return $ ExposePrimType $ TypeApp res (fromMaybe (ExprTypeVar tvar) rtype) (Variable sline name)
+
+ | DynVariable stype sline name <- expr
+ -> do
+ _ <- unify off (ExprTypePrim (Proxy :: Proxy a)) stype
return $ Variable sline name
- | Just (Refl :: FunctionType a :~: b) <- eqT
+ | HidePrimType (_ :: Expr b') <- expr
+ -> unifyExpr off pa (ExposePrimType expr :: Expr b')
+
+ | HideFunType args (_ :: Expr (FunctionType b')) <- expr
+ -> unifyExpr off pa (ExposeFunType args expr :: Expr (FunctionType b'))
+
+ | TypeLambda tvar t f <- expr
-> do
- let FunctionArguments remaining = exprArgs expr
- showType ( Nothing, SomeArgumentType atype ) = "`<" <> textExprType atype <> ">'"
- showType ( Just (ArgumentKeyword kw), SomeArgumentType atype ) = "`" <> kw <> " <" <> textExprType atype <> ">'"
- err = parseError . FancyError off . S.singleton . ErrorFail . T.unpack
-
- 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)
+ _ <- unify off (ExprTypePrim (Proxy :: Proxy a)) t
+ Just (ExprTypePrim pt) <- M.lookup tvar <$> gets testTypeUnif
+ unifyExpr off pa (f $ ExprTypePrim pt)
+
+ | Just (Refl :: FunctionType a :~: b) <- eqT
+ -> evalRemainingArguments off (exprArgs expr) expr
| Just (Refl :: DynamicType :~: b) <- eqT
, Undefined msg <- expr
@@ -211,7 +303,81 @@ unifyExpr off pa expr = if
| otherwise
-> do
parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
- "couldn't match expected type `" <> textExprType pa <> "' with actual type `" <> textExprType expr <> "'"
+ "couldn't match expected type ‘" <> textExprType pa <> "’ with actual type ‘" <> textExprType expr <> "’"
+
+
+evalRemainingArguments :: ExprType a => Int -> FunctionArguments SomeArgumentType -> Expr (FunctionType a) -> TestParser (Expr a)
+evalRemainingArguments off (FunctionArguments remaining) expr = do
+ let showType ( Nothing, SomeArgumentType _ stype ) = "‘<" <> textSomeExprType stype <> ">’"
+ showType ( Just (ArgumentKeyword kw), SomeArgumentType _ stype ) = "‘" <> kw <> " <" <> textSomeExprType stype <> ">’"
+ err = parseError . FancyError off . S.singleton . ErrorFail . T.unpack
+
+ defaults <- fmap catMaybes $ forM (M.toAscList remaining) $ \case
+ arg@( _, SomeArgumentType RequiredArgument _ ) -> err $ "missing " <> showType arg <> " argument"
+ ( _, SomeArgumentType OptionalArgument _ ) -> return Nothing
+ ( kw, SomeArgumentType (ExprDefault def) _ ) -> return $ Just ( kw, def )
+ ( kw, SomeArgumentType ContextDefault (ExprTypePrim atype) ) -> do
+ SomeExpr context <- gets testContext
+ context' <- unifyExpr off atype context
+ return $ Just ( kw, SomeExpr context' )
+ ( _, SomeArgumentType ContextDefault _ ) -> err "non-primitive context requirement"
+ sline <- getSourceLine
+ return (FunctionEval sline $ ArgsApp (FunctionArguments $ M.fromAscList defaults) expr)
+
+
+unifySomeExpr :: Int -> SomeExprType -> SomeExpr -> TestParser SomeExpr
+unifySomeExpr off stype sexpr@(SomeExpr (expr :: Expr a))
+ | ExprTypePrim pa <- stype
+ = SomeExpr <$> unifyExpr off pa expr
+
+ | ExprTypeConstr1 {} <- stype
+ = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ "unification with incomplete type"
+
+ | ExprTypeVar tvar <- stype
+ = do
+ _ <- unify off (ExprTypeVar tvar) (someExprType sexpr)
+ return sexpr
+
+ | Just (Refl :: a :~: DynamicType) <- eqT
+ , ExprTypeForall qvar itype <- someExprType sexpr
+ = do
+ tvar <- newTypeVar
+ itype' <- unify off stype $ renameVarInType qvar tvar itype
+ rtype <- M.lookup tvar <$> gets testTypeUnif
+ return $ SomeExpr (TypeApp itype' (fromMaybe (ExprTypeVar tvar) rtype) expr)
+
+ | ExprTypeFunction args res <- stype
+ = case someExprType sexpr of
+ ExprTypeFunction args' res' -> do
+ _ <- unify off args args'
+ _ <- unify off res res'
+ return sexpr
+ _ -> do
+ _ <- unify off args (ExprTypeArguments mempty)
+ SomeExpr expr' <- unifySomeExpr off res sexpr
+ return $ SomeExpr $ FunctionAbstraction expr'
+
+ | ExprTypeApp _ _ <- stype
+ , ExprTypeFunction args' res' <- someExprType sexpr
+ = do
+ ( _, ( remaining, _ ) ) <- case args' of
+ ExprTypeArguments args'' -> do
+ unifyArguments args'' mempty
+ _ -> do
+ _ <- unify off (ExprTypeArguments mempty) args'
+ return ( mempty, ( mempty, mempty ) )
+ unify off stype res' >>= \case
+ ExprTypePrim (Proxy :: Proxy r) | Just (Refl :: a :~: FunctionType r) <- eqT ->
+ SomeExpr <$> evalRemainingArguments off remaining expr
+ _ | Just (Refl :: a :~: FunctionType DynamicType) <- eqT ->
+ SomeExpr <$> evalRemainingArguments off remaining expr
+ _ ->
+ error $ "expecting function type, got: " <> show (typeRep expr)
+
+ | otherwise
+ = do
+ _ <- unify off stype (someExprType sexpr)
+ return sexpr
skipLineComment :: TestParser ()
@@ -235,7 +401,7 @@ osymbol str = void $ try $ (string (TL.pack str) <* notFollowedBy operatorChar)
wsymbol str = void $ try $ (string (TL.pack str) <* notFollowedBy wordChar) <* sc
operatorChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s)
-operatorChar = satisfy $ (`elem` ['.', '+', '-', '*', '/', '='])
+operatorChar = satisfy $ (`elem` [ '.', '+', '-', '*', '/', '=', '<', '>', '|' ])
{-# INLINE operatorChar #-}
localState :: TestParser a -> TestParser a
@@ -249,15 +415,6 @@ localState inner = do
toplevel :: (a -> b) -> TestParser a -> TestParser b
toplevel f = return . f <=< L.nonIndented scn
-block :: (a -> [b] -> TestParser c) -> TestParser a -> TestParser b -> TestParser c
-block merge header item = L.indentBlock scn $ do
- h <- header
- choice
- [ do symbol ":"
- return $ L.IndentSome Nothing (merge h) item
- , L.IndentNone <$> merge h []
- ]
-
listOf :: TestParser a -> TestParser [a]
listOf item = do
x <- item
diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs
index 079cfba..a0ae70d 100644
--- a/src/Parser/Expr.hs
+++ b/src/Parser/Expr.hs
@@ -4,17 +4,20 @@ module Parser.Expr (
varName,
newVarName,
- addVarName,
+ addVarName, addVarNameType,
+ constrName,
+ TermComplexity(..),
someExpr,
typedExpr,
literal,
variable,
+ constructor,
stringExpansion,
- checkFunctionArguments,
functionArguments,
+ applyFunctionArguments,
) where
import Control.Applicative (liftA2)
@@ -76,12 +79,22 @@ newVarName = do
return name
addVarName :: forall a. ExprType a => Int -> TypedVarName a -> TestParser ()
-addVarName off (TypedVarName name) = do
+addVarName off tname = addVarNameType off tname (ExprTypePrim @a Proxy)
+
+addVarNameType :: forall a. ExprType a => Int -> TypedVarName a -> SomeExprType -> TestParser ()
+addVarNameType off (TypedVarName name) stype = do
gets (lookup name . testVars) >>= \case
Just _ -> registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
T.pack "variable '" <> textVarName name <> T.pack "' already exists"
Nothing -> return ()
- modify $ \s -> s { testVars = ( name, ( LocalVarName name, ExprTypePrim @a Proxy )) : testVars s }
+ modify $ \s -> s { testVars = ( name, ( LocalVarName name, stype )) : testVars s }
+
+constrName :: TestParser VarName
+constrName = label "contructor name" $ do
+ lexeme $ try $ do
+ lead <- upperChar
+ rest <- takeWhileP Nothing (\x -> isAlphaNum x || x == '_')
+ return $ VarName $ TL.toStrict $ TL.fromChunks $ T.singleton lead : TL.toChunks rest
someExpansion :: TestParser SomeExpr
someExpansion = do
@@ -91,7 +104,7 @@ someExpansion = do
sline <- getSourceLine
name <- VarName . TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_')
lookupScalarVarExpr off sline name
- , between (char '{') (char '}') someExpr
+ , between (char '{') (char '}') (someExpr FunctionTerm)
]
expressionExpansion :: forall a. ExprType a => Text -> TestParser (Expr a)
@@ -118,6 +131,13 @@ numberLiteral = label "number" $ lexeme $ do
else return $ SomeExpr $ Pure x
]
+boolLiteral :: TestParser SomeExpr
+boolLiteral = label "bool" $ lexeme $ do
+ SomeExpr . Pure <$> choice
+ [ wsymbol "True" *> return True
+ , wsymbol "False" *> return False
+ ]
+
quotedString :: TestParser (Expr Text)
quotedString = label "string" $ lexeme $ do
void $ char '"'
@@ -142,7 +162,7 @@ quotedString = label "string" $ lexeme $ do
regex :: TestParser (Expr Regex)
regex = label "regular expression" $ lexeme $ do
off <- stateOffset <$> getParserState
- void $ char '/'
+ void $ try $ char '/' <* notFollowedBy (char '=') -- TODO: better parsing rules for regexes
let inner = choice
[ char '/' >> return []
, takeWhile1P Nothing (`notElem` ['/', '\\', '$']) >>= \s -> (Pure (RegexPart (TL.toStrict s)) :) <$> inner
@@ -168,40 +188,51 @@ regex = label "regular expression" $ lexeme $ do
list :: TestParser SomeExpr
list = label "list" $ do
symbol "["
- SomeExpr x <- someExpr
- let enumErr off = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
- "list range enumeration not defined for '" <> textExprType x <> "'"
- let exprList = foldr (liftA2 (:)) (Pure [])
- SomeExpr <$> choice
+ choice
[do symbol "]"
- return $ exprList [x]
-
- ,do off <- stateOffset <$> getParserState
- osymbol ".."
- ExprEnumerator fromTo _ <- maybe (enumErr off) return $ exprEnumerator x
- y <- typedExpr
- symbol "]"
- return $ fromTo <$> x <*> y
-
- ,do symbol ","
- y <- typedExpr
-
- choice
+ tvar <- newTypeVar
+ return $ SomeExpr $
+ TypeLambda tvar (ExprTypeApp (ExprTypeConstr1 (Proxy :: Proxy [])) [ ExprTypeVar tvar ]) $
+ \case
+ (ExprTypePrim (Proxy :: Proxy a)) -> HidePrimType $ Pure ([] :: [ a ])
+ _ -> Undefined "incomplete type"
+
+ ,do SomeExpr x <- someExpr FunctionTerm
+ let enumErr off = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
+ "list range enumeration not defined for ‘" <> textExprType x <> "’"
+ let exprList = foldr (liftA2 (:)) (Pure [])
+
+ SomeExpr <$> choice
[do symbol "]"
- return $ exprList [x, y]
+ return $ exprList [ x ]
,do off <- stateOffset <$> getParserState
osymbol ".."
- ExprEnumerator _ fromThenTo <- maybe (enumErr off) return $ exprEnumerator x
- z <- typedExpr
+ ExprEnumerator fromTo _ <- maybe (enumErr off) return $ exprEnumerator x
+ y <- typedExpr FunctionTerm
symbol "]"
- return $ fromThenTo <$> x <*> y <*> z
+ return $ fromTo <$> x <*> y
,do symbol ","
- xs <- listOf typedExpr
- symbol "]"
- return $ exprList (x:y:xs)
+ y <- typedExpr FunctionTerm
+
+ choice
+ [do symbol "]"
+ return $ exprList [ x, y ]
+
+ ,do off <- stateOffset <$> getParserState
+ osymbol ".."
+ ExprEnumerator _ fromThenTo <- maybe (enumErr off) return $ exprEnumerator x
+ z <- typedExpr FunctionTerm
+ symbol "]"
+ return $ fromThenTo <$> x <*> y <*> z
+
+ ,do symbol ","
+ xs <- listOf (typedExpr FunctionTerm)
+ symbol "]"
+ return $ exprList (x : y : xs)
+ ]
]
]
@@ -224,14 +255,28 @@ applyBinOp off op x y = do
y' <- unifyExpr off (Proxy @b) y
return $ op <$> x' <*> y'
-someExpr :: TestParser SomeExpr
-someExpr = join inner <?> "expression"
+data TermComplexity
+ = SimpleTerm -- variable name, literal or more complex term in parentheses
+ | FunctionTerm -- simple term or function call
+
+someExpr :: TermComplexity -> TestParser SomeExpr
+someExpr complexity = label "expression" $ do
+ case complexity of
+ SimpleTerm -> join termSimple
+ FunctionTerm -> join inner
where
- inner = makeExprParser term table
+ inner = makeExprParser termFunction table
parens = between (symbol "(") (symbol ")")
- term = label "term" $ choice
+ termSimple = label "term" $ choice
+ [ parens inner
+ , return <$> literal
+ , return <$> variable
+ , return <$> constructor
+ ]
+
+ termFunction = label "term" $ choice
[ parens inner
, return <$> literal
, return <$> functionCall
@@ -257,15 +302,30 @@ someExpr = join inner <?> "expression"
, SomeBinOp ((-) @Scientific)
]
]
+ , [ let tvar = TypeVar "a"
+ targs = FunctionArguments $ M.fromList
+ [ ( Just "$l", ( VarName "$l", SomeArgumentType RequiredArgument $ ExprTypeApp (ExprTypeConstr1 (Proxy @[])) [ ExprTypeVar tvar ]) )
+ , ( Just "$r", ( VarName "$r", SomeArgumentType RequiredArgument $ ExprTypeApp (ExprTypeConstr1 (Proxy @[])) [ ExprTypeVar tvar ]) )
+ ]
+ in infixrExpr "++" $ SomeExpr $ TypeLambda tvar (ExprTypeFunction (ExprTypeArguments $ fmap snd targs) (ExprTypeApp (ExprTypeConstr1 (Proxy @[])) [ ExprTypeVar tvar ])) $ \case
+ ExprTypePrim (Proxy :: Proxy a) ->
+ HideFunType (fmap snd targs) $ ArgsReq targs $
+ FunctionAbstraction $ ((++) @a)
+ <$> (Variable SourceLineBuiltin $ LocalVarName $ VarName "$l")
+ <*> (Variable SourceLineBuiltin $ LocalVarName $ VarName "$r")
+ t -> Undefined ("ambiguous type ‘" <> T.unpack (textSomeExprType t) <> "’ for operator ‘++’") :: Expr DynamicType
+ ]
, [ binary' "==" (\op xs ys -> length xs == length ys && and (zipWith op xs ys)) $
[ SomeBinOp ((==) @Integer)
, SomeBinOp ((==) @Scientific)
, SomeBinOp ((==) @Text)
+ , SomeBinOp ((==) @Bool)
]
, binary' "/=" (\op xs ys -> length xs /= length ys || or (zipWith op xs ys)) $
[ SomeBinOp ((/=) @Integer)
, SomeBinOp ((/=) @Scientific)
, SomeBinOp ((/=) @Text)
+ , SomeBinOp ((/=) @Bool)
]
, binary ">" $
[ SomeBinOp ((>) @Integer)
@@ -298,6 +358,17 @@ someExpr = join inner <?> "expression"
choice $ map (\(SomeUnOp op) -> SomeExpr <$> applyUnOp off op e) ops
+ infixrExpr :: String -> SomeExpr -> Operator TestParser (TestParser SomeExpr)
+ infixrExpr name fun = InfixR $ do
+ void $ osymbol name
+ return $ \p q -> do
+ loff <- stateOffset <$> getParserState
+ l <- p
+ roff <- stateOffset <$> getParserState
+ r <- q
+ applyFunctionArguments (FunctionArguments $ M.fromList [ ( Just "$l", ( loff, l ) ), ( Just "$r", ( roff, r ) ) ]) fun
+
+
binary :: String -> [SomeBinOp] -> Operator TestParser (TestParser SomeExpr)
binary name = binary' name (undefined :: forall a b. (a -> b -> Void) -> [a] -> [b] -> Integer)
-- use 'Void' that can never match actually used type to disable recursion
@@ -338,15 +409,16 @@ someExpr = join inner <?> "expression"
region (const err) $
foldl1 (<|>) $ map (\(SomeBinOp op) -> tryop op (proxyOf e) (proxyOf f)) ops
-typedExpr :: forall a. ExprType a => TestParser (Expr a)
-typedExpr = do
+typedExpr :: forall a. ExprType a => TermComplexity -> TestParser (Expr a)
+typedExpr complexity = do
off <- stateOffset <$> getParserState
- SomeExpr e <- someExpr
+ SomeExpr e <- someExpr complexity
unifyExpr off Proxy e
literal :: TestParser SomeExpr
literal = label "literal" $ choice
[ numberLiteral
+ , boolLiteral
, SomeExpr <$> quotedString
, SomeExpr <$> regex
, list
@@ -360,15 +432,19 @@ variable = label "variable" $ do
e <- lookupVarExpr off sline name
recordSelector e <|> return e
+constructor :: TestParser SomeExpr
+constructor = label "constructor" $ do
+ off <- stateOffset <$> getParserState
+ sline <- getSourceLine
+ name <- constrName
+ lookupVarExpr off sline name
+
functionCall :: TestParser SomeExpr
functionCall = do
sline <- getSourceLine
- variable >>= \case
- SomeExpr e'@(FunVariable argTypes _ _) -> do
- let check = checkFunctionArguments argTypes
- args <- functionArguments check someExpr literal (\poff -> lookupVarExpr poff sline . VarName)
- return $ SomeExpr $ ArgsApp args e'
- e -> return e
+ fun <- variable <|> constructor
+ args <- functionArguments (\poff _ e -> return ( poff, e )) (someExpr FunctionTerm) literal (\poff -> lookupVarExpr poff sline . VarName)
+ applyFunctionArguments args fun
recordSelector :: SomeExpr -> TestParser SomeExpr
recordSelector (SomeExpr expr) = do
@@ -384,21 +460,6 @@ recordSelector (SomeExpr expr) = do
applyRecordSelector m e (RecordSelector f) = SomeExpr $ App (AnnRecord m) (pure f) e
-checkFunctionArguments :: FunctionArguments SomeArgumentType
- -> Int -> Maybe ArgumentKeyword -> SomeExpr -> TestParser SomeExpr
-checkFunctionArguments (FunctionArguments argTypes) poff kw sexpr@(SomeExpr expr) = do
- case M.lookup kw argTypes of
- Just (SomeArgumentType (_ :: ArgumentType expected)) -> do
- withRecovery (\e -> registerParseError e >> return sexpr) $ do
- SomeExpr <$> unifyExpr poff (Proxy @expected) expr
- Nothing -> do
- registerParseError $ FancyError poff $ S.singleton $ ErrorFail $ T.unpack $
- case kw of
- Just (ArgumentKeyword tkw) -> "unexpected parameter with keyword ‘" <> tkw <> "’"
- Nothing -> "unexpected parameter"
- return sexpr
-
-
functionArguments :: (Int -> Maybe ArgumentKeyword -> a -> TestParser b) -> TestParser a -> TestParser a -> (Int -> Text -> TestParser a) -> TestParser (FunctionArguments b)
functionArguments check param lit promote = do
args <- parseArgs True
@@ -426,3 +487,51 @@ functionArguments check param lit promote = do
pparam = between (symbol "(") (symbol ")") param <|> lit
checkAndInsert off kw x cont = M.insert kw <$> check off kw x <*> cont
+
+
+applyFunctionArguments :: FunctionArguments ( Int, SomeExpr ) -> SomeExpr -> TestParser SomeExpr
+applyFunctionArguments (FunctionArguments margs) sexpr
+ | M.null margs = return sexpr
+applyFunctionArguments args sexpr@(SomeExpr (expr :: Expr a))
+ | Just (Refl :: a :~: DynamicType) <- eqT
+ , ExprTypeForall qvar itype <- someExprType sexpr
+ = do
+ tvar <- newTypeVar
+ case renameVarInType qvar tvar itype of
+ ExprTypeFunction (ExprTypeArguments args') res' -> do
+ ( used, ( _, unexpectedArgs ) ) <- unifyArguments args' args
+ unexpectedArguments unexpectedArgs
+ t <- fromMaybe (ExprTypeVar tvar) . M.lookup tvar <$> gets testTypeUnif
+ resolveKnownTypeVars res' >>= \case
+ res''@(ExprTypePrim (Proxy :: Proxy r)) ->
+ return $ SomeExpr (ArgsApp used (ExposeFunType args' (TypeApp res'' t expr) :: Expr (FunctionType r)))
+ r ->
+ return $ SomeExpr (ArgsApp used (ExposeFunType args' (TypeApp r t expr) :: Expr (FunctionType DynamicType)))
+ _ -> do
+ unexpectedArguments args
+ return sexpr
+
+ | otherwise
+ = case someExprType sexpr of
+ ExprTypeFunction (ExprTypeArguments args') res' -> do
+ ( used, ( _, unexpectedArgs ) ) <- unifyArguments args' args
+ unexpectedArguments unexpectedArgs
+ resolveKnownTypeVars res' >>= \case
+ ExprTypePrim (Proxy :: Proxy r)
+ | Just (Refl :: a :~: FunctionType r) <- eqT
+ -> return $ SomeExpr (ArgsApp used expr)
+ _
+ | Just (Refl :: a :~: FunctionType DynamicType) <- eqT
+ -> return $ SomeExpr (ArgsApp used expr)
+ _ ->
+ error $ "expecting function type, got: " <> show (typeRep expr)
+ _ -> do
+ unexpectedArguments args
+ return sexpr
+ where
+ unexpectedArguments (FunctionArguments amap) = do
+ forM_ (M.toAscList amap) $ \( kw, ( poff, _ ) ) ->
+ registerParseError $ FancyError poff $ S.singleton $ ErrorFail $ T.unpack $
+ case kw of
+ Just (ArgumentKeyword tkw) -> "unexpected parameter with keyword ‘" <> tkw <> "’"
+ Nothing -> "unexpected parameter"
diff --git a/src/Parser/Shell.hs b/src/Parser/Shell.hs
index 0f34fee..105edfa 100644
--- a/src/Parser/Shell.hs
+++ b/src/Parser/Shell.hs
@@ -3,6 +3,7 @@ module Parser.Shell (
shellScript,
) where
+import Control.Applicative (liftA2)
import Control.Monad
import Data.Char
@@ -19,15 +20,18 @@ 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
+parseTextArgument :: TestParser (Expr Text)
+parseTextArgument = lexeme $ fmap (App AnnNone (Pure T.concat) <$> foldr (liftA2 (:)) (Pure [])) $ some $ choice
[ doubleQuotedString
- , escapedChar
+ , singleQuotedString
+ , standaloneEscapedChar
, stringExpansion
, unquotedString
]
where
- specialChars = [ '\"', '\\', '$' ]
+ specialChars = [ '"', '\'', '\\', '$', '#', '|', '>', '<', ';', '[', ']'{-, '{', '}' -}, '(', ')'{-, '*', '?', '~', '&', '!' -} ]
+
+ stringSpecialChars = [ '"', '\\', '$' ]
unquotedString :: TestParser (Expr Text)
unquotedString = do
@@ -38,36 +42,92 @@ parseArgument = lexeme $ fmap (App AnnNone (Pure T.concat) <$> foldr (liftA2 (:)
void $ char '"'
let inner = choice
[ char '"' >> return []
- , (:) <$> (Pure . TL.toStrict <$> takeWhile1P Nothing (`notElem` specialChars)) <*> inner
- , (:) <$> escapedChar <*> inner
+ , (:) <$> (Pure . TL.toStrict <$> takeWhile1P Nothing (`notElem` stringSpecialChars)) <*> inner
+ , (:) <$> stringEscapedChar <*> inner
, (:) <$> stringExpansion <*> inner
]
App AnnNone (Pure T.concat) . foldr (liftA2 (:)) (Pure []) <$> inner
- escapedChar :: TestParser (Expr Text)
- escapedChar = do
+ singleQuotedString :: TestParser (Expr Text)
+ singleQuotedString = do
+ Pure . TL.toStrict <$> (char '\'' *> takeWhileP Nothing (/= '\'') <* char '\'')
+
+ stringEscapedChar :: TestParser (Expr Text)
+ stringEscapedChar = do
void $ char '\\'
- Pure <$> choice
- [ char '\\' >> return "\\"
- , char '"' >> return "\""
- , char '$' >> return "$"
- , char 'n' >> return "\n"
+ fmap Pure $ choice $
+ map (\c -> char c >> return (T.singleton c)) stringSpecialChars ++
+ [ char 'n' >> return "\n"
, char 'r' >> return "\r"
, char 't' >> return "\t"
+ , return "\\"
]
-parseArguments :: TestParser (Expr [ Text ])
+ standaloneEscapedChar :: TestParser (Expr Text)
+ standaloneEscapedChar = do
+ void $ char '\\'
+ fmap T.singleton . Pure <$> printChar
+
+parseRedirection :: TestParser (Expr ShellArgument)
+parseRedirection = choice
+ [ do
+ osymbol "<"
+ fmap ShellRedirectStdin <$> parseTextArgument
+ , do
+ osymbol ">"
+ fmap (ShellRedirectStdout False) <$> parseTextArgument
+ , do
+ osymbol ">>"
+ fmap (ShellRedirectStdout True) <$> parseTextArgument
+ , do
+ osymbol "2>"
+ fmap (ShellRedirectStderr False) <$> parseTextArgument
+ , do
+ osymbol "2>>"
+ fmap (ShellRedirectStderr True) <$> parseTextArgument
+ ]
+
+parseArgument :: TestParser (Expr ShellArgument)
+parseArgument = choice
+ [ parseRedirection
+ , fmap ShellArgument <$> parseTextArgument
+ ]
+
+parseArguments :: TestParser (Expr [ ShellArgument ])
parseArguments = foldr (liftA2 (:)) (Pure []) <$> many parseArgument
-shellStatement :: TestParser (Expr [ ShellStatement ])
-shellStatement = label "shell statement" $ do
- command <- parseArgument
+parseCommand :: TestParser (Expr ShellCommand)
+parseCommand = label "shell statement" $ do
+ line <- getSourceLine
+ command <- parseTextArgument
args <- parseArguments
- return $ fmap (: []) $ ShellStatement
+ return $ ShellCommand
<$> command
<*> args
+ <*> pure line
+
+parsePipeline :: Maybe (Expr ShellPipeline) -> TestParser (Expr ShellPipeline)
+parsePipeline mbupper = do
+ cmd <- parseCommand
+ let pipeline =
+ case mbupper of
+ Nothing -> fmap (\ecmd -> ShellPipeline ecmd Nothing) cmd
+ Just upper -> liftA2 (\ecmd eupper -> ShellPipeline ecmd (Just eupper)) cmd upper
+ choice
+ [ do
+ osymbol "|"
+ parsePipeline (Just pipeline)
+
+ , do
+ return pipeline
+ ]
+
+parseStatement :: TestParser (Expr [ ShellStatement ])
+parseStatement = do
+ line <- getSourceLine
+ fmap ((: []) . flip ShellStatement line) <$> parsePipeline Nothing
shellScript :: TestParser (Expr ShellScript)
shellScript = do
indent <- L.indentLevel
- fmap ShellScript <$> blockOf indent shellStatement
+ fmap ShellScript <$> blockOf indent parseStatement
diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs
index 812c559..67f2f88 100644
--- a/src/Parser/Statement.hs
+++ b/src/Parser/Statement.hs
@@ -1,5 +1,6 @@
module Parser.Statement (
testStep,
+ testBlock,
) where
import Control.Monad
@@ -36,14 +37,14 @@ letStatement = do
off <- stateOffset <$> getParserState
name <- varName
osymbol "="
- SomeExpr e <- someExpr
+ se@(SomeExpr e) <- someExpr FunctionTerm
localState $ do
let tname = TypedVarName name
- addVarName off tname
+ addVarNameType off tname (someExprType se)
void $ eol
body <- testBlock indent
- return $ Let line tname e body
+ return $ Let line tname e (TestBlockStep EmptyTestBlock . Scope <$> body)
forStatement :: TestParser (Expr (TestBlock ()))
forStatement = do
@@ -54,7 +55,8 @@ forStatement = do
wsymbol "in"
loff <- stateOffset <$> getParserState
- SomeExpr e <- someExpr
+ tvar <- newTypeVar
+ SomeExpr e <- unifySomeExpr loff (ExprTypeApp (ExprTypeConstr1 (Proxy :: Proxy [])) [ ExprTypeVar tvar ]) =<< someExpr FunctionTerm
let err = parseError $ FancyError loff $ S.singleton $ ErrorFail $ T.unpack $
"expected a list, expression has type '" <> textExprType e <> "'"
ExprListUnpacker unpack _ <- maybe err return $ exprListUnpacker e
@@ -68,7 +70,7 @@ forStatement = do
body <- testBlock indent
return $ (\xs f -> mconcat $ map f xs)
<$> (unpack <$> e)
- <*> LambdaAbstraction tname body
+ <*> LambdaAbstraction tname (TestBlockStep EmptyTestBlock . Scope <$> body)
shellStatement :: TestParser (Expr (TestBlock ()))
shellStatement = do
@@ -92,18 +94,12 @@ shellStatement = do
, do
parseParamKeyword "on" mbnode
- node <- typedExpr
+ node <- typedExpr SimpleTerm
parseParams ref mbpname (Just node)
, do
off <- stateOffset <$> getParserState
symbol ":"
- pname <- case mbpname of
- Just pname -> return pname
- Nothing -> do
- registerParseError $ FancyError off $ S.singleton $ ErrorFail $
- "missing parameter with keyword ‘as’"
- return $ TypedVarName (VarName "")
node <- case mbnode of
Just node -> return node
Nothing -> do
@@ -114,16 +110,18 @@ shellStatement = do
void eol
void $ L.indentGuard scn GT ref
script <- shellScript
- cont <- testBlock ref
+ cont <- fmap Scope <$> testBlock ref
+ let expr | Just pname <- mbpname = LambdaAbstraction pname cont
+ | otherwise = const <$> cont
return $ TestBlockStep EmptyTestBlock <$>
- (SpawnShell pname <$> node <*> script <*> LambdaAbstraction pname cont)
+ (SpawnShell mbpname <$> node <*> script <*> expr)
]
exprStatement :: TestParser (Expr (TestBlock ()))
exprStatement = do
ref <- L.indentLevel
off <- stateOffset <$> getParserState
- SomeExpr expr <- someExpr
+ SomeExpr expr <- someExpr FunctionTerm
choice
[ continuePartial off ref expr
, unifyExpr off Proxy expr
@@ -139,8 +137,8 @@ exprStatement = do
blockOf indent $ do
coff <- stateOffset <$> getParserState
sline <- getSourceLine
- args <- functionArguments (checkFunctionArguments (exprArgs fun)) someExpr literal (\poff -> lookupVarExpr poff sline . VarName)
- let fun' = ArgsApp args fun
+ args <- functionArguments (\poff _ e -> return ( poff, e )) (someExpr FunctionTerm) literal (\poff -> lookupVarExpr poff sline . VarName)
+ SomeExpr fun' <- applyFunctionArguments args (SomeExpr fun)
choice
[ continuePartial coff indent fun'
, unifyExpr coff Proxy fun'
@@ -172,19 +170,18 @@ instance ParamType SourceLine where
parseParam _ = mzero
showParamType _ = "<source line>"
+instance ParamType CallStack where
+ type ParamRep CallStack = Expr CallStack
+ parseParam _ = mzero
+ showParamType _ = "<call stack>"
+ paramExpr = id
+
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 _ = 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
type ParamRep [a] = [ParamRep a]
parseParam _ = listOf (parseParam @a Proxy)
@@ -220,8 +217,8 @@ instance (ParamType a, ParamType b) => ParamType (Either a b) where
instance ExprType a => ParamType (Traced a) where
type ParamRep (Traced a) = Expr a
- parseParam _ = parseParam (Proxy @(Expr a))
- showParamType _ = showParamType (Proxy @(Expr a))
+ parseParam _ = parseParam (Proxy @(ExprParam a))
+ showParamType _ = showParamType (Proxy @(ExprParam a))
paramExpr = Trace
data SomeParam f = forall a. ParamType a => SomeParam (Proxy a) (f (ParamRep a))
@@ -279,6 +276,9 @@ paramOrContext name = fromParamOrContext <$> param name
cmdLine :: CommandDef SourceLine
cmdLine = param ""
+callStack :: CommandDef CallStack
+callStack = param ""
+
newtype InnerBlock a = InnerBlock { fromInnerBlock :: [ a ] -> TestBlock () }
instance ExprType a => ParamType (InnerBlock a) where
@@ -294,14 +294,14 @@ instance ExprType a => ParamType (InnerBlock a) where
combine f (x : xs) = f x xs
combine _ [] = error "inner block parameter count mismatch"
-innerBlock :: CommandDef (TestBlock ())
+innerBlock :: CommandDef (TestStep ())
innerBlock = ($ ([] :: [ Void ])) <$> innerBlockFun
-innerBlockFun :: ExprType a => CommandDef (a -> TestBlock ())
+innerBlockFun :: ExprType a => CommandDef (a -> TestStep ())
innerBlockFun = (\f x -> f [ x ]) <$> innerBlockFunList
-innerBlockFunList :: ExprType a => CommandDef ([ a ] -> TestBlock ())
-innerBlockFunList = fromInnerBlock <$> param ""
+innerBlockFunList :: ExprType a => CommandDef ([ a ] -> TestStep ())
+innerBlockFunList = (\ib -> Scope . fromInnerBlock ib) <$> param ""
newtype ExprParam a = ExprParam { fromExprParam :: a }
deriving (Functor, Foldable, Traversable)
@@ -310,7 +310,7 @@ 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
+ SomeExpr e <- someExpr SimpleTerm
unifyExpr off Proxy e
showParamType _ = "<" ++ T.unpack (textExprType @a Proxy) ++ ">"
paramExpr = fmap ExprParam
@@ -330,6 +330,7 @@ command name (CommandDef types ctor) = do
iparams <- forM params $ \case
(_, SomeParam (p :: Proxy p) Nothing)
| Just (Refl :: p :~: SourceLine) <- eqT -> return $ SomeParam p $ Identity line
+ | Just (Refl :: p :~: CallStack) <- eqT -> return $ SomeParam p $ Identity $ Variable line callStackFqVarName
| SomeNewVariables (vars :: [ TypedVarName a ]) <- definedVariables
, Just (Refl :: p :~: InnerBlock a) <- eqT
@@ -384,7 +385,8 @@ testLocal = do
void $ eol
indent <- L.indentGuard scn GT ref
- localState $ testBlock indent
+ localState $ do
+ fmap (TestBlockStep EmptyTestBlock . Scope) <$> testBlock indent
testWith :: TestParser (Expr (TestBlock ()))
testWith = do
@@ -392,7 +394,7 @@ testWith = do
wsymbol "with"
off <- stateOffset <$> getParserState
- ctx@(SomeExpr (_ :: Expr ctxe)) <- someExpr
+ ctx@(SomeExpr (_ :: Expr ctxe)) <- someExpr SimpleTerm
let expected =
[ ExprTypePrim @Network Proxy
, ExprTypePrim @Node Proxy
@@ -410,7 +412,7 @@ testWith = do
indent <- L.indentGuard scn GT ref
localState $ do
modify $ \s -> s { testContext = ctx }
- testBlock indent
+ fmap (TestBlockStep EmptyTestBlock . Scope) <$> testBlock indent
testSubnet :: TestParser (Expr (TestBlock ()))
testSubnet = command "subnet" $ Subnet
@@ -428,13 +430,17 @@ testSpawn :: TestParser (Expr (TestBlock ()))
testSpawn = command "spawn" $ Spawn
<$> param "as"
<*> (bimap fromExprParam fromExprParam <$> paramOrContext "on")
+ <*> (maybe [] fromExprParam <$> param "args")
+ <*> (maybe Nothing (Just . fromExprParam) <$> param "killwith")
<*> innerBlockFun
testExpect :: TestParser (Expr (TestBlock ()))
testExpect = command "expect" $ Expect
- <$> cmdLine
+ <$> callStack
+ <*> cmdLine
<*> (fromExprParam <$> paramOrContext "from")
<*> param ""
+ <*> (maybe 1 fromExprParam <$> param "timeout")
<*> param "capture"
<*> innerBlockFunList
diff --git a/src/Process.hs b/src/Process.hs
index 290aedf..4f4c286 100644
--- a/src/Process.hs
+++ b/src/Process.hs
@@ -1,13 +1,19 @@
module Process (
Process(..),
- ProcName(..),
- textProcName, unpackProcName,
+ ProcessId(..), textProcId,
+ ProcName(..), textProcName, unpackProcName,
+ Signal,
send,
- outProc,
+ outProc, outProcName,
lineReadingLoop,
+ startProcessIOLoops,
spawnOn,
closeProcess,
+ closeTestProcess,
withProcess,
+
+ IgnoreProcessOutput(..),
+ flushProcessOutput,
) where
import Control.Arrow
@@ -18,9 +24,12 @@ import Control.Monad.Except
import Control.Monad.Reader
import Data.Function
+import Data.List
+import Data.Maybe
+import Data.Scientific
import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Text.IO as T
+import Data.Text qualified as T
+import Data.Text.IO qualified as T
import System.Directory
import System.Environment
@@ -28,23 +37,29 @@ import System.Exit
import System.FilePath
import System.IO
import System.IO.Error
-import System.Posix.Signals
+import System.Posix.Process
import System.Process
import {-# SOURCE #-} GDB
import Network
import Network.Ip
import Output
+import Process.Signal
import Run.Monad
+import Script.Expr
import Script.Expr.Class
+import Script.Object
data Process = Process
- { procName :: ProcName
+ { procId :: ProcessId
+ , procName :: ProcName
, procHandle :: Either ProcessHandle ( ThreadId, MVar ExitCode )
, procStdin :: Handle
- , procOutput :: TVar [Text]
+ , procOutput :: TVar [ Text ]
+ , procIgnore :: TVar ( Int, [ ( Int, Maybe Regex ) ] )
, procKillWith :: Maybe Signal
, procNode :: Node
+ , procPid :: Maybe Pid
}
instance Eq Process where
@@ -52,18 +67,24 @@ instance Eq Process where
instance ExprType Process where
textExprType _ = T.pack "proc"
- textExprValue n = T.pack "p:" <> textProcName (procName n)
+ textExprValue p = "<process:" <> textProcName (procName p) <> "#" <> textProcId (procId p) <> ">"
recordMembers = map (first T.pack)
- [ ("node", RecordSelector $ procNode)
+ [ ( "node", RecordSelector $ procNode )
+ , ( "pid", RecordSelector $ maybe (0 :: Integer) fromIntegral . procPid )
]
+newtype ProcessId = ProcessId Int
+
data ProcName = ProcName Text
| ProcNameTcpdump
| ProcNameGDB
deriving (Eq, Ord)
+textProcId :: ProcessId -> Text
+textProcId (ProcessId pid) = T.pack (show pid)
+
textProcName :: ProcName -> Text
textProcName (ProcName name) = name
textProcName ProcNameTcpdump = T.pack "tcpdump"
@@ -78,22 +99,52 @@ send p line = liftIO $ do
hFlush (procStdin p)
outProc :: MonadOutput m => OutputType -> Process -> Text -> m ()
-outProc otype p line = outLine otype (Just $ textProcName $ procName p) line
+outProc otype p line = outProcName otype (procName p) line
+
+outProcName :: MonadOutput m => OutputType -> ProcName -> Text -> m ()
+outProcName otype pname line = outLine otype (Just $ textProcName pname) line
lineReadingLoop :: MonadOutput m => Process -> Handle -> (Text -> m ()) -> m ()
lineReadingLoop process h act =
liftIO (tryIOError (T.hGetLine h)) >>= \case
- Left err
- | isEOFError err -> return ()
- | otherwise -> outProc OutputChildFail process $ T.pack $ "IO error: " ++ show err
+ Left err -> do
+ when (not (isEOFError err)) $ do
+ outProc OutputChildFail process $ T.pack $ "IO error: " ++ show err
+ liftIO $ hClose h
Right line -> do
act line
lineReadingLoop process h act
+startProcessIOLoops :: Process -> Handle -> Handle -> TestRun ()
+startProcessIOLoops process@Process {..} hout herr = do
+
+ void $ forkTest $ lineReadingLoop process hout $ \line -> do
+ outProc OutputChildStdout process line
+ ignored <- liftIO $ atomically $ do
+ ignores <- map snd . snd <$> readTVar procIgnore
+ let ignored = any (matches line) ignores
+ when (not ignored) $ do
+ modifyTVar procOutput (++ [ line ])
+ return ignored
+ when ignored $ do
+ outProc OutputIgnored process line
+
+ void $ forkTest $ lineReadingLoop process herr $ \line -> do
+ case procName of
+ ProcNameTcpdump -> return ()
+ _ -> outProc OutputChildStderr process line
+
+ where
+ matches _ Nothing
+ = True
+ matches line (Just re)
+ | Right (Just _) <- regexMatch re line = True
+ | otherwise = False
+
spawnOn :: Either Network Node -> ProcName -> Maybe Signal -> String -> TestRun Process
-spawnOn target pname killWith cmd = do
+spawnOn target procName procKillWith 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.
+ -- because working directory will be changed for the shell wrapper.
cmd' <- liftIO $ do
case span (/= ' ') cmd of
( path, rest )
@@ -103,56 +154,73 @@ spawnOn target pname killWith cmd = do
return (path' ++ rest)
_ -> return cmd
+ procId <- case procName of
+ ProcNameTcpdump -> return $ ProcessId (-1)
+ _ -> do
+ idVar <- asks $ teNextProcId . fst
+ liftIO $ modifyMVar idVar (\x -> return ( x + 1, ProcessId x ))
+
let netns = either getNetns getNetns target
- let prefix = T.unpack $ "ip netns exec \"" <> textNetnsName netns <> "\" "
currentEnv <- liftIO $ getEnvironment
- (Just hin, Just hout, Just herr, handle) <- liftIO $ createProcess (shell $ prefix ++ cmd')
- { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe
- , cwd = Just (either netDir nodeDir target)
- , env = Just $ ( "EREBOS_DIR", "." ) : currentEnv
- }
- pout <- liftIO $ newTVarIO []
-
- let process = Process
- { procName = pname
- , procHandle = Left handle
- , procStdin = hin
- , procOutput = pout
- , procKillWith = killWith
- , procNode = either (const undefined) id target
+ (Just procStdin, Just hout, Just herr, handle) <- liftIO $ do
+ runInNetworkNamespace netns $ createProcess (shell cmd')
+ { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe
+ , cwd = Just (either netDir nodeDir target)
+ , env = Just $ ( "EREBOS_DIR", "." ) : currentEnv
}
+ let procHandle = Left handle
+ procOutput <- liftIO $ newTVarIO []
+ procIgnore <- liftIO $ newTVarIO ( 0, [] )
+ let procNode = either (const undefined) id target
+ procPid <- liftIO $ getPid handle
+ let process = Process {..}
- void $ forkTest $ lineReadingLoop process hout $ \line -> do
- outProc OutputChildStdout process line
- liftIO $ atomically $ modifyTVar pout (++[line])
- void $ forkTest $ lineReadingLoop process herr $ \line -> do
- case pname of
- ProcNameTcpdump -> return ()
- _ -> outProc OutputChildStderr process line
+ startProcessIOLoops process hout herr
asks (teGDB . fst) >>= maybe (return Nothing) (liftIO . tryReadMVar) >>= \case
- Just gdb | ProcName _ <- pname -> addInferior gdb process
+ Just gdb | ProcName _ <- procName -> addInferior gdb process
_ -> return ()
return process
-closeProcess :: (MonadIO m, MonadOutput m, MonadError Failed m) => Process -> m ()
-closeProcess p = do
+closeProcess :: (MonadIO m, MonadOutput m, MonadError Failed m) => Scientific -> Process -> m ()
+closeProcess timeout p = do
liftIO $ hClose $ procStdin p
case procKillWith p of
Nothing -> return ()
- Just sig -> liftIO $ either getPid (\_ -> return Nothing) (procHandle p) >>= \case
+ Just sig -> case procPid p of
Nothing -> return ()
Just pid -> signalProcess sig pid
liftIO $ void $ forkIO $ do
- threadDelay 1000000
+ threadDelay $ floor $ 1000000 * timeout
either terminateProcess (killThread . fst) $ procHandle p
- liftIO (either waitForProcess (takeMVar . snd) (procHandle p)) >>= \case
- ExitSuccess -> return ()
- ExitFailure code -> do
- outProc OutputChildFail p $ T.pack $ "exit code: " ++ show code
+
+ status <- case procPid p of
+ Nothing -> Just . Exited <$> liftIO (either waitForProcess (takeMVar . snd) (procHandle p))
+ Just pid -> liftIO (getProcessStatus True False pid)
+ case status of
+ Just (Exited ExitSuccess) -> do
+ return ()
+ Just (Exited (ExitFailure code)) -> do
+ outProc OutputChildFail p $ "exit code: " <> T.pack (show code)
+ throwError Failed
+ Just (Terminated sig _)
+ | Just (Signal sig) == procKillWith p -> return ()
+ | otherwise -> do
+ outProc OutputChildFail p $ "killed with signal " <> T.pack (show sig)
+ throwError Failed
+ Just (Stopped sig) -> do
+ outProc OutputChildFail p $ "stopped with signal " <> T.pack (show sig)
throwError Failed
+ Nothing -> do
+ outProc OutputChildFail p $ "no exit status"
+ throwError Failed
+
+closeTestProcess :: Process -> TestRun ()
+closeTestProcess process = do
+ timeout <- getCurrentTimeout
+ closeProcess timeout process
withProcess :: Either Network Node -> ProcName -> Maybe Signal -> String -> (Process -> TestRun a) -> TestRun a
withProcess target pname killWith cmd inner = do
@@ -163,5 +231,36 @@ withProcess target pname killWith cmd inner = do
inner process `finally` do
ps <- liftIO $ takeMVar procVar
- closeProcess process `finally` do
+ closeTestProcess process `finally` do
liftIO $ putMVar procVar $ filter (/=process) ps
+
+
+data IgnoreProcessOutput = IgnoreProcessOutput Process Int
+
+instance ObjectType TestRun IgnoreProcessOutput where
+ type ConstructorArgs IgnoreProcessOutput = ( Process, Maybe Regex )
+
+ textObjectType _ _ = "IgnoreProcessOutput"
+ textObjectValue _ (IgnoreProcessOutput _ _) = "<IgnoreProcessOutput>"
+
+ createObject oid ( process@Process {..}, regex ) = do
+ ( obj, flushed ) <- liftIO $ atomically $ do
+ flushed <- flushProcessOutput process regex
+ ( iid, list ) <- readTVar procIgnore
+ writeTVar procIgnore ( iid + 1, ( iid, regex ) : list )
+ return ( Object oid $ IgnoreProcessOutput process iid, flushed )
+ mapM_ (outProc OutputIgnored process) flushed
+ return obj
+
+ destroyObject Object { objImpl = IgnoreProcessOutput Process {..} iid } = do
+ liftIO $ atomically $ do
+ writeTVar procIgnore . fmap (filter ((iid /=) . fst)) =<< readTVar procIgnore
+
+flushProcessOutput :: Process -> Maybe Regex -> STM [ Text ]
+flushProcessOutput p mbre = do
+ current <- readTVar (procOutput p)
+ let ( ignore, keep ) = case mbre of
+ Nothing -> ( current, [] )
+ Just re -> partition (either error isJust . regexMatch re) current
+ writeTVar (procOutput p) keep
+ return ignore
diff --git a/src/Process/Signal.hs b/src/Process/Signal.hs
new file mode 100644
index 0000000..e57b68d
--- /dev/null
+++ b/src/Process/Signal.hs
@@ -0,0 +1,88 @@
+module Process.Signal (
+ Signal(..),
+ signalBuiltins,
+ signalProcess,
+) where
+
+import Control.Monad.IO.Class
+
+import Data.Text (Text)
+import Data.Text qualified as T
+
+import Script.Expr
+
+import System.Posix qualified as Posix
+
+
+newtype Signal = Signal Posix.Signal
+ deriving (Eq, Ord)
+
+instance ExprType Signal where
+ textExprType _ = "Signal"
+ textExprValue (Signal sig)
+ | sig == Posix.sigHUP = "SIGHUP"
+ | sig == Posix.sigINT = "SIGINT"
+ | sig == Posix.sigQUIT = "SIGQUIT"
+ | sig == Posix.sigILL = "SIGILL"
+ | sig == Posix.sigTRAP = "SIGTRAP"
+ | sig == Posix.sigABRT = "SIGABRT"
+ | sig == Posix.sigBUS = "SIGBUS"
+ | sig == Posix.sigFPE = "SIGFPE"
+ | sig == Posix.sigKILL = "SIGKILL"
+ | sig == Posix.sigUSR1 = "SIGUSR1"
+ | sig == Posix.sigSEGV = "SIGSEGV"
+ | sig == Posix.sigUSR2 = "SIGUSR2"
+ | sig == Posix.sigPIPE = "SIGPIPE"
+ | sig == Posix.sigALRM = "SIGALRM"
+ | sig == Posix.sigTERM = "SIGTERM"
+ | sig == Posix.sigCHLD = "SIGCHLD"
+ | sig == Posix.sigCONT = "SIGCONT"
+ | sig == Posix.sigSTOP = "SIGSTOP"
+ | sig == Posix.sigTSTP = "SIGTSTP"
+ | sig == Posix.sigTTIN = "SIGTTIN"
+ | sig == Posix.sigTTOU = "SIGTTOU"
+ | sig == Posix.sigURG = "SIGURG"
+ | sig == Posix.sigXCPU = "SIGXCPU"
+ | sig == Posix.sigXFSZ = "SIGXFSZ"
+ | sig == Posix.sigVTALRM = "SIGVTALRM"
+ | sig == Posix.sigPROF = "SIGPROF"
+ | sig == Posix.sigPOLL = "SIGPOLL"
+ | sig == Posix.sigSYS = "SIGSYS"
+ | otherwise = "<SIG_" <> T.pack (show sig) <> ">"
+
+
+signalBuiltins :: [ ( Text, SomeExpr ) ]
+signalBuiltins = map (fmap $ SomeExpr . Pure)
+ [ ( "SIGHUP", Signal Posix.sigHUP )
+ , ( "SIGINT", Signal Posix.sigINT )
+ , ( "SIGQUIT", Signal Posix.sigQUIT )
+ , ( "SIGILL", Signal Posix.sigILL )
+ , ( "SIGTRAP", Signal Posix.sigTRAP )
+ , ( "SIGABRT", Signal Posix.sigABRT )
+ , ( "SIGBUS", Signal Posix.sigBUS )
+ , ( "SIGFPE", Signal Posix.sigFPE )
+ , ( "SIGKILL", Signal Posix.sigKILL )
+ , ( "SIGUSR1", Signal Posix.sigUSR1 )
+ , ( "SIGSEGV", Signal Posix.sigSEGV )
+ , ( "SIGUSR2", Signal Posix.sigUSR2 )
+ , ( "SIGPIPE", Signal Posix.sigPIPE )
+ , ( "SIGALRM", Signal Posix.sigALRM )
+ , ( "SIGTERM", Signal Posix.sigTERM )
+ , ( "SIGCHLD", Signal Posix.sigCHLD )
+ , ( "SIGCONT", Signal Posix.sigCONT )
+ , ( "SIGSTOP", Signal Posix.sigSTOP )
+ , ( "SIGTSTP", Signal Posix.sigTSTP )
+ , ( "SIGTTIN", Signal Posix.sigTTIN )
+ , ( "SIGTTOU", Signal Posix.sigTTOU )
+ , ( "SIGURG", Signal Posix.sigURG )
+ , ( "SIGXCPU", Signal Posix.sigXCPU )
+ , ( "SIGXFSZ", Signal Posix.sigXFSZ )
+ , ( "SIGVTALRM", Signal Posix.sigVTALRM )
+ , ( "SIGPROF", Signal Posix.sigPROF )
+ , ( "SIGPOLL", Signal Posix.sigPOLL )
+ , ( "SIGSYS", Signal Posix.sigSYS )
+ ]
+
+
+signalProcess :: MonadIO m => Signal -> Posix.ProcessID -> m ()
+signalProcess (Signal sig) pid = liftIO $ Posix.signalProcess sig pid
diff --git a/src/Run.hs b/src/Run.hs
index b7093f4..f3805ea 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -1,7 +1,14 @@
module Run (
module Run.Monad,
runTest,
+
+ LoadedModules(..),
+ loadModules,
evalGlobalDefs,
+
+ TestFilter(..),
+ testFilterFromConfig,
+ filterTests,
) where
import Control.Applicative
@@ -9,15 +16,20 @@ import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad
import Control.Monad.Except
-import Control.Monad.Fix
import Control.Monad.Reader
+import Control.Monad.Writer
+import Data.Bifunctor
+import Data.Either
+import Data.List
import Data.Map qualified as M
import Data.Maybe
-import Data.Set qualified as S
+import Data.Proxy
import Data.Scientific
+import Data.Set qualified as S
import Data.Text (Text)
-import qualified Data.Text as T
+import Data.Text qualified as T
+import Data.Typeable
import System.Directory
import System.Exit
@@ -26,17 +38,24 @@ import System.Posix.Process
import System.Posix.Signals
import System.Process
+import Config
import GDB
import Network
import Network.Ip
import Output
+import Parser
import Process
+import Process.Signal
import Run.Monad
+import Sandbox
import Script.Expr
+import Script.Module
+import Script.Object
import Script.Shell
import Test
import Test.Builtins
+
runTest :: Output -> TestOptions -> GlobalDefs -> Test -> IO Bool
runTest out opts gdefs test = do
let testDir = optTestDir opts
@@ -47,7 +66,10 @@ runTest out opts gdefs test = do
createDirectoryIfMissing True testDir
failedVar <- newTVarIO Nothing
+ objIdVar <- newMVar 1
+ procIdVar <- newMVar 1
procVar <- newMVar []
+ timeoutVar <- newMVar ( optTimeout opts, 0 )
mgdb <- if optGDB opts
then flip runReaderT out $ do
@@ -59,18 +81,22 @@ runTest out opts gdefs test = do
{ teOutput = out
, teFailed = failedVar
, teOptions = opts
+ , teNextObjId = objIdVar
+ , teNextProcId = procIdVar
, teProcesses = procVar
+ , teTimeout = timeoutVar
, teGDB = fst <$> mgdb
}
tstate = TestState
{ tsGlobals = gdefs
- , tsLocals = []
+ , tsLocals = [ ( callStackVarName, SomeExpr $ Pure $ CallStack [] ) ]
, tsNodePacketLoss = M.empty
, tsDisconnectedUp = S.empty
, tsDisconnectedBridge = S.empty
}
- let sigHandler SignalInfo { siginfoSpecific = chld } = do
+ let sigHandler SignalInfo { siginfoSpecific = NoSignalSpecificInfo } = return ()
+ sigHandler SignalInfo { siginfoSpecific = chld } = do
processes <- readMVar procVar
forM_ processes $ \p -> do
mbpid <- either getPid (\_ -> return Nothing) (procHandle p)
@@ -88,16 +114,29 @@ runTest out opts gdefs test = do
oldHandler <- installHandler processStatusChanged (CatchInfo sigHandler) Nothing
resetOutputTime out
- res <- runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do
- withInternet $ \_ -> do
- evalBlock =<< eval (testSteps test)
- when (optWait opts) $ do
- void $ outPromptGetLine $ "Test '" <> testName test <> "' completed, waiting..."
+ testRunResult <- newEmptyMVar
+
+ flip runReaderT out $ do
+ void $ outLine OutputGlobalInfo Nothing $ "Starting test ‘" <> testName test <> "’"
+
+ void $ forkOS $ do
+ isolateFilesystem testDir >>= \case
+ True -> do
+ tres <- runWriterT $ runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do
+ withInternet $ \_ -> do
+ runStep =<< eval (testSteps test)
+ when (optWait opts) $ do
+ void $ outPromptGetLine $ "Test '" <> testName test <> "' completed, waiting..."
+ putMVar testRunResult tres
+ _ -> do
+ putMVar testRunResult ( Left Failed, [] )
+
+ ( res, [] ) <- takeMVar testRunResult
void $ installHandler processStatusChanged oldHandler Nothing
Right () <- runExceptT $ flip runReaderT out $ do
- maybe (return ()) (closeProcess . snd) mgdb
+ maybe (return ()) (closeProcess 1 . snd) mgdb
[] <- readMVar procVar
failed <- atomically $ readTVar (teFailed tenv)
@@ -105,23 +144,111 @@ runTest out opts gdefs test = do
(Right (), Nothing) -> do
when (not $ optKeep opts) $ removeDirectoryRecursive testDir
return True
- _ -> return False
+ _ -> do
+ flip runReaderT out $ do
+ void $ outLine OutputGlobalError Nothing $ "Test ‘" <> testName test <> "’ failed."
+ return False
+
+
+data LoadedModules = LoadedModules
+ { lmModules :: [ Module ]
+ , lmTags :: [ ( ( ModuleName, Text ), [ Tag ] ) ]
+ , lmGlobalDefs :: GlobalDefs
+ }
+
+loadModules :: [ ( FilePath, Maybe Text ) ] -> IO (Either CustomTestError LoadedModules)
+loadModules files = do
+ parseTestFiles (map fst files) >>= \case
+ Right ( modules, allModules ) -> return $ do
+ lmModules <- forM (zip files modules) $ \( ( path, tsel ), m ) -> do
+ tests <- case tsel of
+ Nothing -> return $ moduleTests m
+ Just tname
+ | Just test <- find ((tname ==) . testName) (moduleTests m)
+ -> return [ test ]
+ | otherwise
+ -> throwError $ TestNotFound tname (Just path)
+ return m { moduleTests = tests }
+
+ let lmGlobalDefs = evalGlobalDefs $ concatMap (\m -> map (first ( moduleName m, )) $ moduleDefinitions m) allModules
+ evalTags test = map (\e -> runSimpleEval (eval e) lmGlobalDefs []) $ testTags test
+ lmTags = concatMap (\Module {..} -> map (\test -> ( ( moduleName, testName test ), evalTags test )) moduleTests) lmModules
+ Right $ LoadedModules {..}
+ Left err -> do
+ return $ Left err
evalGlobalDefs :: [ (( ModuleName, VarName ), SomeExpr ) ] -> GlobalDefs
-evalGlobalDefs exprs = fix $ \gdefs ->
- builtins `M.union` M.fromList (map (fmap (evalSomeWith gdefs)) exprs)
+evalGlobalDefs exprs = builtins `M.union` M.fromList exprs
+
+
+data TestFilter = TestFilter
+ { tfSelect :: Maybe [ Text ]
+ , tfExclude :: [ Text ]
+ }
+
+instance Semigroup TestFilter where
+ a <> b
+ | isJust (tfSelect b) = b
+ | otherwise = a { tfExclude = tfExclude a <> tfExclude b }
+
+instance Monoid TestFilter where
+ mempty = TestFilter Nothing []
+
+testFilterFromConfig :: Config -> TestFilter
+testFilterFromConfig Config {..} = TestFilter
+ { tfSelect = configSelect
+ , tfExclude = configExclude
+ }
+
+filterTests :: TestFilter -> LoadedModules -> Either CustomTestError [ Test ]
+filterTests TestFilter {..} LoadedModules {..} = do
+ let allTests = concatMap (\m -> ( moduleName m, ) <$> moduleTests m) lmModules
+ let evalTerm :: Text -> Either CustomTestError (Either Text Tag)
+ evalTerm t =
+ case find ((VarName t ==) . snd . fst) $ M.toList lmGlobalDefs of
+ Just ( _, SomeExpr (expr :: Expr etype))
+ | Just (Refl :: etype :~: Tag) <- eqT
+ -> return $ Right $ runSimpleEval (eval expr) lmGlobalDefs []
+ Nothing
+ | Just _ <- find ((t ==) . testName . snd) allTests
+ -> return $ Left t
+ _ ->
+ throwError $ TestOrTagNotFound t Nothing
+ exclude <- partitionEithers <$> mapM evalTerm tfExclude
+ let matches ( tnames, tags ) ( mname, test ) =
+ testName test `elem` tnames || maybe False (any (`elem` tags)) (lookup ( mname, testName test ) lmTags)
+ map snd . filter (not . matches exclude) <$> case tfSelect of
+ Nothing -> return allTests
+ Just tnames -> do
+ selected <- partitionEithers <$> mapM evalTerm tnames
+ return $ filter (matches selected) allTests
+
+
+runBlock :: TestBlock () -> TestRun ()
+runBlock EmptyTestBlock = return ()
+runBlock (TestBlockStep prev step) = runBlock prev >> runStep step
+
+runStep :: TestStep () -> TestRun ()
+runStep = \case
+ Scope block -> do
+ ( x, objs ) <- censor (const []) $ listen $ catchError (Right <$> runBlock block) (return . Left)
+ mapM_ destroySomeObject (reverse objs)
+ either throwError return x
+
+ CreateObject (Proxy :: Proxy o) cargs -> do
+ objIdVar <- asks (teNextObjId . fst)
+ oid <- liftIO $ modifyMVar objIdVar (\x -> return ( x + 1, x ))
+ obj <- createObject @TestRun @o (ObjectId oid) cargs
+ tell [ toSomeObject obj ]
-evalBlock :: TestBlock () -> TestRun ()
-evalBlock EmptyTestBlock = return ()
-evalBlock (TestBlockStep prev step) = evalBlock prev >> case step of
Subnet name parent inner -> do
- withSubnet parent (Just name) $ evalBlock . inner
+ withSubnet parent (Just name) $ runStep . inner
DeclNode name net inner -> do
- withNode net (Left name) $ evalBlock . inner
+ withNode net (Left name) $ runStep . inner
- Spawn tvname@(TypedVarName (VarName tname)) target inner -> do
+ Spawn tvname@(TypedVarName (VarName tname)) target args killWith inner -> do
case target of
Left net -> withNode net (Right tvname) go
Right node -> go node
@@ -130,38 +257,44 @@ evalBlock (TestBlockStep prev step) = evalBlock prev >> case step of
opts <- asks $ teOptions . fst
let pname = ProcName tname
tool = fromMaybe (optDefaultTool opts) (lookup pname $ optProcTools opts)
- withProcess (Right node) pname Nothing tool $ evalBlock . inner
-
- SpawnShell (TypedVarName (VarName tname)) node script inner -> do
+ cmd = T.unwords $ T.pack tool : map escape args
+ escape = ("'" <>) . (<> "'") . T.replace "'" "'\\''"
+ outProcName OutputChildExec pname cmd
+ withProcess (Right node) pname killWith (T.unpack cmd) $ runStep . inner
+
+ SpawnShell mbname node script inner -> do
+ let tname | Just (TypedVarName (VarName name)) <- mbname = name
+ | otherwise = "shell"
let pname = ProcName tname
- withShellProcess node pname script $ evalBlock . inner
+ withShellProcess node pname script $ runStep . inner
Send p line -> do
outProc OutputChildStdin p line
send p line
- Expect line p expr captures inner -> do
- expect line p expr captures $ evalBlock . inner
+ Expect stack line p expr timeout captures inner -> do
+ expect stack line p expr timeout captures $ runStep . inner
Flush p regex -> do
- flush p regex
+ mapM_ (outProc OutputIgnored p) =<<
+ atomicallyTest (flushProcessOutput p regex)
- Guard line vars expr -> do
- testStepGuard line vars expr
+ Guard stack expr -> do
+ testStepGuard stack expr
DisconnectNode node inner -> do
- withDisconnectedUp (nodeUpstream node) $ evalBlock inner
+ withDisconnectedUp (nodeUpstream node) $ runStep inner
DisconnectNodes net inner -> do
- withDisconnectedBridge (netBridge net) $ evalBlock inner
+ withDisconnectedBridge (netBridge net) $ runStep inner
DisconnectUpstream net inner -> do
case netUpstream net of
- Just link -> withDisconnectedUp link $ evalBlock inner
- Nothing -> evalBlock inner
+ Just link -> withDisconnectedUp link $ runStep inner
+ Nothing -> runStep inner
PacketLoss loss node inner -> do
- withNodePacketLoss node loss $ evalBlock inner
+ withNodePacketLoss node loss $ runStep inner
Wait -> do
void $ outPromptGetLine "Waiting..."
@@ -171,11 +304,10 @@ withInternet :: (Network -> TestRun a) -> TestRun a
withInternet inner = do
testDir <- asks $ optTestDir . teOptions . fst
inet <- newInternet testDir
- res <- withNetwork (inetRoot inet) $ \net -> do
- withTypedVar rootNetworkVar net $ do
- inner net
- delInternet inet
- return res
+ flip finally (delInternet inet) $ do
+ withNetwork (inetRoot inet) $ \net -> do
+ withTypedVar rootNetworkVar net $ do
+ inner net
withSubnet :: Network -> Maybe (TypedVarName Network) -> (Network -> TestRun a) -> TestRun a
withSubnet parent tvname inner = do
@@ -184,8 +316,8 @@ withSubnet parent tvname inner = do
withNetwork :: Network -> (Network -> TestRun a) -> TestRun a
withNetwork net inner = do
- tcpdump <- liftIO (findExecutable "tcpdump") >>= return . \case
- Just path -> withProcess (Left net) ProcNameTcpdump (Just softwareTermination)
+ tcpdump <- asks (optTcpdump . teOptions . fst) >>= return . \case
+ Just path -> withProcess (Left net) ProcNameTcpdump (Just (Signal softwareTermination))
(path ++ " -i br0 -w './br0.pcap' -U -Z root") . const
Nothing -> id
@@ -251,20 +383,16 @@ tryMatch re (x:xs) | Right (Just (_, _, _, capture)) <- regexMatch re x = Just (
| otherwise = fmap (x:) <$> tryMatch re xs
tryMatch _ [] = Nothing
-exprFailed :: Text -> SourceLine -> Maybe ProcName -> EvalTrace -> TestRun ()
-exprFailed desc sline pname exprVars = do
+exprFailed :: Text -> CallStack -> Maybe ProcName -> TestRun ()
+exprFailed desc stack pname = do
let prompt = maybe T.empty textProcName pname
- outLine OutputMatchFail (Just prompt) $ T.concat [desc, T.pack " failed on ", textSourceLine sline]
- forM_ exprVars $ \((name, sel), value) ->
- outLine OutputMatchFail (Just prompt) $ T.concat
- [ " ", textFqVarName name, T.concat (map ("."<>) sel)
- , " = ", textSomeVarValue sline value
- ]
+ outLine (OutputMatchFail stack) (Just prompt) $ desc <> " failed"
throwError Failed
-expect :: SourceLine -> Process -> Traced Regex -> [TypedVarName Text] -> ([ Text ] -> TestRun ()) -> TestRun ()
-expect sline p (Traced trace re) tvars inner = do
- timeout <- asks $ optTimeout . teOptions . fst
+expect :: CallStack -> SourceLine -> Process -> Traced Regex -> Scientific -> [ TypedVarName Text ] -> ([ Text ] -> TestRun ()) -> TestRun ()
+expect (CallStack cs) sline p (Traced trace re) etimeout tvars inner = do
+ let stack = CallStack (( sline, trace ) : cs)
+ timeout <- (etimeout *) <$> getCurrentTimeout
delay <- liftIO $ registerDelay $ ceiling $ 1000000 * timeout
mbmatch <- atomicallyTest $ (Nothing <$ (check =<< readTVar delay)) <|> do
line <- readTVar (procOutput p)
@@ -278,21 +406,14 @@ expect sline p (Traced trace re) 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` textSourceLine sline
+ outProc (OutputMatchFail stack) p $ T.pack "mismatched number of capture variables"
throwError Failed
outProc OutputMatch p line
inner capture
- Nothing -> exprFailed (T.pack "expect") sline (Just $ procName p) trace
-
-flush :: Process -> Maybe Regex -> TestRun ()
-flush p mbre = do
- atomicallyTest $ do
- writeTVar (procOutput p) =<< case mbre of
- Nothing -> return []
- Just re -> filter (either error isNothing . regexMatch re) <$> readTVar (procOutput p)
+ Nothing -> exprFailed (T.pack "expect") stack (Just $ procName p)
-testStepGuard :: SourceLine -> EvalTrace -> Bool -> TestRun ()
-testStepGuard sline vars x = do
- when (not x) $ exprFailed (T.pack "guard") sline Nothing vars
+testStepGuard :: CallStack -> Bool -> TestRun ()
+testStepGuard stack x = do
+ when (not x) $ exprFailed (T.pack "guard") stack Nothing
diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs
index e107017..f4444e8 100644
--- a/src/Run/Monad.hs
+++ b/src/Run/Monad.hs
@@ -7,6 +7,9 @@ module Run.Monad (
finally,
forkTest,
+ forkTestUsing,
+
+ getCurrentTimeout,
) where
import Control.Concurrent
@@ -14,6 +17,7 @@ import Control.Concurrent.STM
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
+import Control.Monad.Writer
import Data.Map (Map)
import Data.Scientific
@@ -25,21 +29,30 @@ import Network.Ip
import Output
import {-# SOURCE #-} Process
import Script.Expr
+import Script.Object
-newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT Failed IO) a }
- deriving (Functor, Applicative, Monad, MonadReader (TestEnv, TestState), MonadIO)
+newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT Failed (WriterT [ SomeObject TestRun ] IO)) a }
+ deriving
+ ( Functor, Applicative, Monad
+ , MonadReader ( TestEnv, TestState )
+ , MonadWriter [ SomeObject TestRun ]
+ , MonadIO
+ )
data TestEnv = TestEnv
{ teOutput :: Output
, teFailed :: TVar (Maybe Failed)
, teOptions :: TestOptions
- , teProcesses :: MVar [Process]
+ , teNextObjId :: MVar Int
+ , teNextProcId :: MVar Int
+ , teProcesses :: MVar [ Process ]
+ , teTimeout :: MVar ( Scientific, Integer ) -- ( positive timeout, number of zero multiplications )
, teGDB :: Maybe (MVar GDB)
}
data TestState = TestState
{ tsGlobals :: GlobalDefs
- , tsLocals :: [ ( VarName, SomeVarValue ) ]
+ , tsLocals :: [ ( VarName, SomeExpr ) ]
, tsDisconnectedUp :: Set NetworkNamespace
, tsDisconnectedBridge :: Set NetworkNamespace
, tsNodePacketLoss :: Map NetworkNamespace Scientific
@@ -50,6 +63,7 @@ data TestOptions = TestOptions
, optProcTools :: [(ProcName, String)]
, optTestDir :: FilePath
, optTimeout :: Scientific
+ , optTcpdump :: Maybe FilePath
, optGDB :: Bool
, optForce :: Bool
, optKeep :: Bool
@@ -62,6 +76,7 @@ defaultTestOptions = TestOptions
, optProcTools = []
, optTestDir = ".test"
, optTimeout = 1
+ , optTcpdump = Nothing
, optGDB = False
, optForce = False
, optKeep = False
@@ -110,9 +125,19 @@ finally act handler = do
return x
forkTest :: TestRun () -> TestRun ThreadId
-forkTest act = do
+forkTest = forkTestUsing forkIO
+
+forkTestUsing :: (IO () -> IO ThreadId) -> TestRun () -> TestRun ThreadId
+forkTestUsing fork act = do
tenv <- ask
- liftIO $ forkIO $ do
- runExceptT (flip runReaderT tenv $ fromTestRun act) >>= \case
+ liftIO $ fork $ do
+ ( res, [] ) <- runWriterT (runExceptT $ flip runReaderT tenv $ fromTestRun act)
+ case res of
Left e -> atomically $ writeTVar (teFailed $ fst tenv) (Just e)
Right () -> return ()
+
+getCurrentTimeout :: TestRun Scientific
+getCurrentTimeout = do
+ ( timeout, zeros ) <- liftIO . readMVar =<< asks (teTimeout . fst)
+ return $ if zeros > 0 then 0
+ else timeout
diff --git a/src/Sandbox.hs b/src/Sandbox.hs
new file mode 100644
index 0000000..a05a455
--- /dev/null
+++ b/src/Sandbox.hs
@@ -0,0 +1,16 @@
+module Sandbox (
+ isolateFilesystem,
+) where
+
+import Foreign.C.String
+import Foreign.C.Types
+
+import System.Directory
+
+
+isolateFilesystem :: FilePath -> IO Bool
+isolateFilesystem rwDir = do
+ absDir <- makeAbsolute rwDir
+ withCString absDir c_isolate_fs >>= return . (== 0)
+
+foreign import ccall unsafe "erebos_tester_isolate_fs" c_isolate_fs :: CString -> IO CInt
diff --git a/src/Script/Expr.hs b/src/Script/Expr.hs
index ced807c..09b7c80 100644
--- a/src/Script/Expr.hs
+++ b/src/Script/Expr.hs
@@ -4,10 +4,12 @@ module Script.Expr (
MonadEval(..), VariableDictionary, GlobalDefs,
lookupVar, tryLookupVar, withVar, withTypedVar,
eval, evalSome, evalSomeWith,
+ runSimpleEval,
FunctionType, DynamicType,
ExprType(..), SomeExpr(..),
TypeVar(..), SomeExprType(..), someExprType, textSomeExprType,
+ renameTypeVar, renameVarInType,
VarValue(..), SomeVarValue(..),
svvVariables, svvArguments,
@@ -18,8 +20,9 @@ module Script.Expr (
anull, exprArgs,
SomeArgumentType(..), ArgumentType(..),
- Traced(..), EvalTrace, VarNameSelectors, gatherVars,
+ Traced(..), EvalTrace, CallStack(..), VarNameSelectors, gatherVars,
AppAnnotation(..),
+ callStackVarName, callStackFqVarName,
module Script.Var,
@@ -28,6 +31,7 @@ module Script.Expr (
) where
import Control.Monad
+import Control.Monad.Except
import Control.Monad.Reader
import Data.Char
@@ -53,12 +57,19 @@ 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)
+ DynVariable :: SomeExprType -> SourceLine -> FqVarName -> Expr DynamicType
+ FunVariable :: ExprType a => SomeExprType -> SourceLine -> FqVarName -> Expr (FunctionType a)
+ OptVariable :: ExprType a => SourceLine -> FqVarName -> Expr (Maybe a)
ArgsReq :: ExprType a => FunctionArguments ( VarName, SomeArgumentType ) -> Expr (FunctionType a) -> Expr (FunctionType a)
ArgsApp :: ExprType a => FunctionArguments SomeExpr -> Expr (FunctionType a) -> Expr (FunctionType a)
FunctionAbstraction :: ExprType a => Expr a -> Expr (FunctionType a)
- FunctionEval :: ExprType a => Expr (FunctionType a) -> Expr a
+ FunctionEval :: ExprType a => SourceLine -> Expr (FunctionType a) -> Expr a
+ HidePrimType :: forall a. ExprType a => Expr a -> Expr DynamicType
+ HideFunType :: forall a. ExprType a => FunctionArguments SomeArgumentType -> Expr (FunctionType a) -> Expr DynamicType
+ ExposePrimType :: forall a. ExprType a => Expr DynamicType -> Expr a
+ ExposeFunType :: forall a. ExprType a => FunctionArguments SomeArgumentType -> Expr DynamicType -> Expr (FunctionType a)
+ TypeLambda :: TypeVar -> SomeExprType -> (SomeExprType -> Expr DynamicType) -> Expr DynamicType
+ TypeApp :: SomeExprType {- result type -} -> SomeExprType {- type argument -} -> Expr DynamicType -> Expr DynamicType
LambdaAbstraction :: ExprType a => TypedVarName a -> Expr b -> Expr (a -> b)
Pure :: a -> Expr a
App :: AppAnnotation b -> Expr (a -> b) -> Expr a -> Expr b
@@ -95,10 +106,17 @@ mapExpr f = go
e@Variable {} -> f e
e@DynVariable {} -> f e
e@FunVariable {} -> f e
+ e@OptVariable {} -> f e
ArgsReq args expr -> f $ ArgsReq args (go expr)
ArgsApp args expr -> f $ ArgsApp (fmap (\(SomeExpr e) -> SomeExpr (go e)) args) (go expr)
FunctionAbstraction expr -> f $ FunctionAbstraction (go expr)
- FunctionEval expr -> f $ FunctionEval (go expr)
+ FunctionEval sline expr -> f $ FunctionEval sline (go expr)
+ HidePrimType expr -> f $ HidePrimType $ go expr
+ HideFunType args expr -> f $ HideFunType args $ go expr
+ ExposePrimType expr -> f $ ExposePrimType $ go expr
+ ExposeFunType args expr -> f $ ExposeFunType args $ go expr
+ TypeLambda tvar stype efun -> TypeLambda tvar stype (go . efun)
+ TypeApp restype arg expr -> TypeApp restype arg (go expr)
LambdaAbstraction tvar expr -> f $ LambdaAbstraction tvar (go expr)
e@Pure {} -> f e
App ann efun earg -> f $ App ann (go efun) (go earg)
@@ -114,19 +132,19 @@ class MonadFail m => MonadEval m where
askDictionary :: m VariableDictionary
withDictionary :: (VariableDictionary -> VariableDictionary) -> m a -> m a
-type GlobalDefs = Map ( ModuleName, VarName ) SomeVarValue
+type GlobalDefs = Map ( ModuleName, VarName ) SomeExpr
-type VariableDictionary = [ ( VarName, SomeVarValue ) ]
+type VariableDictionary = [ ( VarName, SomeExpr ) ]
-lookupVar :: MonadEval m => FqVarName -> m SomeVarValue
+lookupVar :: MonadEval m => FqVarName -> m SomeExpr
lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackFqVarName name ++ "'") return =<< tryLookupVar name
-tryLookupVar :: MonadEval m => FqVarName -> m (Maybe SomeVarValue)
+tryLookupVar :: MonadEval m => FqVarName -> m (Maybe SomeExpr)
tryLookupVar (LocalVarName name) = lookup name <$> askDictionary
tryLookupVar (GlobalVarName mname var) = M.lookup ( mname, var ) <$> askGlobalDefs
withVar :: (MonadEval m, ExprType e) => VarName -> e -> m a -> m a
-withVar name value = withDictionary (( name, someConstValue value ) : )
+withVar name value = withDictionary (( name, SomeExpr (Pure value) ) : )
withTypedVar :: (MonadEval m, ExprType e) => TypedVarName e -> e -> m a -> m a
withTypedVar (TypedVarName name) = withVar name
@@ -138,49 +156,86 @@ isInternalVar (LocalVarName (VarName name))
| otherwise = False
-newtype SimpleEval a = SimpleEval (Reader ( GlobalDefs, VariableDictionary ) a)
- deriving (Functor, Applicative, Monad)
+
+newtype SimpleEval a = SimpleEval (ReaderT ( GlobalDefs, VariableDictionary ) (Except String) a)
+ deriving (Functor, Applicative, Monad, MonadError String)
runSimpleEval :: SimpleEval a -> GlobalDefs -> VariableDictionary -> a
-runSimpleEval (SimpleEval x) = curry $ runReader x
+runSimpleEval (SimpleEval x) gdefs dict = either error id $ runExcept $ runReaderT x ( gdefs, dict )
+
+trySimpleEval :: SimpleEval a -> GlobalDefs -> VariableDictionary -> Maybe a
+trySimpleEval (SimpleEval x) gdefs dict = either (const Nothing) Just $ runExcept $ runReaderT x ( gdefs, dict )
instance MonadFail SimpleEval where
- fail = error . ("eval failed: " <>)
+ fail = throwError . ("eval failed: " <>)
instance MonadEval SimpleEval where
askGlobalDefs = SimpleEval (asks fst)
askDictionary = SimpleEval (asks snd)
withDictionary f (SimpleEval inner) = SimpleEval (local (fmap f) inner)
+callStackVarName :: VarName
+callStackVarName = VarName "$STACK"
+
+callStackFqVarName :: FqVarName
+callStackFqVarName = LocalVarName callStackVarName
+
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
+ Variable _ name -> evalSomeExpr name =<< lookupVar name
+ DynVariable _ _ name -> evalSomeExpr name =<< lookupVar name
+ FunVariable _ _ name -> evalSomeExpr name =<< lookupVar name
+ OptVariable _ name -> maybe (return Nothing) (fmap Just . evalSomeExpr name) =<< tryLookupVar name
ArgsReq (FunctionArguments req) efun -> do
gdefs <- askGlobalDefs
dict <- askDictionary
- return $ FunctionType $ \(FunctionArguments args) ->
- let used = M.intersectionWith (\value ( vname, _ ) -> ( vname, value )) args req
+ return $ FunctionType $ \stack (FunctionArguments args) ->
+ let used = M.intersectionWith (\(SomeVarValue value) ( vname, _ ) -> ( vname, SomeExpr $ Pure $ vvFunction value (CallStack []) mempty )) args req
FunctionType fun = runSimpleEval (eval efun) gdefs (toList used ++ dict)
- in fun $ FunctionArguments $ args `M.difference` req
+ in fun stack $ FunctionArguments $ args `M.difference` req
ArgsApp eargs efun -> do
FunctionType fun <- eval efun
args <- mapM evalSome eargs
- return $ FunctionType $ \args' -> fun (args <> args')
+ return $ FunctionType $ \stack args' -> fun stack (args <> args')
FunctionAbstraction expr -> do
- val <- eval expr
- return $ FunctionType $ const val
- FunctionEval efun -> do
- FunctionType fun <- eval efun
- return $ fun mempty
+ gdefs <- askGlobalDefs
+ dict <- askDictionary
+ return $ FunctionType $ \stack _ ->
+ runSimpleEval (eval expr) gdefs (( callStackVarName, SomeExpr (Pure stack) ) : filter ((callStackVarName /=) . fst) dict)
+ FunctionEval sline efun -> do
+ vars <- gatherVars efun
+ CallStack cs <- maybe (return $ CallStack []) (evalSomeExpr callStackFqVarName) =<< tryLookupVar callStackFqVarName
+ let cs' = CallStack (( sline, vars ) : cs)
+ FunctionType fun <- withVar callStackVarName cs' $ eval efun
+ return $ fun cs' mempty
+ HidePrimType expr -> DynamicType <$> eval expr
+ HideFunType _ expr -> DynamicType <$> eval expr
+ ExposePrimType expr -> do
+ DynamicType x <- eval expr
+ case cast x of
+ Just x' -> return x'
+ n@Nothing -> fail $ "type error in expose primitive type result " <> show ( typeOf x, typeOf n )
+ ExposeFunType _ expr -> do
+ DynamicType x <- eval expr
+ case cast x of
+ Just x' -> return x'
+ n@Nothing -> fail $ "type error in expose function type result " <> show ( typeOf x, typeOf n )
+ TypeLambda _ _ f -> do
+ gdefs <- askGlobalDefs
+ dict <- askDictionary
+ return $ DynamicType $ \t -> runSimpleEval (eval $ f t) gdefs dict
+ TypeApp _ arg expr -> do
+ DynamicType f <- eval expr
+ case cast f of
+ Just f' -> return (f' arg)
+ n@Nothing -> fail $ "type error in type application " <> show ( typeOf f, typeOf n )
LambdaAbstraction (TypedVarName name) expr -> do
gdefs <- askGlobalDefs
dict <- askDictionary
- return $ \x -> runSimpleEval (eval expr) gdefs (( name, someConstValue x ) : dict)
+ return $ \x -> runSimpleEval (eval expr) gdefs (( name, SomeExpr $ Pure x ) : dict)
Pure value -> return value
App _ f x -> eval f <*> eval x
Concat xs -> T.concat <$> mapM eval xs
@@ -192,6 +247,13 @@ eval = \case
Undefined err -> fail err
Trace expr -> Traced <$> gatherVars expr <*> eval expr
+evalSomeExpr :: forall m a. (MonadEval m, ExprType a) => FqVarName -> SomeExpr -> m a
+evalSomeExpr name (SomeExpr (e :: Expr b)) = do
+ maybe (fail err) eval $ cast e
+ where
+ err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable ‘", textFqVarName name, T.pack "’ has type type ",
+ textExprType @b Proxy ]
+
evalToVarValue :: MonadEval m => Expr a -> m (VarValue a)
evalToVarValue expr = do
VarValue
@@ -205,7 +267,7 @@ evalFunToVarValue expr = do
VarValue
<$> gatherVars expr
<*> pure (exprArgs expr)
- <*> pure (const fun)
+ <*> pure fun
evalSome :: MonadEval m => SomeExpr -> m SomeVarValue
evalSome (SomeExpr expr)
@@ -216,13 +278,13 @@ evalSomeWith :: GlobalDefs -> SomeExpr -> SomeVarValue
evalSomeWith gdefs sexpr = runSimpleEval (evalSome sexpr) gdefs []
-data FunctionType a = FunctionType (FunctionArguments SomeVarValue -> a)
+data FunctionType a = FunctionType (CallStack -> FunctionArguments SomeVarValue -> a)
instance ExprType a => ExprType (FunctionType a) where
textExprType _ = "function type"
textExprValue _ = "<function type>"
-data DynamicType
+data DynamicType = forall a. Typeable a => DynamicType a
instance ExprType DynamicType where
textExprType _ = "ambiguous type"
@@ -236,41 +298,106 @@ newtype TypeVar = TypeVar Text
data SomeExprType
= forall a. ExprType a => ExprTypePrim (Proxy a)
+ | forall a. ExprTypeConstr1 a => ExprTypeConstr1 (Proxy a)
| ExprTypeVar TypeVar
- | forall a. ExprType a => ExprTypeFunction (FunctionArguments SomeArgumentType) (Proxy a)
+ | ExprTypeFunction SomeExprType SomeExprType
+ | ExprTypeArguments (FunctionArguments SomeArgumentType)
+ | ExprTypeApp SomeExprType [ SomeExprType ]
+ | ExprTypeForall TypeVar SomeExprType
someExprType :: SomeExpr -> SomeExprType
someExprType (SomeExpr expr) = go expr
where
go :: forall e. ExprType e => Expr e -> SomeExprType
go = \case
- DynVariable tvar _ _ -> ExprTypeVar tvar
- (e :: Expr a)
- | IsFunType <- asFunType e -> ExprTypeFunction (gof e) (proxyOfFunctionType e)
- | otherwise -> ExprTypePrim (Proxy @a)
-
- 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"
+ DynVariable stype _ _ -> stype
+ e@(FunVariable args _ _) -> ExprTypeFunction args (ExprTypePrim (proxyOfFunctionType e))
+ HidePrimType (_ :: Expr a) -> ExprTypePrim (Proxy @a)
+ HideFunType args e -> ExprTypeFunction (ExprTypeArguments args) (ExprTypePrim (proxyOfFunctionType e))
+ e@(ExposeFunType args _) -> ExprTypeFunction (ExprTypeArguments args) (ExprTypePrim (proxyOfFunctionType e))
+ TypeLambda tvar stype _ -> ExprTypeForall tvar stype
+ TypeApp stype _ _ -> stype
+
+ ArgsReq args inner -> exprTypeFunction (fmap snd args) (go inner)
+ ArgsApp (FunctionArguments used) inner
+ | ExprTypeFunction (ExprTypeArguments (FunctionArguments args)) x <- go inner
+ -> ExprTypeFunction (ExprTypeArguments (FunctionArguments (args `M.difference` used))) x
+ FunctionAbstraction inner -> exprTypeFunction mempty (go inner)
+ FunctionEval _ inner
+ | ExprTypeFunction _ x <- go inner -> x
+
+ (_ :: Expr a) -> ExprTypePrim (Proxy @a)
+
+ exprTypeFunction :: FunctionArguments SomeArgumentType -> SomeExprType -> SomeExprType
+ exprTypeFunction args (ExprTypeFunction (ExprTypeArguments args') inner) = ExprTypeFunction (ExprTypeArguments (args <> args')) inner
+ exprTypeFunction args inner = ExprTypeFunction (ExprTypeArguments args) inner
proxyOfFunctionType :: Expr (FunctionType a) -> Proxy a
proxyOfFunctionType _ = Proxy
+
+renameTypeVar :: TypeVar -> TypeVar -> Expr a -> Expr a
+renameTypeVar a b = go
+ where
+ go :: Expr e -> Expr e
+ go orig = case orig of
+ Let sline vname x y -> Let sline vname (go x) (go y)
+ Variable {} -> orig
+ DynVariable stype sline name -> DynVariable (renameVarInType a b stype) sline name
+ FunVariable {} -> orig
+ OptVariable {} -> orig
+ ArgsReq args body -> ArgsReq args (go body)
+ ArgsApp args fun -> ArgsApp (fmap (renameTypeVarInSomeExpr a b) args) (go fun)
+ FunctionAbstraction expr -> FunctionAbstraction (go expr)
+ FunctionEval sline expr -> FunctionEval sline (go expr)
+ HidePrimType expr -> HidePrimType (go expr)
+ HideFunType args expr -> HideFunType args (go expr)
+ ExposePrimType {} -> orig
+ ExposeFunType {} -> orig
+ TypeLambda tvar stype expr
+ | tvar == a -> orig
+ | tvar == b -> error "type var collision"
+ | otherwise -> TypeLambda tvar (renameVarInType a b stype) (go . expr)
+ TypeApp restype arg expr -> TypeApp (renameVarInType a b restype) (renameVarInType a b arg) (go expr)
+ LambdaAbstraction vname expr -> LambdaAbstraction vname (go expr)
+ Pure {} -> orig
+ App ann f x -> App ann (go f) (go x)
+ Concat xs -> Concat (map go xs)
+ Regex xs -> Regex (map go xs)
+ Undefined {} -> orig
+ Trace expr -> Trace (go expr)
+
+renameTypeVarInSomeExpr :: TypeVar -> TypeVar -> SomeExpr -> SomeExpr
+renameTypeVarInSomeExpr a b (SomeExpr e) = SomeExpr (renameTypeVar a b e)
+
+renameVarInType :: TypeVar -> TypeVar -> SomeExprType -> SomeExprType
+renameVarInType a b = go
+ where
+ go orig = case orig of
+ ExprTypePrim {} -> orig
+ ExprTypeConstr1 {} -> orig
+ ExprTypeVar tvar | tvar == a -> ExprTypeVar b
+ | otherwise -> orig
+ ExprTypeFunction args result -> ExprTypeFunction (go args) (go result)
+ ExprTypeArguments args -> ExprTypeArguments (fmap (\(SomeArgumentType atype stype) -> SomeArgumentType atype (go stype)) args)
+ ExprTypeApp c xs -> ExprTypeApp (go c) (map go xs)
+ ExprTypeForall tvar stype
+ | tvar == a -> orig
+ | tvar == b -> error "type var collision"
+ | otherwise -> ExprTypeForall tvar (go stype)
+
+
textSomeExprType :: SomeExprType -> Text
-textSomeExprType (ExprTypePrim p) = textExprType p
-textSomeExprType (ExprTypeVar (TypeVar name)) = name
-textSomeExprType (ExprTypeFunction _ r) = "function:" <> textExprType r
+textSomeExprType = go []
+ where
+ go _ (ExprTypePrim p) = textExprType p
+ go (x : _) (ExprTypeConstr1 c) = textExprTypeConstr1 c x
+ go [] (ExprTypeConstr1 _) = "<incomplte type>"
+ go _ (ExprTypeVar (TypeVar name)) = name
+ go _ (ExprTypeFunction _ r) = "function:" <> textSomeExprType r
+ go _ (ExprTypeArguments _) = "{…}"
+ go _ (ExprTypeApp c xs) = go (map textSomeExprType xs) c
+ go _ (ExprTypeForall (TypeVar name) ctype) = "∀" <> name <> "." <> go [] ctype
data AsFunType a
= forall b. (a ~ FunctionType b, ExprType b) => IsFunType
@@ -289,7 +416,7 @@ asFunType = \case
data VarValue a = VarValue
{ vvVariables :: EvalTrace
, vvArguments :: FunctionArguments SomeArgumentType
- , vvFunction :: SourceLine -> FunctionArguments SomeVarValue -> a
+ , vvFunction :: CallStack -> FunctionArguments SomeVarValue -> a
}
data SomeVarValue = forall a. ExprType a => SomeVarValue (VarValue a)
@@ -303,33 +430,33 @@ 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
+fromConstValue :: forall a m. (ExprType a, MonadFail m) => CallStack -> FqVarName -> VarValue a -> m a
+fromConstValue stack name (VarValue _ args value :: VarValue b) = do
maybe (fail err) return $ do
guard $ anull args
- cast $ value sline mempty
+ cast $ value stack 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
+fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => CallStack -> FqVarName -> SomeVarValue -> m a
+fromSomeVarValue stack name (SomeVarValue (VarValue _ args value :: VarValue b)) = do
maybe (fail err) return $ do
guard $ anull args
- cast $ value sline mempty
+ cast $ value stack 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
+textSomeVarValue :: SomeVarValue -> Text
+textSomeVarValue (SomeVarValue (VarValue _ args value))
+ | anull args = textExprValue $ value (CallStack []) mempty
| otherwise = "<function>"
someVarValueType :: SomeVarValue -> SomeExprType
someVarValueType (SomeVarValue (VarValue _ args _ :: VarValue a))
| anull args = ExprTypePrim (Proxy @a)
- | otherwise = ExprTypeFunction args (Proxy @a)
+ | otherwise = ExprTypeFunction (ExprTypeArguments args) (ExprTypePrim (Proxy @a))
newtype ArgumentKeyword = ArgumentKeyword Text
@@ -345,31 +472,26 @@ exprArgs :: Expr (FunctionType a) -> FunctionArguments SomeArgumentType
exprArgs = \case
Let _ _ _ expr -> exprArgs expr
Variable {} -> mempty
- FunVariable args _ _ -> args
+ FunVariable (ExprTypeArguments args) _ _ -> args
+ FunVariable _ _ _ -> error "exprArgs: type-var args"
ArgsReq args expr -> fmap snd args <> exprArgs expr
ArgsApp (FunctionArguments applied) expr ->
let FunctionArguments args = exprArgs expr
in FunctionArguments (args `M.difference` applied)
FunctionAbstraction {} -> mempty
FunctionEval {} -> mempty
+ ExposePrimType {} -> mempty
+ ExposeFunType args _ -> args
Pure {} -> error "exprArgs: pure"
App {} -> error "exprArgs: app"
Undefined {} -> error "exprArgs: undefined"
-funFromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => 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 SomeArgumentType = SomeArgumentType ArgumentType SomeExprType
-data ArgumentType a
+data ArgumentType
= RequiredArgument
| OptionalArgument
- | ExprDefault (Expr a)
+ | ExprDefault SomeExpr
| ContextDefault
@@ -377,6 +499,11 @@ data Traced a = Traced EvalTrace a
type VarNameSelectors = ( FqVarName, [ Text ] )
type EvalTrace = [ ( VarNameSelectors, SomeVarValue ) ]
+newtype CallStack = CallStack [ ( SourceLine, EvalTrace ) ]
+
+instance ExprType CallStack where
+ textExprType _ = T.pack "callstack"
+ textExprValue _ = T.pack "<callstack>"
gatherVars :: forall a m. MonadEval m => Expr a -> m EvalTrace
gatherVars = fmap (uniqOn fst . sortOn fst) . helper
@@ -384,25 +511,32 @@ gatherVars = fmap (uniqOn fst . sortOn fst) . helper
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
+ e@(Variable _ var) -> gatherLocalVar var e
+ e@(DynVariable _ _ var) -> gatherLocalVar var e
+ e@(FunVariable _ _ var) -> gatherLocalVar var e
+ e@(OptVariable _ var) -> gatherLocalVar var e
ArgsReq args expr -> withDictionary (filter ((`notElem` map fst (toList args)) . fst)) $ helper expr
ArgsApp (FunctionArguments args) fun -> do
v <- helper fun
vs <- mapM (\(SomeExpr e) -> helper e) $ M.elems args
return $ concat (v : vs)
FunctionAbstraction expr -> helper expr
- FunctionEval efun -> helper efun
+ FunctionEval _ efun -> helper efun
+ HidePrimType expr -> helper expr
+ HideFunType _ expr -> helper expr
+ ExposePrimType expr -> helper expr
+ ExposeFunType _ expr -> helper expr
+ TypeLambda {} -> return []
+ TypeApp _ _ expr -> helper expr
LambdaAbstraction (TypedVarName var) expr -> withDictionary (filter ((var /=) . fst)) $ helper expr
Pure _ -> return []
e@(App (AnnRecord sel) _ x)
| Just (var, sels) <- gatherSelectors x
-> do
- val <- SomeVarValue . VarValue [] mempty . const . const <$> eval e
- return [ (( var, sels ++ [ sel ] ), val ) ]
+ gdefs <- askGlobalDefs
+ dict <- askDictionary
+ let mbVal = SomeVarValue . VarValue [] mempty . const . const <$> trySimpleEval (eval e) gdefs dict
+ return $ catMaybes [ (( var, sels ++ [ sel ] ), ) <$> mbVal ]
| otherwise -> do
helper x
App _ f x -> (++) <$> helper f <*> helper x
@@ -411,6 +545,16 @@ gatherVars = fmap (uniqOn fst . sortOn fst) . helper
Undefined {} -> return []
Trace expr -> helper expr
+ gatherLocalVar :: forall b. ExprType b => FqVarName -> Expr b -> m EvalTrace
+ gatherLocalVar var expr
+ | GlobalVarName {} <- var = return []
+ | isInternalVar var = return []
+ | otherwise = do
+ gdefs <- askGlobalDefs
+ dict <- askDictionary
+ let mbVal = SomeVarValue . VarValue [] mempty . const . const <$> trySimpleEval (eval expr) gdefs dict
+ return $ maybe [] (\x -> [ ( ( var, [] ), x ) ]) mbVal
+
gatherSelectors :: forall b. Expr b -> Maybe ( FqVarName, [ Text ] )
gatherSelectors = \case
Variable _ var -> Just (var, [])
diff --git a/src/Script/Expr/Class.hs b/src/Script/Expr/Class.hs
index 20a92b4..5bf8a4b 100644
--- a/src/Script/Expr/Class.hs
+++ b/src/Script/Expr/Class.hs
@@ -1,10 +1,13 @@
module Script.Expr.Class (
ExprType(..),
+ ExprTypeConstr1(..),
+ TypeDeconstructor(..),
RecordSelector(..),
ExprListUnpacker(..),
ExprEnumerator(..),
) where
+import Data.Kind
import Data.Maybe
import Data.Scientific
import Data.Text (Text)
@@ -16,6 +19,9 @@ class Typeable a => ExprType a where
textExprType :: proxy a -> Text
textExprValue :: a -> Text
+ matchTypeConstructor :: proxy a -> TypeDeconstructor a
+ matchTypeConstructor _ = NoTypeDeconstructor
+
recordMembers :: [(Text, RecordSelector a)]
recordMembers = []
@@ -31,6 +37,13 @@ class Typeable a => ExprType a where
exprEnumerator :: proxy a -> Maybe (ExprEnumerator a)
exprEnumerator _ = Nothing
+class (Typeable a, forall b. ExprType b => ExprType (a b)) => ExprTypeConstr1 (a :: Type -> Type) where
+ textExprTypeConstr1 :: proxy a -> Text -> Text
+
+data TypeDeconstructor a
+ = NoTypeDeconstructor
+ | forall c x. (ExprTypeConstr1 c, ExprType x, c x ~ a) => TypeDeconstructor1 (Proxy c) (Proxy x)
+
data RecordSelector a = forall b. ExprType b => RecordSelector (a -> b)
@@ -39,6 +52,10 @@ data ExprListUnpacker a = forall e. ExprType e => ExprListUnpacker (a -> [e]) (P
data ExprEnumerator a = ExprEnumerator (a -> a -> [a]) (a -> a -> a -> [a])
+instance ExprType () where
+ textExprType _ = "Unit"
+ textExprValue () = "()"
+
instance ExprType Integer where
textExprType _ = T.pack "integer"
textExprValue x = T.pack (show x)
@@ -70,8 +87,22 @@ instance ExprType Void where
textExprType _ = T.pack "void"
textExprValue _ = T.pack "<void>"
-instance ExprType a => ExprType [a] where
- textExprType _ = "[" <> textExprType @a Proxy <> "]"
+instance ExprType a => ExprType [ a ] where
+ textExprType _ = textExprTypeConstr1 @[] Proxy (textExprType @a Proxy)
textExprValue x = "[" <> T.intercalate ", " (map textExprValue x) <> "]"
+ matchTypeConstructor _ = TypeDeconstructor1 Proxy Proxy
exprListUnpacker _ = Just $ ExprListUnpacker id (const Proxy)
+
+instance ExprTypeConstr1 [] where
+ textExprTypeConstr1 _ x = "[" <> x <> "]"
+
+instance ExprType a => ExprType (Maybe a) where
+ textExprType _ = textExprType @a Proxy <> "?"
+ textExprValue (Just x) = textExprValue x
+ textExprValue Nothing = "Nothing"
+
+instance (ExprType a, ExprType b) => ExprType (Either a b) where
+ textExprType _ = textExprType @a Proxy <> "|" <> textExprType @b Proxy
+ textExprValue (Left x) = "Left " <> textExprValue x
+ textExprValue (Right x) = "Right " <> textExprValue x
diff --git a/src/Script/Object.hs b/src/Script/Object.hs
new file mode 100644
index 0000000..7e60f80
--- /dev/null
+++ b/src/Script/Object.hs
@@ -0,0 +1,53 @@
+module Script.Object (
+ ObjectId(..),
+ ObjectType(..),
+ Object(..), SomeObject(..),
+ toSomeObject, fromSomeObject,
+ destroySomeObject,
+) where
+
+import Data.Kind
+import Data.Text (Text)
+import Data.Typeable
+
+import Script.Expr.Class
+
+
+newtype ObjectId = ObjectId Int
+
+class Typeable a => ObjectType m a where
+ type ConstructorArgs a :: Type
+ type ConstructorArgs a = ()
+
+ textObjectType :: proxy (m a) -> proxy a -> Text
+ textObjectValue :: proxy (m a) -> a -> Text
+
+ createObject :: ObjectId -> ConstructorArgs a -> m (Object m a)
+ destroyObject :: Object m a -> m ()
+
+instance (Typeable m, ObjectType m a) => ExprType (Object m a) where
+ textExprType _ = textObjectType (Proxy @(m a)) (Proxy @a)
+ textExprValue = textObjectValue (Proxy @(m a)) . objImpl
+
+
+data Object m a = ObjectType m a => Object
+ { objId :: ObjectId
+ , objImpl :: a
+ }
+
+data SomeObject m = forall a. ObjectType m a => SomeObject
+ { sobjId :: ObjectId
+ , sobjImpl :: a
+ }
+
+toSomeObject :: Object m a -> SomeObject m
+toSomeObject Object {..} = SomeObject { sobjId = objId, sobjImpl = objImpl }
+
+fromSomeObject :: ObjectType m a => SomeObject m -> Maybe (Object m a)
+fromSomeObject SomeObject {..} = do
+ let objId = sobjId
+ objImpl <- cast sobjImpl
+ return Object {..}
+
+destroySomeObject :: SomeObject m -> m ()
+destroySomeObject (SomeObject oid impl) = destroyObject (Object oid impl)
diff --git a/src/Script/Shell.hs b/src/Script/Shell.hs
index 60ec929..2d1b82b 100644
--- a/src/Script/Shell.hs
+++ b/src/Script/Shell.hs
@@ -1,6 +1,9 @@
module Script.Shell (
- ShellStatement(..),
ShellScript(..),
+ ShellStatement(ShellStatement),
+ ShellPipeline(ShellPipeline),
+ ShellCommand(ShellCommand),
+ ShellArgument(..),
withShellProcess,
) where
@@ -11,69 +14,198 @@ import Control.Monad.Except
import Control.Monad.IO.Class
import Control.Monad.Reader
+import Data.Maybe
import Data.Text (Text)
import Data.Text qualified as T
-import Data.Text.IO qualified as T
+
+import Foreign.C.Types
+import Foreign.Ptr
+import Foreign.Marshal.Array
+import Foreign.Storable
import System.Exit
+import System.FilePath
import System.IO
+import System.Posix.IO qualified as P
+import System.Posix.Process
+import System.Posix.Types
import System.Process hiding (ShellCommand)
import Network
+import Network.Ip
import Output
import Process
import Run.Monad
+import Script.Expr.Class
+import Script.Var
+
+newtype ShellScript = ShellScript [ ShellStatement ]
data ShellStatement = ShellStatement
- { shellCommand :: Text
- , shellArguments :: [ Text ]
+ { shellPipeline :: ShellPipeline
+ , shellSourceLine :: SourceLine
}
-newtype ShellScript = ShellScript [ ShellStatement ]
+data ShellPipeline = ShellPipeline
+ { pipeCommand :: ShellCommand
+ , pipeUpstream :: Maybe ShellPipeline
+ }
+
+data ShellCommand = ShellCommand
+ { cmdCommand :: Text
+ , cmdExtArguments :: [ ShellArgument ]
+ , cmdSourceLine :: SourceLine
+ }
+
+data ShellArgument
+ = ShellArgument Text
+ | ShellRedirectStdin Text
+ | ShellRedirectStdout Bool Text
+ | ShellRedirectStderr Bool Text
+
+cmdArguments :: ShellCommand -> [ Text ]
+cmdArguments = catMaybes . map (\case ShellArgument x -> Just x; _ -> Nothing) . cmdExtArguments
+
+instance ExprType ShellScript where
+ textExprType _ = T.pack "ShellScript"
+ textExprValue _ = "<shell-script>"
+
+instance ExprType ShellStatement where
+ textExprType _ = T.pack "ShellStatement"
+ textExprValue _ = "<shell-statement>"
+instance ExprType ShellPipeline where
+ textExprType _ = T.pack "ShellPipeline"
+ textExprValue _ = "<shell-pipeline>"
-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
+instance ExprType ShellCommand where
+ textExprType _ = T.pack "ShellCommand"
+ textExprValue _ = "<shell-command>"
+
+instance ExprType ShellArgument where
+ textExprType _ = T.pack "ShellArgument"
+ textExprValue _ = "<shell-argument>"
+
+
+data ShellExecInfo = ShellExecInfo
+ { seiNode :: Node
+ , seiProcName :: ProcName
+ , seiStatusVar :: MVar ExitCode
+ }
+
+
+data HandleHandling
+ = CloseHandle Handle
+ | KeepHandle Handle
+
+closeIfRequested :: MonadIO m => HandleHandling -> m ()
+closeIfRequested (CloseHandle h) = liftIO $ hClose h
+closeIfRequested (KeepHandle _) = return ()
+
+handledHandle :: HandleHandling -> Handle
+handledHandle (CloseHandle h) = h
+handledHandle (KeepHandle h) = h
+
+
+executeCommand :: ShellExecInfo -> HandleHandling -> HandleHandling -> HandleHandling -> ShellCommand -> TestRun ()
+executeCommand ShellExecInfo {..} pstdin pstdout pstderr scmd@ShellCommand {..} = do
+ let args = cmdArguments scmd
+ ( pstdin', pstdout', pstderr' ) <- (\f -> foldM f ( pstdin, pstdout, pstderr ) cmdExtArguments) $ \cur@( cin, cout, cerr ) -> \case
+ ShellRedirectStdin path -> do
+ closeIfRequested cin
+ h <- liftIO $ openBinaryFile (nodeDir seiNode </> T.unpack path) ReadMode
+ return ( CloseHandle h, cout, cerr )
+ ShellRedirectStdout append path -> do
+ closeIfRequested cout
+ h <- liftIO $ openBinaryFile (nodeDir seiNode </> T.unpack path) $ if append then AppendMode else WriteMode
+ return ( cin, CloseHandle h, cerr )
+ ShellRedirectStderr append path -> do
+ closeIfRequested cerr
+ h <- liftIO $ openBinaryFile (nodeDir seiNode </> T.unpack path) $ if append then AppendMode else WriteMode
+ return ( cin, cout, CloseHandle h )
+ _ -> do
+ return cur
+
+ pid <- liftIO $ do
+ (_, _, _, phandle) <- createProcess_ "shell"
+ (proc (T.unpack cmdCommand) (map T.unpack args))
+ { std_in = UseHandle $ handledHandle pstdin'
+ , std_out = UseHandle $ handledHandle pstdout'
+ , std_err = UseHandle $ handledHandle pstderr'
+ , cwd = Just (nodeDir seiNode)
+ , env = Just []
+ }
+ Just pid <- getPid phandle
+ return pid
+
+ mapM_ closeIfRequested [ pstdin', pstdout', pstderr' ]
+ liftIO (getProcessStatus True False pid) >>= \case
+ Just (Exited ExitSuccess) -> do
+ return ()
+ Just (Exited status) -> do
+ outLine OutputChildFail (Just $ textProcName seiProcName) $ "failed at: " <> textSourceLine cmdSourceLine
+ liftIO $ putMVar seiStatusVar status
+ throwError Failed
+ Just (Terminated sig _) -> do
+ outLine OutputChildFail (Just $ textProcName seiProcName) $ "killed with " <> T.pack (show sig) <> " at: " <> textSourceLine cmdSourceLine
+ liftIO $ putMVar seiStatusVar (ExitFailure (- fromIntegral sig))
+ throwError Failed
+ Just (Stopped sig) -> do
+ outLine OutputChildFail (Just $ textProcName seiProcName) $ "stopped with " <> T.pack (show sig) <> " at: " <> textSourceLine cmdSourceLine
+ liftIO $ putMVar seiStatusVar (ExitFailure (- fromIntegral sig))
+ throwError Failed
+ Nothing -> do
+ outLine OutputChildFail (Just $ textProcName seiProcName) $ "no exit status"
+ liftIO $ putMVar seiStatusVar (ExitFailure (- 1))
+ throwError Failed
+
+executePipeline :: ShellExecInfo -> HandleHandling -> HandleHandling -> HandleHandling -> ShellPipeline -> TestRun ()
+executePipeline sei pstdin pstdout pstderr ShellPipeline {..} = do
+ case pipeUpstream of
+ Nothing -> do
+ executeCommand sei pstdin pstdout pstderr pipeCommand
+
+ Just upstream -> do
+ ( pipeRead, pipeWrite ) <- createPipeCloexec
+ void $ forkTestUsing forkOS $ do
+ executePipeline sei pstdin (CloseHandle pipeWrite) (KeepHandle $ handledHandle pstderr) upstream
+
+ executeCommand sei (CloseHandle pipeRead) pstdout (KeepHandle $ handledHandle pstderr) pipeCommand
+ closeIfRequested pstderr
+
+executeScript :: ShellExecInfo -> Handle -> Handle -> Handle -> ShellScript -> TestRun ()
+executeScript sei@ShellExecInfo {..} pstdin pstdout pstderr (ShellScript statements) = do
+ setNetworkNamespace $ getNetns seiNode
+ forM_ statements $ \ShellStatement {..} -> do
+ executePipeline sei (KeepHandle pstdin) (KeepHandle pstdout) (KeepHandle pstderr) shellPipeline
+ liftIO $ putMVar seiStatusVar ExitSuccess
spawnShell :: Node -> ProcName -> ShellScript -> TestRun Process
spawnShell procNode procName script = do
+ idVar <- asks $ teNextProcId . fst
+ procId <- liftIO $ modifyMVar idVar (\x -> return ( x + 1, ProcessId x ))
+
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
+ procIgnore <- liftIO $ newTVarIO ( 0, [] )
+ seiStatusVar <- liftIO $ newEmptyMVar
+ ( pstdin, procStdin ) <- createPipeCloexec
+ ( hout, pstdout ) <- createPipeCloexec
+ ( herr, pstderr ) <- createPipeCloexec
+ procHandle <- fmap (Right . (, seiStatusVar)) $ forkTestUsing forkOS $ do
+ let seiNode = procNode
+ seiProcName = procName
+ executeScript ShellExecInfo {..} pstdin pstdout pstderr script
+ liftIO $ do
+ hClose pstdin
+ hClose pstdout
+ hClose pstderr
let procKillWith = Nothing
+ let procPid = 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
-
+ startProcessIOLoops process hout herr
return process
withShellProcess :: Node -> ProcName -> ShellScript -> (Process -> TestRun a) -> TestRun a
@@ -85,5 +217,19 @@ withShellProcess node pname script inner = do
inner process `finally` do
ps <- liftIO $ takeMVar procVar
- closeProcess process `finally` do
+ closeTestProcess process `finally` do
liftIO $ putMVar procVar $ filter (/=process) ps
+
+
+foreign import ccall "shell_pipe_cloexec" c_pipe_cloexec :: Ptr Fd -> IO CInt
+
+createPipeCloexec :: (MonadIO m, MonadFail m) => m ( Handle, Handle )
+createPipeCloexec = liftIO $ do
+ allocaArray 2 $ \ptr -> do
+ c_pipe_cloexec ptr >>= \case
+ 0 -> do
+ rh <- P.fdToHandle =<< peekElemOff ptr 0
+ wh <- P.fdToHandle =<< peekElemOff ptr 1
+ return ( rh, wh )
+ _ -> do
+ fail $ "failed to create pipe"
diff --git a/src/Script/Var.hs b/src/Script/Var.hs
index 668060c..2c50101 100644
--- a/src/Script/Var.hs
+++ b/src/Script/Var.hs
@@ -9,6 +9,8 @@ module Script.Var (
import Data.Text (Text)
import Data.Text qualified as T
+import Script.Expr.Class
+
newtype VarName = VarName Text
deriving (Eq, Ord)
@@ -40,6 +42,10 @@ unqualifyName (LocalVarName name) = name
newtype TypedVarName a = TypedVarName { fromTypedVarName :: VarName }
deriving (Eq, Ord)
+instance ExprType a => ExprType (TypedVarName a) where
+ textExprType _ = "TypedVarName"
+ textExprValue = textVarName . fromTypedVarName
+
newtype ModuleName = ModuleName [ Text ]
deriving (Eq, Ord, Show)
@@ -54,3 +60,7 @@ data SourceLine
textSourceLine :: SourceLine -> Text
textSourceLine (SourceLine text) = text
textSourceLine SourceLineBuiltin = "<builtin>"
+
+instance ExprType SourceLine where
+ textExprType _ = "SourceLine"
+ textExprValue = textSourceLine
diff --git a/src/Test.hs b/src/Test.hs
index b8c5049..61f2e3d 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -1,23 +1,42 @@
module Test (
Test(..),
+ Tag(..),
TestStep(..),
TestBlock(..),
+
+ MultiplyTimeout(..),
) where
+import Control.Concurrent.MVar
+import Control.Monad.Except
+import Control.Monad.Reader
+
+import Data.Bifunctor
import Data.Scientific
-import Data.Text (Text)
+import Data.Text (Text, pack)
import Data.Typeable
import Network
+import Output
import Process
+import Run.Monad
import Script.Expr
+import Script.Object
import Script.Shell
data Test = Test
{ testName :: Text
- , testSteps :: Expr (TestBlock ())
+ , testTags :: [ Expr Tag ]
+ , testSteps :: Expr (TestStep ())
}
+data Tag = Tag ModuleName VarName
+ deriving (Eq)
+
+instance ExprType Tag where
+ textExprType _ = "Tag"
+ textExprValue (Tag mname vname) = "<tag:" <> textModuleName mname <> "." <> textVarName vname <> ">"
+
data TestBlock a where
EmptyTestBlock :: TestBlock ()
TestBlockStep :: TestBlock () -> TestStep a -> TestBlock a
@@ -31,20 +50,51 @@ 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
+ Scope :: TestBlock a -> TestStep a
+ CreateObject :: forall o. ObjectType TestRun o => Proxy o -> ConstructorArgs o -> TestStep ()
+ Subnet :: TypedVarName Network -> Network -> (Network -> TestStep a) -> TestStep a
+ DeclNode :: TypedVarName Node -> Network -> (Node -> TestStep a) -> TestStep a
+ Spawn :: TypedVarName Process -> Either Network Node -> [ Text ] -> Maybe Signal -> (Process -> TestStep a) -> TestStep a
+ SpawnShell :: Maybe (TypedVarName Process) -> Node -> ShellScript -> (Process -> TestStep a) -> TestStep a
Send :: Process -> Text -> TestStep ()
- Expect :: SourceLine -> Process -> Traced Regex -> [ TypedVarName Text ] -> ([ Text ] -> TestBlock a) -> TestStep a
+ Expect :: CallStack -> SourceLine -> Process -> Traced Regex -> Scientific -> [ TypedVarName Text ] -> ([ Text ] -> TestStep 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
+ Guard :: CallStack -> Bool -> TestStep ()
+ DisconnectNode :: Node -> TestStep a -> TestStep a
+ DisconnectNodes :: Network -> TestStep a -> TestStep a
+ DisconnectUpstream :: Network -> TestStep a -> TestStep a
+ PacketLoss :: Scientific -> Node -> TestStep a -> TestStep a
Wait :: TestStep ()
-instance Typeable a => ExprType (TestBlock a) where
- textExprType _ = "test block"
- textExprValue _ = "<test block>"
+instance ExprType a => ExprType (TestBlock a) where
+ textExprType _ = "TestBlock"
+ textExprValue _ = "<test-block>"
+
+instance ExprType a => ExprType (TestStep a) where
+ textExprType _ = "TestStep"
+ textExprValue _ = "<test-step>"
+
+
+data MultiplyTimeout = MultiplyTimeout Scientific
+
+instance ObjectType TestRun MultiplyTimeout where
+ type ConstructorArgs MultiplyTimeout = Scientific
+
+ textObjectType _ _ = "MultiplyTimeout"
+ textObjectValue _ (MultiplyTimeout x) = pack (show x) <> "@MultiplyTimeout"
+
+ createObject oid timeout
+ | timeout >= 0 = do
+ var <- asks (teTimeout . fst)
+ liftIO $ modifyMVar_ var $ return .
+ (if timeout == 0 then second (+ 1) else first (* timeout))
+ return $ Object oid $ MultiplyTimeout timeout
+
+ | otherwise = do
+ outLine OutputError Nothing "timeout must not be negative"
+ throwError Failed
+
+ destroyObject Object { objImpl = MultiplyTimeout timeout } = do
+ var <- asks (teTimeout . fst)
+ liftIO $ modifyMVar_ var $ return .
+ (if timeout == 0 then second (subtract 1) else first (/ timeout))
diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs
index 69579bc..85f7b86 100644
--- a/src/Test/Builtins.hs
+++ b/src/Test/Builtins.hs
@@ -3,55 +3,86 @@ module Test.Builtins (
) where
import Data.Map qualified as M
-import Data.Maybe
+import Data.Proxy
+import Data.Scientific
import Data.Text (Text)
+import Data.Text qualified as T
-import Process (Process)
+import Process
+import Process.Signal
import Script.Expr
import Test
builtins :: GlobalDefs
-builtins = M.fromList
- [ fq "send" builtinSend
- , fq "flush" builtinFlush
- , fq "guard" builtinGuard
- , fq "wait" builtinWait
+builtins = M.fromList $ concat
+ [ [ fq "send" builtinSend
+ , fq "flush" builtinFlush
+ , fq "ignore" builtinIgnore
+ , fq "guard" builtinGuard
+ , fq "multiply_timeout" builtinMultiplyTimeout
+ , fq "wait" builtinWait
+ , fq "concat" builtinConcat
+ ]
+ , map (uncurry fq) signalBuiltins
]
where
fq name impl = (( ModuleName [ "$" ], VarName name ), impl )
-getArg :: ExprType a => FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> a
-getArg args = fromMaybe (error "parameter mismatch") . getArgMb args
+biVar :: ExprType a => Text -> Expr a
+biVar = Variable SourceLineBuiltin . LocalVarName . VarName
-getArgMb :: ExprType a => FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> Maybe a
-getArgMb (FunctionArguments args) kw = do
- fromSomeVarValue SourceLineBuiltin (LocalVarName (VarName "")) =<< M.lookup kw args
+biOpt :: ExprType a => Text -> Expr (Maybe a)
+biOpt = OptVariable SourceLineBuiltin . LocalVarName . VarName
-getArgVars :: FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> [ (( FqVarName, [ Text ] ), SomeVarValue ) ]
-getArgVars (FunctionArguments args) kw = do
- maybe [] svvVariables $ M.lookup kw args
+biArgs :: [ ( Maybe ArgumentKeyword, a ) ] -> FunctionArguments ( VarName, a )
+biArgs = FunctionArguments . M.fromList . map (\( kw, atype ) -> ( kw, ( VarName $ maybe "$0" (\(ArgumentKeyword tkw) -> "$" <> tkw) kw, atype ) ))
-builtinSend :: SomeVarValue
-builtinSend = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $
- \_ args -> TestBlockStep EmptyTestBlock $ Send (getArg args (Just "to")) (getArg args Nothing)
+builtinSend :: SomeExpr
+builtinSend = SomeExpr $ ArgsReq (biArgs atypes) $
+ FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (Send <$> biVar "$to" <*> biVar "$0")
where
atypes =
- [ ( Just "to", SomeArgumentType (ContextDefault @Process) )
- , ( Nothing, SomeArgumentType (RequiredArgument @Text) )
+ [ ( Just "to", SomeArgumentType ContextDefault (ExprTypePrim (Proxy @Process)) )
+ , ( Nothing, SomeArgumentType RequiredArgument (ExprTypePrim (Proxy @Text)) )
]
-builtinFlush :: SomeVarValue
-builtinFlush = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $
- \_ args -> TestBlockStep EmptyTestBlock $ Flush (getArg args (Just "from")) (getArgMb args (Just "matching"))
+builtinFlush :: SomeExpr
+builtinFlush = SomeExpr $ ArgsReq (biArgs atypes) $
+ FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (Flush <$> biVar "$from" <*> biOpt "$matching")
where
atypes =
- [ ( Just "from", SomeArgumentType (ContextDefault @Process) )
- , ( Just "matching", SomeArgumentType (OptionalArgument @Regex) )
+ [ ( Just "from", SomeArgumentType ContextDefault (ExprTypePrim (Proxy @Process)) )
+ , ( Just "matching", SomeArgumentType OptionalArgument (ExprTypePrim (Proxy @Regex)) )
]
-builtinGuard :: SomeVarValue
-builtinGuard = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton Nothing (SomeArgumentType (RequiredArgument @Bool))) $
- \sline args -> TestBlockStep EmptyTestBlock $ Guard sline (getArgVars args Nothing) (getArg args Nothing)
+builtinIgnore :: SomeExpr
+builtinIgnore = SomeExpr $ ArgsReq (biArgs atypes) $
+ FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (CreateObject (Proxy @IgnoreProcessOutput) <$> ((,) <$> biVar "$from" <*> biOpt "$matching"))
+ where
+ atypes =
+ [ ( Just "from", SomeArgumentType ContextDefault (ExprTypePrim (Proxy @Process)) )
+ , ( Just "matching", SomeArgumentType OptionalArgument (ExprTypePrim (Proxy @Regex)) )
+ ]
+
+builtinGuard :: SomeExpr
+builtinGuard = SomeExpr $
+ ArgsReq (biArgs [ ( Nothing, SomeArgumentType RequiredArgument (ExprTypePrim (Proxy @Bool)) ) ]) $
+ FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (Guard <$> Variable SourceLineBuiltin callStackFqVarName <*> biVar "$0")
+
+builtinMultiplyTimeout :: SomeExpr
+builtinMultiplyTimeout = SomeExpr $ ArgsReq (biArgs $ [ ( Just "by", SomeArgumentType RequiredArgument (ExprTypePrim (Proxy @Scientific)) ) ]) $
+ FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (CreateObject (Proxy @MultiplyTimeout) <$> biVar "$by")
+
+builtinWait :: SomeExpr
+builtinWait = SomeExpr $ Pure $ TestBlockStep EmptyTestBlock Wait
-builtinWait :: SomeVarValue
-builtinWait = someConstValue $ TestBlockStep EmptyTestBlock Wait
+builtinConcat :: SomeExpr
+builtinConcat = SomeExpr $ TypeLambda (TypeVar "a")
+ (ExprTypeFunction
+ (ExprTypeArguments $ FunctionArguments $ M.singleton Nothing $ SomeArgumentType RequiredArgument
+ (ExprTypeApp (ExprTypeConstr1 (Proxy @[])) [ ExprTypeApp (ExprTypeConstr1 (Proxy @[])) [ ExprTypeVar (TypeVar "a") ] ] ))
+ (ExprTypeApp (ExprTypeConstr1 (Proxy @[])) [ ExprTypeVar (TypeVar "a") ])
+ ) $ \case
+ ExprTypePrim (pa :: Proxy a) -> HideFunType (FunctionArguments $ M.singleton Nothing $ SomeArgumentType RequiredArgument (ExprTypePrim (Proxy :: Proxy [[ a ]]))) $
+ ArgsReq (biArgs [ ( Nothing, SomeArgumentType RequiredArgument (ExprTypePrim pa) ) ]) $ FunctionAbstraction $ (concat :: [[ a ]] -> [ a ]) <$> biVar "$0"
+ t -> Undefined ("ambiguous type ‘" <> T.unpack (textSomeExprType t) <> "’ for concat") :: Expr DynamicType
diff --git a/src/TestMode.hs b/src/TestMode.hs
index ab938e6..22d8237 100644
--- a/src/TestMode.hs
+++ b/src/TestMode.hs
@@ -4,12 +4,13 @@ module TestMode (
testMode,
) where
+import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
-import Data.Bifunctor
import Data.List
+import Data.Maybe
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.IO qualified as T
@@ -19,39 +20,40 @@ import System.IO.Error
import Text.Megaparsec.Error
import Text.Megaparsec.Pos
+import Config
import Output
import Parser
import Run
import Script.Expr
-import Script.Module
import Test
data TestModeInput = TestModeInput
{ tmiOutput :: Output
+ , tmiConfig :: Maybe Config
, tmiParams :: [ Text ]
}
data TestModeState = TestModeState
- { tmsModules :: [ Module ]
- , tmsGlobals :: GlobalDefs
+ { tmsModules :: Maybe LoadedModules
+ , tmsNextTestNumber :: Int
}
initTestModeState :: TestModeState
initTestModeState = TestModeState
- { tmsModules = mempty
- , tmsGlobals = mempty
+ { tmsModules = Nothing
+ , tmsNextTestNumber = 1
}
-testMode :: IO ()
-testMode = do
- out <- startOutput OutputStyleTest False
+testMode :: Maybe Config -> IO ()
+testMode tmiConfig = do
+ tmiOutput <- startOutput OutputStyleTest False
let testLoop = getLineMb >>= \case
Just line -> do
case T.words line of
- cname : params
+ cname : tmiParams
| Just (CommandM cmd) <- lookup cname commands -> do
- runReaderT cmd $ TestModeInput out params
+ runReaderT cmd $ TestModeInput {..}
| otherwise -> fail $ "Unknown command '" ++ T.unpack cname ++ "'"
[] -> return ()
testLoop
@@ -59,7 +61,7 @@ testMode = do
Nothing -> return ()
runExceptT (evalStateT testLoop initTestModeState) >>= \case
- Left err -> flip runReaderT out $ outLine OutputError Nothing $ T.pack err
+ Left err -> flip runReaderT tmiOutput $ outLine OutputError Nothing $ T.pack err
Right () -> return ()
getLineMb :: MonadIO m => m (Maybe Text)
@@ -70,6 +72,25 @@ cmdOut line = do
out <- asks tmiOutput
flip runReaderT out $ outLine OutputTestRaw Nothing line
+getNextTestNumber :: CommandM Int
+getNextTestNumber = do
+ num <- gets tmsNextTestNumber
+ modify $ \s -> s { tmsNextTestNumber = num + 1 }
+ return num
+
+runSingleTest :: Test -> CommandM Bool
+runSingleTest test = do
+ out <- asks tmiOutput
+ num <- getNextTestNumber
+ Just LoadedModules {..} <- gets tmsModules
+ mbconfig <- asks tmiConfig
+ let opts = defaultTestOptions
+ { optDefaultTool = fromMaybe "/bin/true" $ configTool =<< mbconfig
+ , optTestDir = ".test" <> show num
+ , optKeep = True
+ }
+ liftIO (runTest out opts lmGlobalDefs test)
+
newtype CommandM a = CommandM (ReaderT TestModeInput (StateT TestModeState (ExceptT String IO)) a)
deriving
@@ -85,30 +106,25 @@ type Command = CommandM ()
commands :: [ ( Text, Command ) ]
commands =
[ ( "load", cmdLoad )
+ , ( "load-config", cmdLoadConfig )
, ( "run", cmdRun )
]
-cmdLoad :: Command
-cmdLoad = do
- [ path ] <- asks tmiParams
- liftIO (parseTestFiles [ T.unpack path ]) >>= \case
- Right ( modules, allModules ) -> do
- let globalDefs = evalGlobalDefs $ concatMap (\m -> map (first ( moduleName m, )) $ moduleDefinitions m) allModules
- modify $ \s -> s
- { tmsModules = modules
- , tmsGlobals = globalDefs
- }
- cmdOut "load-done"
-
- Left (ModuleNotFound moduleName) -> do
- cmdOut $ "load-failed module-not-found" <> textModuleName moduleName
- Left (FileNotFound notFoundPath) -> do
- cmdOut $ "load-failed file-not-found " <> T.pack notFoundPath
- Left (ImportModuleError bundle) -> do
+showError :: Text -> CustomTestError -> Command
+showError prefix = \case
+ ModuleNotFound moduleName -> do
+ cmdOut $ prefix <> " module-not-found" <> textModuleName moduleName
+ FileNotFound notFoundPath -> do
+ cmdOut $ prefix <> " file-not-found " <> T.pack notFoundPath
+ TestNotFound tname mbfile -> do
+ cmdOut $ prefix <> " test-not-found " <> tname <> maybe "" ((" " <>) . T.pack) mbfile
+ TestOrTagNotFound tname mbfile -> do
+ cmdOut $ prefix <> " test-or-tag-not-found " <> tname <> maybe "" ((" " <>) . T.pack) mbfile
+ ImportModuleError bundle -> do
#if MIN_VERSION_megaparsec(9,7,0)
- mapM_ (cmdOut . T.pack) $ lines $ errorBundlePrettyWith showParseError bundle
+ mapM_ (cmdOut . T.pack) $ lines $ errorBundlePrettyWith showParseError bundle
#endif
- cmdOut $ "load-failed parse-error"
+ cmdOut $ prefix <> " parse-error"
where
showParseError _ SourcePos {..} _ = concat
[ "parse-error"
@@ -117,14 +133,35 @@ cmdLoad = do
, ":", show $ unPos sourceColumn
]
+cmdLoad :: Command
+cmdLoad = do
+ [ path ] <- asks tmiParams
+ liftIO (loadModules [ ( T.unpack path, Nothing ) ]) >>= \case
+ Right modules -> do
+ modify $ \s -> s { tmsModules = Just modules }
+ cmdOut "load-done"
+ Left err -> showError "load-failed" err
+
+cmdLoadConfig :: Command
+cmdLoadConfig = do
+ Just config <- asks tmiConfig
+ liftIO (getConfigTestFiles config >>= loadModules . (map (, Nothing ))) >>= \case
+ Right modules -> do
+ modify $ \s -> s { tmsModules = Just modules }
+ cmdOut "load-config-done"
+ Left err -> showError "load-config-failed" err
+
cmdRun :: Command
cmdRun = do
- [ name ] <- asks tmiParams
- TestModeState {..} <- get
- case find ((name ==) . testName) $ concatMap moduleTests tmsModules of
- Nothing -> cmdOut "run-not-found"
- Just test -> do
- out <- asks tmiOutput
- liftIO (runTest out defaultTestOptions tmsGlobals test) >>= \case
- True -> cmdOut "run-done"
- False -> cmdOut "run-failed"
+ params <- asks tmiParams
+ let ( select, exclude ) = fmap (map (T.drop 1)) $ partition (("^" /=) . T.take 1) params
+ pfilter = (TestFilter (if select == [ "*" ] then Nothing else Just select) exclude)
+ cfilter <- asks $ maybe mempty testFilterFromConfig . tmiConfig
+ Just lm <- gets tmsModules
+ case filterTests (cfilter <> pfilter) lm of
+ Left err -> showError "run-failed" err
+ Right tests -> do
+ forM_ tests $ \test -> do
+ res <- runSingleTest test
+ cmdOut $ "run-test-result " <> testName test <> " " <> (if res then "done" else "failed")
+ cmdOut "run-done"
diff --git a/src/main.c b/src/main.c
index 98daf2c..9a6abcb 100644
--- a/src/main.c
+++ b/src/main.c
@@ -9,8 +9,11 @@
#include <sched.h>
#include <stdbool.h>
#include <stdio.h>
+#include <stdlib.h>
#include <string.h>
#include <sys/mount.h>
+#include <sys/stat.h>
+#include <sys/syscall.h>
#include <unistd.h>
/*
@@ -45,9 +48,15 @@ static bool writeProcSelfFile( const char * file, const char * data, size_t size
int main( int argc, char * argv[] )
{
+ int ret;
+
uid_t uid = geteuid();
gid_t gid = getegid();
- unshare( CLONE_NEWUSER | CLONE_NEWNET | CLONE_NEWNS );
+ ret = unshare( CLONE_NEWUSER | CLONE_NEWNET | CLONE_NEWNS );
+ if( ret < 0 ){
+ fprintf( stderr, "unsharing user, network and mount namespaces failed: %s\n", strerror( errno ));
+ return 1;
+ }
char buf[ 256 ];
int len;
@@ -71,7 +80,70 @@ int main( int argc, char * argv[] )
if ( ! writeProcSelfFile( "gid_map", buf, len ) )
return 1;
- mount( "tmpfs", "/run", "tmpfs", 0, "size=4m" );
+ /*
+ * Prepare for future filesystem isolation within additional mount namespace:
+ * - clone whole mount tree as read-only under new /tmp/new_root
+ * - keep writable /proc and /tmp
+ */
+
+ ret = mount( "tmpfs", "/run", "tmpfs", 0, "size=4m" );
+ if( ret < 0 ){
+ fprintf( stderr, "failed to mount tmpfs on /run: %s\n", strerror( errno ));
+ return 1;
+ }
+
+ ret = mkdir( "/run/new_root", 0700 );
+ if( ret < 0 ){
+ fprintf( stderr, "failed to create new_root directory: %s\n", strerror( errno ));
+ return 1;
+ }
+
+ ret = mount( "/", "/run/new_root", NULL, MS_BIND | MS_REC, NULL );
+ if( ret < 0 ){
+ fprintf( stderr, "failed to bind-mount / on new_root: %s\n", strerror( errno ));
+ return 1;
+ }
+
+ struct mount_attr * attr_ro = &( struct mount_attr ) {
+ .attr_set = MOUNT_ATTR_RDONLY,
+ };
+ ret = mount_setattr( -1, "/run/new_root", AT_RECURSIVE, attr_ro, sizeof( * attr_ro ) );
+ if( ret < 0 ){
+ fprintf( stderr, "failed set sandbox root as read-only: %s\n", strerror( errno ));
+ return 1;
+ }
+
+ struct mount_attr * attr_rw = &( struct mount_attr ) {
+ .attr_clr = MOUNT_ATTR_RDONLY,
+ };
+ ret = mount_setattr( -1, "/run/new_root/proc", AT_RECURSIVE, attr_rw, sizeof( * attr_rw ) );
+ if( ret < 0 ){
+ fprintf( stderr, "failed set sandbox /proc as read-write: %s\n", strerror( errno ));
+ return 1;
+ }
+ ret = mount_setattr( -1, "/run/new_root/tmp", AT_RECURSIVE, attr_rw, sizeof( * attr_rw ) );
+ if( ret < 0 ){
+ if( errno == EINVAL ){
+ // Original /tmp is not a separate filesystem, so we can't just change the attributes
+ ret = mount( "/tmp", "/run/new_root/tmp", NULL, MS_BIND, NULL );
+ if( ret < 0 )
+ fprintf( stderr, "failed to bind-mount original /tmp in sandbox as read-write: %s\n", strerror( errno ));
+ } else {
+ fprintf( stderr, "failed set sandbox /tmp as read-write: %s\n", strerror( errno ));
+ }
+ }
+
+ ret = mount( "tmpfs", "/run/new_root/run", "tmpfs", 0, "size=4m" );
+ if( ret < 0 ){
+ fprintf( stderr, "failed to mount tmpfs on sandbox /run: %s\n", strerror( errno ));
+ return 1;
+ }
+
+ ret = mkdir( "/run/new_root/run/old_root", 0700 );
+ if( ret < 0 ){
+ fprintf( stderr, "failed to create old_root directory: %s\n", strerror( errno ));
+ return 1;
+ }
hs_init( &argc, &argv );
testerMain();
@@ -79,3 +151,53 @@ int main( int argc, char * argv[] )
return 0;
}
+
+/*
+ * - Replace filesystem hierarchy with read-only version,
+ * - bind-mound rwdir from writable tree, and
+ * - keep writeable /tmp from host.
+ */
+int erebos_tester_isolate_fs( const char * rwdir )
+{
+ int ret;
+
+ ret = unshare( CLONE_NEWNS );
+ if( ret < 0 ){
+ fprintf( stderr, "unsharing mount namespace failed: %s\n", strerror( errno ));
+ return -1;
+ }
+
+ char * cwd = getcwd( NULL, 0 );
+ ret = syscall( SYS_pivot_root, "/run/new_root", "/run/new_root/run/old_root" );
+ if( ret < 0 ){
+ fprintf( stderr, "failed to pivot_root: %s\n", strerror( errno ));
+ free( cwd );
+ return -1;
+ }
+
+ char oldrwdir[ strlen(rwdir) + 15 ];
+ snprintf( oldrwdir, sizeof oldrwdir, "/run/old_root/%s", rwdir );
+ ret = mount( oldrwdir, rwdir, NULL, MS_BIND, NULL );
+ if( ret < 0 ){
+ fprintf( stderr, "failed to bind-mount %s on %s: %s\n", oldrwdir, rwdir, strerror( errno ));
+ free( cwd );
+ return -1;
+ }
+
+ ret = umount2( "/run/old_root", MNT_DETACH );
+ if( ret < 0 ){
+ fprintf( stderr, "failed to detach /run/old_root: %s\n", strerror( errno ));
+ free( cwd );
+ return -1;
+ }
+
+ ret = chdir( cwd );
+ if( ret < 0 ){
+ fprintf( stderr, "failed to chdir to %s: %s\n", cwd, strerror( errno ));
+ free( cwd );
+ return -1;
+ }
+ free( cwd );
+
+ return 0;
+}
diff --git a/src/shell.c b/src/shell.c
new file mode 100644
index 0000000..d832078
--- /dev/null
+++ b/src/shell.c
@@ -0,0 +1,8 @@
+#define _GNU_SOURCE
+#include <fcntl.h>
+#include <unistd.h>
+
+int shell_pipe_cloexec( int pipefd[ 2 ] )
+{
+ return pipe2( pipefd, O_CLOEXEC );
+}
generated by cgit v1.2.3 (git 2.25.1) at 2026-06-24 16:30:14 +0000