Arbitrary expressions as variable valuesHEADmaster

6 files changed, 67 insertions, 62 deletions

diff --git a/src/Parser.hs b/src/Parser.hs
index c83d781..191d40d 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -242,7 +242,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/Process/Signal.hs b/src/Process/Signal.hs
index f6619f6..e57b68d 100644
--- a/src/Process/Signal.hs
+++ b/src/Process/Signal.hs
@@ -51,8 +51,8 @@ instance ExprType Signal where
         | otherwise = "<SIG_" <> T.pack (show sig) <> ">"
 
 
-signalBuiltins :: [ ( Text, SomeVarValue ) ]
-signalBuiltins = map (fmap someConstValue)
+signalBuiltins :: [ ( Text, SomeExpr ) ]
+signalBuiltins = map (fmap $ SomeExpr . Pure)
     [ ( "SIGHUP", Signal Posix.sigHUP )
     , ( "SIGINT", Signal Posix.sigINT )
     , ( "SIGQUIT", Signal Posix.sigQUIT )
diff --git a/src/Run.hs b/src/Run.hs
index a23b254..b8ab186 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -10,7 +10,6 @@ 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
 
@@ -82,7 +81,7 @@ runTest out opts gdefs test = do
             }
         tstate = TestState
             { tsGlobals = gdefs
-            , tsLocals = [ ( callStackVarName, someConstValue (CallStack []) ) ]
+            , tsLocals = [ ( callStackVarName, SomeExpr $ Pure $ CallStack [] ) ]
             , tsNodePacketLoss = M.empty
             , tsDisconnectedUp = S.empty
             , tsDisconnectedBridge = S.empty
@@ -160,8 +159,7 @@ loadModules files = do
 
 
 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
 
 runBlock :: TestBlock () -> TestRun ()
 runBlock EmptyTestBlock = return ()
diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs
index 7a1d3c5..f4444e8 100644
--- a/src/Run/Monad.hs
+++ b/src/Run/Monad.hs
@@ -52,7 +52,7 @@ data TestEnv = TestEnv
 
 data TestState = TestState
     { tsGlobals :: GlobalDefs
-    , tsLocals :: [ ( VarName, SomeVarValue ) ]
+    , tsLocals :: [ ( VarName, SomeExpr ) ]
     , tsDisconnectedUp :: Set NetworkNamespace
     , tsDisconnectedBridge :: Set NetworkNamespace
     , tsNodePacketLoss :: Map NetworkNamespace Scientific
diff --git a/src/Script/Expr.hs b/src/Script/Expr.hs
index 3d26157..06eb9f6 100644
--- a/src/Script/Expr.hs
+++ b/src/Script/Expr.hs
@@ -58,6 +58,7 @@ data Expr a where
     Variable :: ExprType a => SourceLine -> FqVarName -> Expr a
     DynVariable :: SomeExprType -> SourceLine -> FqVarName -> Expr DynamicType
     FunVariable :: ExprType a => FunctionArguments SomeArgumentType -> 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)
@@ -101,6 +102,7 @@ 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)
@@ -123,19 +125,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
@@ -176,14 +178,15 @@ eval = \case
     Let _ (TypedVarName name) valExpr expr -> do
         val <- eval valExpr
         withVar name val $ eval expr
-    Variable _ name -> fromSomeVarValue (CallStack []) name =<< lookupVar name
+    Variable _ name -> evalSomeExpr name =<< lookupVar name
     DynVariable _ _ name -> fail $ "ambiguous type of ‘" <> unpackFqVarName name <> "’"
-    FunVariable _ _ name -> funFromSomeVarValue name =<< lookupVar name
+    FunVariable _ _ name -> evalSomeExpr name =<< lookupVar name
+    OptVariable _ name -> maybe (return Nothing) (fmap Just . evalSomeExpr name) =<< tryLookupVar name
     ArgsReq (FunctionArguments req) efun -> do
         gdefs <- askGlobalDefs
         dict <- askDictionary
         return $ FunctionType $ \stack (FunctionArguments args) ->
