summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Output.hs14
-rw-r--r--src/Parser/Core.hs3
-rw-r--r--src/Run.hs10
-rw-r--r--src/Script/Expr.hs69
-rw-r--r--src/Test.hs2
-rw-r--r--src/Test/Builtins.hs8
6 files changed, 51 insertions, 55 deletions
diff --git a/src/Output.hs b/src/Output.hs
index f8ce41d..0ad1f12 100644
--- a/src/Output.hs
+++ b/src/Output.hs
@@ -167,15 +167,15 @@ outLine otype prompt line = ioWithOutput $ \out ->
normalOutputLines :: OutputType -> Text -> [ Text ]
normalOutputLines (OutputMatchFail (CallStack stack)) msg = concat
- [ msg <> " on " <> textSourceLine stackTopLine : showVars stackTopLine stackTopVars
+ [ msg <> " on " <> textSourceLine stackTopLine : showVars stackTopVars
, concat $ flip map stackRest $ \( sline, vars ) ->
- " called from " <> textSourceLine sline : showVars sline vars
+ " called from " <> textSourceLine sline : showVars vars
]
where
- showVars sline =
+ showVars =
map $ \(( name, sel ), value ) -> T.concat
[ " ", textFqVarName name, T.concat (map ("."<>) sel)
- , " = ", textSomeVarValue sline value
+ , " = ", textSomeVarValue value
]
(( stackTopLine, stackTopVars ), stackRest ) =
case stack of
@@ -188,13 +188,13 @@ 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 sline vars
+ T.concat [ outTestLabel otype, "-line ", textSourceLine sline ] : showVars vars
]
where
- showVars sline =
+ showVars =
map $ \(( name, sel ), value ) -> T.concat
[ outTestLabel otype, "-var ", textFqVarName name, T.concat (map ("."<>) sel)
- , " ", textSomeVarValue sline value
+ , " ", textSomeVarValue value
]
testOutputLines otype prompt msg = [ T.concat [ outTestLabel otype, " ", prompt, " ", msg ] ]
diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs
index 132dbc8..f44e721 100644
--- a/src/Parser/Core.hs
+++ b/src/Parser/Core.hs
@@ -201,7 +201,8 @@ unifyExpr off pa expr = if
SomeExpr context <- gets testContext
context' <- unifyExpr off atype context
return $ Just ( kw, SomeExpr context' )
- return (FunctionEval $ ArgsApp (FunctionArguments $ M.fromAscList defaults) expr)
+ sline <- getSourceLine
+ return (FunctionEval sline $ ArgsApp (FunctionArguments $ M.fromAscList defaults) expr)
| Just (Refl :: DynamicType :~: b) <- eqT
, Undefined msg <- expr
diff --git a/src/Run.hs b/src/Run.hs
index 3ecd7d4..2e5d641 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -208,8 +208,8 @@ runStep = \case
Flush p regex -> do
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) $ runStep inner
@@ -343,6 +343,6 @@ expect sline p (Traced trace re) tvars inner = do
Nothing -> exprFailed (T.pack "expect") (CallStack [ ( sline, trace ) ]) (Just $ procName p)
-testStepGuard :: SourceLine -> EvalTrace -> Bool -> TestRun ()
-testStepGuard sline vars x = do
- when (not x) $ exprFailed (T.pack "guard") (CallStack [ ( sline, vars ) ]) Nothing
+testStepGuard :: CallStack -> Bool -> TestRun ()
+testStepGuard stack x = do
+ when (not x) $ exprFailed (T.pack "guard") stack Nothing
diff --git a/src/Script/Expr.hs b/src/Script/Expr.hs
index 022ec88..4e99a26 100644
--- a/src/Script/Expr.hs
+++ b/src/Script/Expr.hs
@@ -58,7 +58,7 @@ data Expr a where
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
LambdaAbstraction :: ExprType a => TypedVarName a -> Expr b -> Expr (a -> b)
Pure :: a -> Expr a
App :: AppAnnotation b -> Expr (a -> b) -> Expr a -> Expr b
@@ -98,7 +98,7 @@ mapExpr f = go
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)
LambdaAbstraction tvar expr -> f $ LambdaAbstraction tvar (go expr)
e@Pure {} -> f e
App ann efun earg -> f $ App ann (go efun) (go earg)
@@ -131,12 +131,6 @@ withVar name value = withDictionary (( name, someConstValue value ) : )
withTypedVar :: (MonadEval m, ExprType e) => TypedVarName e -> e -> m a -> m a
withTypedVar (TypedVarName name) = withVar name
-isInternalVar :: FqVarName -> Bool
-isInternalVar (GlobalVarName {}) = False
-isInternalVar (LocalVarName (VarName name))
- | Just ( '$', _ ) <- T.uncons name = True
- | otherwise = False
-
newtype SimpleEval a = SimpleEval (Reader ( GlobalDefs, VariableDictionary ) a)
deriving (Functor, Applicative, Monad)
@@ -157,26 +151,27 @@ eval = \case
Let _ (TypedVarName name) valExpr expr -> do
val <- eval valExpr
withVar name val $ eval expr
- Variable sline name -> fromSomeVarValue sline name =<< lookupVar name
+ Variable _ name -> fromSomeVarValue (CallStack []) name =<< lookupVar name
DynVariable _ _ name -> fail $ "ambiguous type of ‘" <> unpackFqVarName name <> "’"
- FunVariable _ sline name -> funFromSomeVarValue sline name =<< lookupVar name
+ FunVariable _ _ name -> funFromSomeVarValue name =<< lookupVar name
ArgsReq (FunctionArguments req) efun -> do
gdefs <- askGlobalDefs
dict <- askDictionary
- return $ FunctionType $ \(FunctionArguments args) ->
+ return $ FunctionType $ \stack (FunctionArguments args) ->
let used = M.intersectionWith (\value ( vname, _ ) -> ( vname, value )) args req
FunctionType fun = runSimpleEval (eval efun) gdefs (toList used ++ dict)
- in fun $ FunctionArguments $ args `M.difference` req
+ 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
+ return $ FunctionType $ const $ const val
+ FunctionEval sline efun -> do
FunctionType fun <- eval efun
- return $ fun mempty
+ vars <- gatherVars efun
+ return $ fun (CallStack [ ( sline, vars ) ]) mempty
LambdaAbstraction (TypedVarName name) expr -> do
gdefs <- askGlobalDefs
dict <- askDictionary
@@ -205,7 +200,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,7 +211,7 @@ 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"
@@ -289,7 +284,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,27 +298,27 @@ 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
@@ -356,10 +351,10 @@ exprArgs = \case
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
+funFromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => FqVarName -> SomeVarValue -> m (FunctionType a)
+funFromSomeVarValue name (SomeVarValue (VarValue _ args value :: VarValue b)) = do
maybe (fail err) return $ do
- FunctionType <$> cast (value sline)
+ FunctionType <$> cast value
where
err = T.unpack $ T.concat [ T.pack "expected function returning ", textExprType @a Proxy, T.pack ", but variable '", textFqVarName name, T.pack "' has ",
(if anull args then "type " else "function type returting ") <> textExprType @b Proxy ]
@@ -386,17 +381,21 @@ gatherVars = fmap (uniqOn fst . sortOn fst) . helper
helper = \case
Let _ (TypedVarName var) _ expr -> withDictionary (filter ((var /=) . fst)) $ helper expr
Variable _ var
- | isInternalVar var -> return []
+ | GlobalVarName {} <- var -> return []
+ | otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var
+ DynVariable _ _ var
+ | GlobalVarName {} <- var -> return []
+ | otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var
+ FunVariable _ _ var
+ | GlobalVarName {} <- var -> return []
| otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var
- DynVariable _ _ var -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var
- FunVariable _ _ var -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var
ArgsReq args expr -> withDictionary (filter ((`notElem` map fst (toList args)) . fst)) $ helper expr
ArgsApp (FunctionArguments args) fun -> do
v <- helper fun
vs <- mapM (\(SomeExpr e) -> helper e) $ M.elems args
return $ concat (v : vs)
FunctionAbstraction expr -> helper expr
- FunctionEval efun -> helper efun
+ FunctionEval _ efun -> helper efun
LambdaAbstraction (TypedVarName var) expr -> withDictionary (filter ((var /=) . fst)) $ helper expr
Pure _ -> return []
e@(App (AnnRecord sel) _ x)
diff --git a/src/Test.hs b/src/Test.hs
index 3e98efa..ce88052 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -49,7 +49,7 @@ data TestStep a where
Send :: Process -> Text -> TestStep ()
Expect :: SourceLine -> Process -> Traced Regex -> [ TypedVarName Text ] -> ([ Text ] -> TestStep a) -> TestStep a
Flush :: Process -> Maybe Regex -> TestStep ()
- Guard :: SourceLine -> EvalTrace -> Bool -> TestStep ()
+ Guard :: CallStack -> Bool -> TestStep ()
DisconnectNode :: Node -> TestStep a -> TestStep a
DisconnectNodes :: Network -> TestStep a -> TestStep a
DisconnectUpstream :: Network -> TestStep a -> TestStep a
diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs
index 244ff57..5f9f890 100644
--- a/src/Test/Builtins.hs
+++ b/src/Test/Builtins.hs
@@ -29,11 +29,7 @@ getArg args = fromMaybe (error "parameter mismatch") . getArgMb args
getArgMb :: ExprType a => FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> Maybe a
getArgMb (FunctionArguments args) kw = do
- fromSomeVarValue SourceLineBuiltin (LocalVarName (VarName "")) =<< M.lookup kw args
-
-getArgVars :: FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> [ (( FqVarName, [ Text ] ), SomeVarValue ) ]
-getArgVars (FunctionArguments args) kw = do
- maybe [] svvVariables $ M.lookup kw args
+ fromSomeVarValue (CallStack []) (LocalVarName (VarName "")) =<< M.lookup kw args
builtinSend :: SomeVarValue
builtinSend = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $
@@ -64,7 +60,7 @@ builtinIgnore = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atype
builtinGuard :: SomeVarValue
builtinGuard = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton Nothing (SomeArgumentType (RequiredArgument @Bool))) $
- \sline args -> TestBlockStep EmptyTestBlock $ Guard sline (getArgVars args Nothing) (getArg args Nothing)
+ \stack args -> TestBlockStep EmptyTestBlock $ Guard stack (getArg args Nothing)
builtinMultiplyTimeout :: SomeVarValue
builtinMultiplyTimeout = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton (Just "by") (SomeArgumentType (RequiredArgument @Scientific))) $
generated by cgit v1.2.3 (git 2.25.1) at 2025-09-16 05:35:10 +0000