diff options
Diffstat (limited to 'src/Script/Expr.hs')
| -rw-r--r-- | src/Script/Expr.hs | 22 |
1 files changed, 18 insertions, 4 deletions
diff --git a/src/Script/Expr.hs b/src/Script/Expr.hs index 4e99a26..7a446c5 100644 --- a/src/Script/Expr.hs +++ b/src/Script/Expr.hs @@ -146,6 +146,12 @@ instance MonadEval SimpleEval where 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 @@ -166,12 +172,16 @@ eval = \case args <- mapM evalSome eargs return $ FunctionType $ \stack args' -> fun stack (args <> args') FunctionAbstraction expr -> do - val <- eval expr - return $ FunctionType $ const $ const val + gdefs <- askGlobalDefs + dict <- askDictionary + return $ FunctionType $ \stack _ -> + runSimpleEval (eval expr) gdefs (( callStackVarName, someConstValue stack ) : dict) FunctionEval sline efun -> do - FunctionType fun <- eval efun vars <- gatherVars efun - return $ fun (CallStack [ ( sline, vars ) ]) mempty + CallStack cs <- maybe (return $ CallStack []) (fromSomeVarValue (CallStack []) callStackFqVarName) =<< tryLookupVar callStackFqVarName + let cs' = CallStack (( sline, vars ) : cs) + FunctionType fun <- withVar callStackVarName cs' $ eval efun + return $ fun cs' mempty LambdaAbstraction (TypedVarName name) expr -> do gdefs <- askGlobalDefs dict <- askDictionary @@ -374,6 +384,10 @@ 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 where |