-            let used = M.intersectionWith (\value ( vname, _ ) -> ( vname, value )) args req
+            let used = M.intersectionWith (\(SomeVarValue value) ( vname, _ ) -> ( vname, SomeExpr $ Pure $ vvFunction value (CallStack []) mempty )) args req
                 FunctionType fun = runSimpleEval (eval efun) gdefs (toList used ++ dict)
              in fun stack $ FunctionArguments $ args `M.difference` req
     ArgsApp eargs efun -> do
@@ -194,10 +197,10 @@ eval = \case
         gdefs <- askGlobalDefs
         dict <- askDictionary
         return $ FunctionType $ \stack _ ->
-            runSimpleEval (eval expr) gdefs (( callStackVarName, someConstValue stack ) : filter ((callStackVarName /=) . fst) dict)
+            runSimpleEval (eval expr) gdefs (( callStackVarName, SomeExpr (Pure stack) ) : filter ((callStackVarName /=) . fst) dict)
     FunctionEval sline efun -> do
         vars <- gatherVars efun
-        CallStack cs <- maybe (return $ CallStack []) (fromSomeVarValue (CallStack []) callStackFqVarName) =<< tryLookupVar callStackFqVarName
+        CallStack cs <- maybe (return $ CallStack []) (evalSomeExpr callStackFqVarName) =<< tryLookupVar callStackFqVarName
         let cs' = CallStack (( sline, vars ) : cs)
         FunctionType fun <- withVar callStackVarName cs' $ eval efun
         return $ fun cs' mempty
@@ -218,7 +221,7 @@ eval = \case
     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
@@ -230,6 +233,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
@@ -313,6 +323,7 @@ renameTypeVar a b = go
         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)
@@ -446,14 +457,6 @@ exprArgs = \case
     App {} -> error "exprArgs: app"
     Undefined {} -> error "exprArgs: undefined"
 
-funFromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => FqVarName -> SomeVarValue -> m (FunctionType a)
-funFromSomeVarValue name (SomeVarValue (VarValue _ args value :: VarValue b)) = do
-    maybe (fail err) return $ do
-        FunctionType <$> cast value
-  where
-    err = T.unpack $ T.concat [ T.pack "expected function returning ", textExprType @a Proxy, T.pack ", but variable '", textFqVarName name, T.pack "' has ",
-            (if anull args then "type " else "function type returting ") <> textExprType @b Proxy ]
-
 data SomeArgumentType = forall a. ExprType a => SomeArgumentType (ArgumentType a)
 
 data ArgumentType a
@@ -479,18 +482,10 @@ 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
-            | GlobalVarName {} <- var -> return []
-            | isInternalVar var -> return []
-            | otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var
-        DynVariable _ _ var
-            | GlobalVarName {} <- var -> return []
-            | isInternalVar var -> return []
-            | otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var
-        FunVariable _ _ var
-            | GlobalVarName {} <- var -> return []
-            | isInternalVar var -> return []
-            | otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var
+        e@(Variable _ var) -> gatherLocalVar var e
+        e@(DynVariable _ _ var) -> gatherLocalVar var e
+        e@(FunVariable _ _ var) -> gatherLocalVar var e
+        e@(OptVariable _ var) -> gatherLocalVar var e
         ArgsReq args expr -> withDictionary (filter ((`notElem` map fst (toList args)) . fst)) $ helper expr
         ArgsApp (FunctionArguments args) fun -> do
             v <- helper fun
@@ -518,6 +513,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/Test/Builtins.hs b/src/Test/Builtins.hs
index 3dc6554..4ad6049 100644
--- a/src/Test/Builtins.hs
+++ b/src/Test/Builtins.hs
@@ -3,7 +3,6 @@ module Test.Builtins (
 ) where
 
 import Data.Map qualified as M
-import Data.Maybe
 import Data.Proxy
 import Data.Scientific
 import Data.Text (Text)
