From 0a7584ca7b65ad5736a254dd1cb82aad237fe888 Mon Sep 17 00:00:00 2001 From: hellerve Date: Mon, 3 Feb 2020 10:07:58 +0100 Subject: [PATCH 1/2] eval: make fn work in dynamic contexts --- src/Eval.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/Eval.hs b/src/Eval.hs index 6cb6be4f5..5943a4aa6 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -303,6 +303,15 @@ eval env xobj = f:args -> do evaledF <- eval env f case evaledF of + Right (XObj (Lst [XObj (Fn _ _) _ _, XObj (Arr params) _ _, body]) _ _) -> do + case checkMatchingNrOfArgs ctx fppl f params args of + Left err -> return (Left err) + Right () -> + do evaledArgs <- fmap sequence (mapM (eval env) args) + case evaledArgs of + Right okArgs -> apply env body params okArgs + Left err -> return (Left err) + Right (XObj (Lst [XObj Dynamic _ _, _, XObj (Arr params) _ _, body]) _ _) -> case checkMatchingNrOfArgs ctx fppl f params args of Left err -> return (Left err) From 954c9b97867dc73e3c6c097ac0146ee3a80ad3fa Mon Sep 17 00:00:00 2001 From: hellerve Date: Mon, 3 Feb 2020 11:08:00 +0100 Subject: [PATCH 2/2] obj: add env capturing to fn --- src/Concretize.hs | 8 ++++---- src/Emit.hs | 2 +- src/Eval.hs | 8 ++++---- src/GenerateConstraints.hs | 2 +- src/InitialTypes.hs | 8 ++++---- src/Obj.hs | 12 ++++++++++-- src/Parsing.hs | 2 +- src/Qualify.hs | 2 +- 8 files changed, 26 insertions(+), 18 deletions(-) diff --git a/src/Concretize.hs b/src/Concretize.hs index 9571bba04..8078073ae 100644 --- a/src/Concretize.hs +++ b/src/Concretize.hs @@ -83,7 +83,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root = return (Left (DefinitionsMustBeAtToplevel xobj)) -- | Fn / λ - visitList allowAmbig _ env (XObj (Lst [XObj (Fn _ _) fni fnt, args@(XObj (Arr argsArr) ai at), body]) i t) = + visitList allowAmbig _ env (XObj (Lst [XObj (Fn _ _ _) fni fnt, args@(XObj (Arr argsArr) ai at), body]) i t) = -- The basic idea of this function is to first visit the body of the lambda ("in place"), -- then take the resulting body and put into a separate function 'defn' with a new name -- in the global scope. That function definition will be set as the lambdas '.callback' in @@ -158,7 +158,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root = modify (deleterDeps ++) modify (copyFn :) modify (copyDeps ++) - return (Right [XObj (Fn (Just lambdaPath) (Set.fromList capturedVars)) fni fnt, args, okBody]) + return (Right [XObj (Fn (Just lambdaPath) (Set.fromList capturedVars) (FEnv env)) fni fnt, args, okBody]) Left err -> return (Left err) @@ -313,7 +313,7 @@ collectCapturedVars root = removeDuplicates (map toGeneralSymbol (visit root)) visit xobj = case obj xobj of -- don't peek inside lambdas, trust their capture lists: - (Lst [XObj (Fn _ captures) _ _, _, _]) -> Set.toList captures + (Lst [XObj (Fn _ captures _ ) _ _, _, _]) -> Set.toList captures (Lst _) -> visitList xobj (Arr _) -> visitArray xobj (Sym path (LookupLocal Capture)) -> [xobj] @@ -682,7 +682,7 @@ manageMemory typeEnv globalEnv root = return (XObj (Lst [defn, nameSymbol, args, okBody]) i t) -- Fn / λ - [fn@(XObj (Fn _ captures) _ _), args@(XObj (Arr argList) _ _), body] -> + [fn@(XObj (Fn _ captures _) _ _), args@(XObj (Arr argList) _ _), body] -> let Just funcTy@(FuncTy _ fnReturnType) = t in do manage xobj -- manage inner lambdas but leave their bodies unvisited, they will be visited in the lifted version... mapM_ unmanage captures diff --git a/src/Emit.hs b/src/Emit.hs index 50104b154..0ccfc9b8b 100644 --- a/src/Emit.hs +++ b/src/Emit.hs @@ -200,7 +200,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo return "" -- Fn / λ - [XObj (Fn name set) _ _, XObj (Arr argList) _ _, body] -> + [XObj (Fn name set _) _ _, XObj (Arr argList) _ _, body] -> do let retVar = freshVar i capturedVars = Set.toList set Just callback = name diff --git a/src/Eval.hs b/src/Eval.hs index 5943a4aa6..a4b017536 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -147,9 +147,9 @@ eval env xobj = _ -> return (makeEvalError ctx Nothing ("`if` condition contains non-boolean value: " ++ pretty okCondition) (info okCondition)) Left err -> return (Left err) - [XObj (Fn _ _) _ _, args@(XObj (Arr a) _ _), _] -> + [XObj (Fn b c _) d e, args@(XObj (Arr a) _ _), f] -> if all isUnqualifiedSym a - then return (Right listXObj) + then return (Right (XObj (Lst [XObj (Fn b c (FEnv env)) d e, args, f]) i t)) else return (makeEvalError ctx Nothing ("`fn` requires all arguments to be unqualified symbols, but it got `" ++ pretty args ++ "`") (info xobj)) [defnExpr@(XObj Defn _ _), name, args@(XObj (Arr a) _ _), body] -> @@ -303,13 +303,13 @@ eval env xobj = f:args -> do evaledF <- eval env f case evaledF of - Right (XObj (Lst [XObj (Fn _ _) _ _, XObj (Arr params) _ _, body]) _ _) -> do + Right (XObj (Lst [XObj (Fn _ _ (FEnv e)) _ _, XObj (Arr params) _ _, body]) _ _) -> do case checkMatchingNrOfArgs ctx fppl f params args of Left err -> return (Left err) Right () -> do evaledArgs <- fmap sequence (mapM (eval env) args) case evaledArgs of - Right okArgs -> apply env body params okArgs + Right okArgs -> apply e body params okArgs Left err -> return (Left err) Right (XObj (Lst [XObj Dynamic _ _, _, XObj (Arr params) _ _, body]) _ _) -> diff --git a/src/GenerateConstraints.hs b/src/GenerateConstraints.hs index dbadd0144..f94f4ea29 100644 --- a/src/GenerateConstraints.hs +++ b/src/GenerateConstraints.hs @@ -32,7 +32,7 @@ genConstraints typeEnv root = fmap sort (gen root) genF xobj args body -- Fn - [XObj (Fn _ _) _ _, XObj (Arr args) _ _, body] -> + [XObj (Fn _ _ _) _ _, XObj (Arr args) _ _, body] -> genF xobj args body -- Def diff --git a/src/InitialTypes.hs b/src/InitialTypes.hs index 8e1f858e0..13980cdf5 100644 --- a/src/InitialTypes.hs +++ b/src/InitialTypes.hs @@ -79,7 +79,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0 (InterfaceSym _) -> visitInterfaceSym env xobj Defn -> return (Left (InvalidObj Defn xobj)) Def -> return (Left (InvalidObj Def xobj)) - e@(Fn _ _) -> return (Left (InvalidObj e xobj)) + e@(Fn _ _ _) -> return (Left (InvalidObj e xobj)) Let -> return (Left (InvalidObj Let xobj)) If -> return (Left (InvalidObj If xobj)) While -> return (Left (InvalidObj While xobj)) @@ -178,7 +178,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0 XObj Defn _ _ : _ -> return (Left (InvalidObj Defn xobj)) -- Fn - [fn@(XObj (Fn _ _) _ _), XObj (Arr argList) argsi argst, body] -> + [fn@(XObj (Fn _ _ _) _ _), XObj (Arr argList) argsi argst, body] -> do (argTypes, returnType, funcScopeEnv) <- getTys env argList let funcTy = Just (FuncTy argTypes returnType) visitedBody <- visit funcScopeEnv body @@ -188,8 +188,8 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0 let final = XObj (Lst [fn, XObj (Arr okArgs) argsi argst, okBody]) i funcTy return final --(trace ("FINAL: " ++ show final) final) - [XObj (Fn _ _) _ _, XObj (Arr _) _ _] -> return (Left (NoFormsInBody xobj)) -- TODO: Special error message for lambdas needed? - XObj fn@(Fn _ _) _ _ : _ -> return (Left (InvalidObj fn xobj)) + [XObj (Fn _ _ _ ) _ _, XObj (Arr _) _ _] -> return (Left (NoFormsInBody xobj)) -- TODO: Special error message for lambdas needed? + XObj fn@(Fn _ _ _) _ _ : _ -> return (Left (InvalidObj fn xobj)) -- Def [def@(XObj Def _ _), nameSymbol, expression]-> diff --git a/src/Obj.hs b/src/Obj.hs index 12ffa02bc..3a41d7471 100644 --- a/src/Obj.hs +++ b/src/Obj.hs @@ -57,7 +57,7 @@ data Obj = Sym SymPath SymbolMode | Dict (Map.Map XObj XObj) | Defn | Def - | Fn (Maybe SymPath) (Set.Set XObj) -- the name of the lifted function, and the set of variables this lambda captures + | Fn (Maybe SymPath) (Set.Set XObj) FnEnv -- the name of the lifted function, the set of variables this lambda captures, and a dynamic environment | Do | Let | While @@ -270,7 +270,7 @@ pretty = visit 0 Bol b -> if b then "true" else "false" Defn -> "defn" Def -> "def" - Fn _ captures -> "fn" ++ " <" ++ joinWithComma (map getName (Set.toList captures)) ++ ">" + Fn _ captures _ -> "fn" ++ " <" ++ joinWithComma (map getName (Set.toList captures)) ++ ">" If -> "if" Match -> "match" While -> "while" @@ -438,6 +438,14 @@ data Env = Env { envBindings :: Map.Map String Binder , envFunctionNestingLevel :: Int -- Normal defn:s have 0, lambdas get +1 for each level of nesting } deriving (Show, Eq) +-- Could be (Maybe Env), but we have to get rid of equality +data FnEnv = None + | FEnv Env + deriving (Show) + +instance Eq FnEnv where + _ == _ = True + newtype TypeEnv = TypeEnv { getTypeEnv :: Env } instance Show TypeEnv where diff --git a/src/Parsing.hs b/src/Parsing.hs index 0268bac6d..45d125ec8 100644 --- a/src/Parsing.hs +++ b/src/Parsing.hs @@ -228,7 +228,7 @@ symbol = do i <- createInfo -- TODO: What about the other def- forms? "do" -> return (XObj Do i Nothing) "while" -> return (XObj While i Nothing) - "fn" -> return (XObj (Fn Nothing Set.empty) i Nothing) + "fn" -> return (XObj (Fn Nothing Set.empty None) i Nothing) "let" -> return (XObj Let i Nothing) "break" -> return (XObj Break i Nothing) "if" -> return (XObj If i Nothing) diff --git a/src/Qualify.hs b/src/Qualify.hs index a4148f0bf..856851264 100644 --- a/src/Qualify.hs +++ b/src/Qualify.hs @@ -37,7 +37,7 @@ setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Lst [defn@(XObj Defn _ _), functionEnv = Env Map.empty (Just envWithSelf) Nothing [] InternalEnv 0 envWithArgs = foldl' (\e arg@(XObj (Sym (SymPath _ argSymName) _) _ _) -> extendEnv e argSymName arg) functionEnv argsArr in XObj (Lst [defn, sym, args, setFullyQualifiedSymbols typeEnv globalEnv envWithArgs body]) i t -setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Lst [fn@(XObj (Fn _ _) _ _), +setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Lst [fn@(XObj (Fn _ _ _) _ _), args@(XObj (Arr argsArr) _ _), body]) i t) =