@@ -27,47 +26,50 @@ builtins = M.fromList $ concat
   where
     fq name impl = (( ModuleName [ "$" ], VarName name ), impl )
 
-getArg :: ExprType a => FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> a
-getArg args = fromMaybe (error "parameter mismatch") . getArgMb args
+biVar :: ExprType a => Text -> Expr a
+biVar = Variable SourceLineBuiltin . LocalVarName . VarName
 
-getArgMb :: ExprType a => FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> Maybe a
-getArgMb (FunctionArguments args) kw = do
-    fromSomeVarValue (CallStack []) (LocalVarName (VarName "")) =<< M.lookup kw args
+biOpt :: ExprType a => Text -> Expr (Maybe a)
+biOpt = OptVariable SourceLineBuiltin . LocalVarName . VarName
 
-builtinSend :: SomeVarValue
-builtinSend = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $
-    \_ args -> TestBlockStep EmptyTestBlock $ Send (getArg args (Just "to")) (getArg args Nothing)
+biArgs :: [ ( Maybe ArgumentKeyword, a ) ] -> FunctionArguments ( VarName, a )
+biArgs = FunctionArguments . M.fromList . map (\( kw, atype ) -> ( kw, ( VarName $ maybe "$0" (\(ArgumentKeyword tkw) -> "$" <> tkw) kw, atype ) ))
+
+builtinSend :: SomeExpr
+builtinSend = SomeExpr $ ArgsReq (biArgs atypes) $
+    FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (Send <$> biVar "$to" <*> biVar "$0")
   where
     atypes =
         [ ( Just "to", SomeArgumentType (ContextDefault @Process) )
         , ( Nothing, SomeArgumentType (RequiredArgument @Text) )
         ]
 
-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) )
         ]
 
-builtinIgnore :: SomeVarValue
-builtinIgnore = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $
-    \_ args -> TestBlockStep EmptyTestBlock $ CreateObject (Proxy @IgnoreProcessOutput) ( getArg args (Just "from"), getArgMb args (Just "matching") )
+builtinIgnore :: SomeExpr
+builtinIgnore = SomeExpr $ ArgsReq (biArgs atypes) $
+    FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (CreateObject (Proxy @IgnoreProcessOutput) <$> ((,) <$> biVar "$from" <*> biOpt "$matching"))
   where
     atypes =
         [ ( Just "from", SomeArgumentType (ContextDefault @Process) )
         , ( Just "matching", SomeArgumentType (OptionalArgument @Regex) )
         ]
 
-builtinGuard :: SomeVarValue
-builtinGuard = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton Nothing (SomeArgumentType (RequiredArgument @Bool))) $
-    \stack args -> TestBlockStep EmptyTestBlock $ Guard stack (getArg args Nothing)
+builtinGuard :: SomeExpr
+builtinGuard = SomeExpr $
+    ArgsReq (biArgs [ ( Nothing, SomeArgumentType (RequiredArgument @Bool) ) ]) $
+    FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (Guard <$> Variable SourceLineBuiltin callStackFqVarName <*> biVar "$0")
 
-builtinMultiplyTimeout :: SomeVarValue
-builtinMultiplyTimeout = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton (Just "by") (SomeArgumentType (RequiredArgument @Scientific))) $
-    \_ args -> TestBlockStep EmptyTestBlock $ CreateObject (Proxy @MultiplyTimeout) (getArg args (Just "by"))
+builtinMultiplyTimeout :: SomeExpr
+builtinMultiplyTimeout = SomeExpr $ ArgsReq (biArgs $ [ ( Just "by", SomeArgumentType (RequiredArgument @Scientific) ) ]) $
+    FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (CreateObject (Proxy @MultiplyTimeout) <$> biVar "$by")
 
-builtinWait :: SomeVarValue
-builtinWait = someConstValue $ TestBlockStep EmptyTestBlock Wait
+builtinWait :: SomeExpr
+builtinWait = SomeExpr $ Pure $ TestBlockStep EmptyTestBlock Wait