From f40e7cd636fcc49dfa7e99c0e902f29f868d1654 Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Tue, 15 Feb 2022 20:55:30 -0500 Subject: [PATCH 1/8] refactor: add resolvers to control lookup order Adds a new abstraction, the *Resolver* which controls the lookup order when resolving symbols. Env, provides mechanisms for storing and retrieving bindings, Context bundles environments together (and provides some retrieval utilities) and Resolver determines the order in which multiple lookups should be executed. The Resolver abstractions allows us to remove much of the gnarly lookup code that was previously directly defined in the evaluator. The abstraction also provides a Semigroup instance for the flexible combination of resolvers, making it significantly easier to try out different orders in the evaluator. This commit changes no behavior -- it just uses Resolvers to emulate the previous lookup order in the evaluator. Future commits will leverage the abstraction to simplify lookups and refine behaviors where needed. --- CarpHask.cabal | 1 + src/Eval.hs | 231 +++++++++++++------------------- src/Resolver.hs | 345 ++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 439 insertions(+), 138 deletions(-) create mode 100644 src/Resolver.hs diff --git a/CarpHask.cabal b/CarpHask.cabal index d2fd72e11..63d779061 100644 --- a/CarpHask.cabal +++ b/CarpHask.cabal @@ -51,6 +51,7 @@ library Reify, RenderDocs, Repl, + Resolver, Set, Scoring, StartingEnv, diff --git a/src/Eval.hs b/src/Eval.hs index ac6988fd4..2a90e7bf7 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -8,6 +8,7 @@ import Context import Control.Applicative import Control.Exception import Control.Monad.State +import Data.Bifunctor(second) import Data.Either (fromRight) import Data.Foldable (foldlM, foldrM) import Data.List (foldl', isSuffixOf) @@ -36,28 +37,17 @@ import TypeError import Types import Util import Prelude hiding (exp, mod) - --- TODO: Formalize "lookup order preference" a bit better and move into --- the Context module. -data LookupPreference - = PreferDynamic - | PreferGlobal - | PreferLocal [SymPath] - deriving (Show) - -data Resolver - = ResolveGlobal - | ResolveLocal +import Resolver type Evaluator = [XObj] -> IO (Context, Either EvalError XObj) --- Prefer dynamic bindings -evalDynamic :: Resolver -> Context -> XObj -> IO (Context, Either EvalError XObj) -evalDynamic resolver ctx xobj = eval ctx xobj PreferDynamic resolver +-- Prefer dynamic bindings and use the standard resolution order when evaluating symbols. +evalDynamic :: Context -> XObj -> IO (Context, Either EvalError XObj) +evalDynamic ctx xobj = eval ctx xobj ResolveStatic legacyPreferDynamic --- Prefer global bindings -evalStatic :: Resolver -> Context -> XObj -> IO (Context, Either EvalError XObj) -evalStatic resolver ctx xobj = eval ctx xobj PreferGlobal resolver +-- Prefer global bindings when evaluating symbols. +evalStatic :: Context -> XObj -> IO (Context, Either EvalError XObj) +evalStatic ctx xobj = eval ctx xobj ResolveDynamic legacyPreferGlobal -- | Dynamic (REPL) evaluation of XObj:s (s-expressions) -- Note: You might find a bunch of code of the following form both here and in @@ -73,17 +63,29 @@ evalStatic resolver ctx xobj = eval ctx xobj PreferGlobal resolver -- it gets real weird with laziness. (Note to the note: this code is mostly a -- remnant of us using StateT, and might not be necessary anymore since we -- switched to more explicit state-passing.) -eval :: Context -> XObj -> LookupPreference -> Resolver -> IO (Context, Either EvalError XObj) -eval ctx xobj@(XObj o info ty) preference resolver = +eval :: Context -> XObj -> ResolveMode -> Resolver -> IO (Context, Either EvalError XObj) +eval ctx xobj@(XObj o info ty) mode resolver = case o of Lst body -> eval' body - Sym spath@(SymPath p n) _ -> + Sym spath _ -> pure $ - case resolver of - ResolveGlobal -> unwrapLookup ((tryAllLookups preference) >>= checkStatic) - ResolveLocal -> unwrapLookup (tryAllLookups preference) + case mode of + ResolveDynamic -> + unwrapLookup $ + (applyResolver resolver spath ctx + >>= getXObj + >>= pure . second (second resolveDef) + >>= checkStatic) + ResolveStatic -> + unwrapLookup $ + (applyResolver resolver spath ctx + >>= getXObj + >>= pure . second (second resolveDef)) where - checkStatic v@(_, Right (XObj (Lst ((XObj obj _ _) : _)) _ _)) = + getXObj :: (Context, Binder) -> Maybe (Context, Either EvalError XObj) + getXObj = pure . (second (pure . binderXObj)) + checkStatic :: (Context, Either EvalError XObj) -> Maybe (Context, Either EvalError XObj) + checkStatic v@(_, (Right (XObj (Lst ((XObj obj _ _) : _)) _ _))) = if isResolvableStaticObj obj then pure (ctx, Left (HasStaticCall xobj info)) else pure v @@ -92,73 +94,12 @@ eval ctx xobj@(XObj o info ty) preference resolver = unwrapLookup = fromMaybe (throwErr (SymbolNotFound spath) ctx info) - -- Try all lookups performs lookups for symbols based on a given - -- lookup preference. - tryAllLookups :: LookupPreference -> Maybe (Context, Either EvalError XObj) - tryAllLookups PreferDynamic = (getDynamic) <|> fullLookup - tryAllLookups PreferGlobal = (getGlobal spath) <|> fullLookup - tryAllLookups (PreferLocal shadows) = (if spath `elem` shadows then (getLocal n) else (getDynamic)) <|> fullLookup - fullLookup = (tryDynamicLookup <|> (if null p then tryInternalLookup spath <|> tryLookup spath else tryLookup spath)) - getDynamic :: Maybe (Context, Either EvalError XObj) - getDynamic = - do - (Binder _ found) <- maybeId (E.findValueBinder (contextGlobalEnv ctx) (SymPath ("Dynamic" : p) n)) - pure (ctx, Right (resolveDef found)) - getGlobal :: SymPath -> Maybe (Context, Either EvalError XObj) - getGlobal path = - do - (Binder meta found) <- maybeId (E.findValueBinder (contextGlobalEnv ctx) path) - checkPrivate meta found - tryDynamicLookup :: Maybe (Context, Either EvalError XObj) - tryDynamicLookup = - do - (Binder meta found) <- maybeId (E.searchValueBinder (contextGlobalEnv ctx) (SymPath ("Dynamic" : p) n)) - checkPrivate meta found - getLocal :: String -> Maybe (Context, Either EvalError XObj) - getLocal name = - do - internal <- contextInternalEnv ctx - (Binder _ found) <- maybeId (E.getValueBinder internal name) - pure (ctx, Right (resolveDef found)) - -- TODO: Deprecate this function? - -- The behavior here is a bit nefarious since it relies on cached - -- environment parents (it calls `search` on the "internal" binder). - -- But for now, it seems to be needed for some cases. - tryInternalLookup :: SymPath -> Maybe (Context, Either EvalError XObj) - tryInternalLookup path = - --trace ("Looking for internally " ++ show path) -- ++ show (fmap (fmap E.binders . E.parent) (contextInternalEnv ctx))) - ( contextInternalEnv ctx - >>= \e -> - maybeId (E.searchValueBinder e path) - >>= \(Binder meta found) -> checkPrivate meta found - ) - tryLookup :: SymPath -> Maybe (Context, Either EvalError XObj) - tryLookup path = - ( maybeId (E.searchValueBinder (contextGlobalEnv ctx) path) - >>= \(Binder meta found) -> checkPrivate meta found - ) - <|> ( (maybeId (E.searchValueBinder (contextGlobalEnv ctx) (SymPath ((contextPath ctx) ++ p) n))) - >>= \(Binder meta found) -> checkPrivate meta found - ) - <|> ( maybeId (lookupBinderInTypeEnv ctx path) - >>= \(Binder _ found) -> pure (ctx, Right (resolveDef found)) - ) - <|> ( foldl - (<|>) - Nothing - ( map - ( \(SymPath p' n') -> - maybeId (E.searchValueBinder (contextGlobalEnv ctx) (SymPath (p' ++ (n' : p)) n)) - >>= \(Binder meta found) -> checkPrivate meta found - ) - (Set.toList (envUseModules (contextGlobalEnv ctx))) - ) - ) - checkPrivate meta found = - pure $ - if metaIsTrue meta "private" - then throwErr (PrivateBinding (getPath found)) ctx info - else (ctx, Right (resolveDef found)) + -- TODO: Reintegrate this check -- in resolve? + --checkPrivate meta found = + -- pure $ + -- if metaIsTrue meta "private" + -- then throwErr (PrivateBinding (getPath found)) ctx info + -- else (ctx, Right (resolveDef found)) Arr objs -> do (newCtx, evaled) <- foldlM successiveEval (ctx, Right []) objs pure @@ -219,17 +160,18 @@ eval ctx xobj@(XObj o info ty) preference resolver = -- break our normal loop. (AppPat self@(ListPat (x@(SymPat _ _) : _)) args) -> do - (_, evald) <- eval ctx x preference ResolveGlobal + (_, evald) <- eval ctx x ResolveDynamic resolver case evald of Left err -> pure (evalError ctx (show err) (xobjInfo xobj)) Right x' -> case checkStatic' x' of + --_ -> evaluateApp (self : args) Right _ -> evaluateApp (self : args) Left er -> pure (ctx, Left er) (AppPat (ListPat _) _) -> evaluateApp form' (AppPat (SymPat _ _) _) -> evaluateApp form' (AppPat (XObj other _ _) _) | isResolvableStaticObj other -> - pure (ctx, (Left (HasStaticCall xobj info))) + pure (ctx, (Left (HasStaticCall xobj info))) [] -> pure (ctx, dynamicNil) _ -> pure (throwErr (UnknownForm xobj) ctx (xobjInfo xobj)) checkStatic' (XObj Def _ _) = Left (HasStaticCall xobj info) @@ -245,24 +187,24 @@ eval ctx xobj@(XObj o info ty) preference resolver = case acc of Left _ -> pure (ctx', acc) Right l -> do - (newCtx, evald) <- eval ctx' x preference resolver + (newCtx, evald) <- eval ctx' x mode resolver pure $ case evald of Right res -> (newCtx, Right (l ++ [res])) Left err -> (newCtx, Left err) evaluateIf :: Evaluator evaluateIf (IfPat _ cond true false) = do - (newCtx, evd) <- eval ctx cond preference ResolveLocal + (newCtx, evd) <- eval ctx cond ResolveStatic resolver case evd of Right cond' -> case xobjObj cond' of - Bol b -> eval newCtx (if b then true else false) preference ResolveLocal + Bol b -> eval newCtx (if b then true else false) ResolveStatic resolver _ -> pure (throwErr (IfContainsNonBool cond) ctx (xobjInfo cond)) Left e -> pure (newCtx, Left e) evaluateIf _ = pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj)) evaluateThe :: Evaluator evaluateThe (ThePat the t value) = do - (newCtx, evaledValue) <- expandAll (evalDynamic ResolveLocal) ctx value -- TODO: Why expand all here? + (newCtx, evaledValue) <- expandAll evalDynamic ctx value -- TODO: Why expand all here? pure ( newCtx, do @@ -271,22 +213,25 @@ eval ctx xobj@(XObj o info ty) preference resolver = ) evaluateThe _ = pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj)) evaluateLet :: Evaluator - evaluateLet (LetPat _ (ArrPat bindings) body) = do - let binds = unwrapVar (pairwise bindings) [] - ni = Env Map.empty (contextInternalEnv ctx) Nothing Set.empty InternalEnv 0 - eitherCtx <- foldrM successiveEval' (Right (replaceInternalEnv ctx ni)) binds - case eitherCtx of - Left err -> pure (ctx, Left err) - Right newCtx -> do - (finalCtx, evaledBody) <- eval newCtx body (PreferLocal (map (\(name, _) -> (SymPath [] name)) binds)) ResolveLocal - let Just e = contextInternalEnv finalCtx - parentEnv = envParent e - pure - ( replaceInternalEnvMaybe finalCtx parentEnv, - do - okBody <- evaledBody - Right okBody - ) + evaluateLet (LetPat _ (ArrPat bindings) body) = + do + let binds = unwrapVar (pairwise bindings) [] + ni = Env Map.empty (contextInternalEnv ctx) Nothing Set.empty InternalEnv 0 + eitherCtx <- foldrM successiveEval' (Right (replaceInternalEnv ctx ni)) binds + case eitherCtx of + Left err -> pure (ctx, Left err) + Right newCtx -> do + let shadowResolver = + (legacyLocal (map (\(name, _) -> (SymPath [] name)) binds)) + (finalCtx, evaledBody) <- eval newCtx body ResolveStatic shadowResolver + let Just e = contextInternalEnv finalCtx + parentEnv = envParent e + pure + ( replaceInternalEnvMaybe finalCtx parentEnv, + do + okBody <- evaledBody + Right okBody + ) where unwrapVar [] acc = acc unwrapVar ((XObj (Sym (SymPath [] x) _) _ _, y) : xs) acc = unwrapVar xs ((x, y) : acc) @@ -303,7 +248,7 @@ eval ctx xobj@(XObj o info ty) preference resolver = recFix = (E.recursive origin (Just "let-rec-env") 0) Right envWithSelf = if isFn x then E.insertX recFix (SymPath [] n) x else Right recFix ctx'' = replaceInternalEnv ctx' envWithSelf - (newCtx, res) <- eval ctx'' x preference resolver + (newCtx, res) <- eval ctx'' x mode resolver case res of Right okX -> pure $ Right (fromRight (error "Failed to eval let binding!!") (bindLetDeclaration (newCtx {contextInternalEnv = origin}) n okX)) @@ -391,16 +336,16 @@ eval ctx xobj@(XObj o info ty) preference resolver = evaluateApp :: Evaluator evaluateApp (AppPat f' args) = case f' of - l@(ListPat _) -> go l ResolveLocal - sym@(SymPat _ _) -> go sym resolver + l@(ListPat _) -> go l ResolveStatic + sym@(SymPat _ _) -> go sym mode _ -> pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj)) where - go x resolve = + go x mode' = do - (newCtx, f) <- eval ctx x preference resolve + (newCtx, f) <- eval ctx x mode' resolver case f of Right fun -> do - (newCtx', res) <- eval (pushFrame newCtx xobj) (XObj (Lst (fun : args)) (xobjInfo x) (xobjTy x)) preference ResolveLocal + (newCtx', res) <- eval (pushFrame newCtx xobj) (XObj (Lst (fun : args)) (xobjInfo x) (xobjTy x)) ResolveStatic resolver pure (popFrame newCtx', res) x' -> pure (newCtx, x') evaluateApp _ = pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj)) @@ -411,7 +356,7 @@ eval ctx xobj@(XObj o info ty) preference resolver = successiveEval' (ctx', acc) x = case acc of err@(Left _) -> pure (ctx', err) - Right _ -> eval ctx' x preference resolver + Right _ -> eval ctx' x mode resolver macroExpand :: Context -> XObj -> IO (Context, Either EvalError XObj) macroExpand ctx xobj = @@ -436,12 +381,13 @@ macroExpand ctx xobj = pure (ctx, Right xobj) XObj (Lst [XObj (Sym (SymPath [] "quote") _) _ _, _]) _ _ -> pure (ctx, Right xobj) - XObj (Lst [XObj (Lst (XObj Macro _ _ : _)) _ _]) _ _ -> evalDynamic ResolveLocal ctx xobj + XObj (Lst [XObj (Lst (XObj Macro _ _ : _)) _ _]) _ _ -> + evalDynamic ctx xobj XObj (Lst (x@(XObj (Sym _ _) _ _) : args)) i t -> do - (_, f) <- evalDynamic ResolveLocal ctx x + (_, f) <- evalDynamic ctx x case f of Right m@(XObj (Lst (XObj Macro _ _ : _)) _ _) -> do - (newCtx', res) <- evalDynamic ResolveLocal ctx (XObj (Lst (m : args)) i t) + (newCtx', res) <- evalDynamic ctx (XObj (Lst (m : args)) i t) pure (newCtx', res) _ -> do (newCtx, expanded) <- foldlM successiveExpand (ctx, Right []) args @@ -499,7 +445,9 @@ apply ctx@Context {contextInternalEnv = internal} body params args = (XObj (Lst (drop n args)) Nothing Nothing) ) binds = if null rest then proper else proper ++ [(head rest)] - (c, r) <- (eval (replaceInternalEnv ctx insideEnv'') body (PreferLocal (map (\x -> (SymPath [] x)) binds)) ResolveLocal) + let shadowResolver = + legacyLocal (map (\x -> (SymPath [] x)) binds) + (c, r) <- (eval (replaceInternalEnv ctx insideEnv'') body ResolveStatic shadowResolver) pure (c {contextInternalEnv = internal}, r) -- | Parses a string and then converts the resulting forms to commands, which are evaluated in order. @@ -560,7 +508,14 @@ executeCommand ctx@(Context env _ _ _ _ _ _ _) xobj = error ("Global env module name is " ++ fromJust (envModuleName env) ++ " (should be Nothing).") -- The s-expression command is a special case that prefers global/static bindings over dynamic bindings -- when given a naked binding (no path) as an argument; (s-expr inc) - (newCtx, result) <- if xobjIsSexp xobj then evalStatic ResolveGlobal ctx xobj else evalDynamic ResolveGlobal ctx xobj + -- NOTE! The "ResolveDynamic" override call to eval PreferDynamic (which is + -- otherwise just evalDynamic) is somehow crucial. Without it, function + -- names in modules are fully expanded to thier full names, breaking defns. + -- This is because of the calls to "isResolvableStaticXObj" in eval' on list + -- patterns -- this alters the behavior of succssiveEval such that it drops + -- certain results? I think? It's a hunch. This behavior is incredibly + -- mysterious. + (newCtx, result) <- if xobjIsSexp xobj then evalStatic ctx xobj else eval ctx xobj ResolveDynamic legacyPreferDynamic case result of Left e@EvalError {} -> do reportExecutionError newCtx (show e) @@ -654,14 +609,14 @@ specialCommandDefine ctx xobj = specialCommandWhile :: Context -> XObj -> XObj -> IO (Context, Either EvalError XObj) specialCommandWhile ctx cond body = do - (newCtx, evd) <- evalDynamic ResolveLocal ctx cond + (newCtx, evd) <- evalDynamic ctx cond case evd of Right c -> case xobjObj c of Bol b -> if b then do - (newCtx', _) <- evalDynamic ResolveLocal newCtx body + (newCtx', _) <- evalDynamic newCtx body specialCommandWhile newCtx' cond body else pure (newCtx, dynamicNil) _ -> @@ -698,7 +653,7 @@ annotateWithinContext ctx xobj = do case sig of Left err -> pure (ctx, Left err) Right okSig -> do - (_, expansionResult) <- expandAll (evalDynamic ResolveLocal) ctx xobj + (_, expansionResult) <- expandAll evalDynamic ctx xobj case expansionResult of Left err -> pure (ctx, Left err) Right expanded -> @@ -764,7 +719,7 @@ primitiveDefmodule xobj ctx@(Context env i tenv pathStrings _ _ _ _) (XObj (Sym macroExpand ctx' expressions >>= \(ctx'', res) -> case res of Left err -> pure (ctx'', Left err) - Right r -> evalDynamic ResolveLocal ctx'' r + Right r -> evalDynamic ctx'' r primitiveDefmodule _ ctx (x : _) = pure (throwErr (DefmoduleContainsNonSymbol x) ctx (xobjInfo x)) primitiveDefmodule xobj ctx [] = @@ -974,7 +929,7 @@ commandExpand = macroExpand -- | i.e. (Int.+ 2 3) => "_0 = 2 + 3" commandC :: UnaryCommandCallback commandC ctx xobj = do - (newCtx, result) <- expandAll (evalDynamic ResolveLocal) ctx xobj + (newCtx, result) <- expandAll evalDynamic ctx xobj case result of Left err -> pure (newCtx, Left err) Right expanded -> do @@ -992,7 +947,7 @@ commandC ctx xobj = do -- | This function will return the compiled AST. commandExpandCompiled :: UnaryCommandCallback commandExpandCompiled ctx xobj = do - (newCtx, result) <- expandAll (evalDynamic ResolveLocal) ctx xobj + (newCtx, result) <- expandAll evalDynamic ctx xobj case result of Left err -> pure (newCtx, Left err) Right expanded -> do @@ -1054,7 +1009,7 @@ buildMainFunction xobj = primitiveDefdynamic :: BinaryPrimitiveCallback primitiveDefdynamic _ ctx (XObj (Sym (SymPath [] name) _) _ _) value = do - (newCtx, result) <- evalDynamic ResolveLocal ctx value + (newCtx, result) <- evalDynamic ctx value case result of Left err -> pure (newCtx, Left err) Right evaledBody -> @@ -1087,7 +1042,7 @@ specialCommandSet ctx [orig@(XObj (Sym path@(SymPath _ _) _) _ _), val] = Just DynamicTy -> handleUnTyped Nothing -> handleUnTyped _ -> - evalDynamic ResolveLocal ctx val + evalDynamic ctx val >>= \(newCtx, result) -> case result of Right evald -> typeCheckValueAgainstBinder newCtx evald binder >>= \(nctx, typedVal) -> setter nctx env typedVal binder @@ -1095,7 +1050,7 @@ specialCommandSet ctx [orig@(XObj (Sym path@(SymPath _ _) _) _ _), val] = where handleUnTyped :: IO (Context, Either EvalError XObj) handleUnTyped = - evalDynamic ResolveLocal ctx val + evalDynamic ctx val >>= \(newCtx, result) -> setter newCtx env result binder setGlobal :: Context -> Env -> Either EvalError XObj -> Binder -> IO (Context, Either EvalError XObj) setGlobal ctx' env value binder = @@ -1149,8 +1104,8 @@ setStaticOrDynamicVar path@(SymPath _ name) env binder value = primitiveEval :: UnaryPrimitiveCallback primitiveEval _ ctx val = do - -- primitives don’t evaluate their arguments, so this needs to double-evaluate - (newCtx, arg) <- evalDynamic ResolveLocal ctx val + --primitives don’t evaluate their arguments, so this needs to double-evaluate + (newCtx, arg) <- evalDynamic ctx val case arg of Left err -> pure (newCtx, Left err) Right evald -> do @@ -1158,7 +1113,7 @@ primitiveEval _ ctx val = do case expanded of Left err -> pure (newCtx', Left err) Right ok -> do - (finalCtx, res) <- evalDynamic ResolveLocal newCtx' ok + (finalCtx, res) <- evalDynamic newCtx' ok pure $ case res of Left (HasStaticCall x i) -> throwErr (StaticCall x) ctx i _ -> (finalCtx, res) diff --git a/src/Resolver.hs b/src/Resolver.hs new file mode 100644 index 000000000..139f89850 --- /dev/null +++ b/src/Resolver.hs @@ -0,0 +1,345 @@ +{-# LANGUAGE TupleSections #-} + +-- | The Env and Context modules provide mechanisms for finding symbols. +-- Resolvers specify the *order in which* such lookups should be performed, and +-- how lookups should be chained in the case of failure. +-- +-- Resolvers are combined using their Semigroup instance, for example: +-- +-- topLevelResolver <> localDynamicResolver +-- +-- produces a resolver that first attempts to find a symbol at the +-- global top level, then attempts to find the symbol (by name only) in the +-- Dynamic module. +-- +-- Resolvers have default orders. In the case above, the localDynamicResolver is +-- of lower order than topLevelResolver, so it will be tried only if +-- topLevelResolver fails to resolve the symbol. +-- +-- One can always tweak the order by setting the order of a resolver explicitly: +-- +-- topLevelResolver {order = Lower } <> localDynamicResolver {order = Higher} +-- +-- will result in a resolver that first applies the localDynamicResolver, then, +-- if it fails will apply the topLevelResolver. The semigroup instance combines +-- resolvers left to right unless the order of the right argument is higher than +-- the left. In the case of equivalent orders, the left will be applied first: +-- +-- resolver(higher) <> resolver'(lower) => resolver followed by resolver' +-- resolver(lower) <> resolver'(lower) => resolver followed by resolver' +-- resolver(higher) <> resolver'(higher) => resolver followed by resolver' +-- resolver(lower) <> resolver'(higher) => resolver' followed by resolver +-- +-- If you need to debug resolvers, thier show instance prints a string depicting +-- the order in which they were run, e.g.: +-- +-- TopLevelReolver -> "LocalDynamicResolver" +module Resolver where + +import Obj +import SymPath +import qualified Set as Set +import qualified Env as E +import Control.Applicative +import Control.Monad +import Data.List(intercalate) +import Util +import Context + +-------------------------------------------------------------------------------- +-- Data + +data LookupPreference + = PreferDynamic + | PreferGlobal + | PreferLocal [SymPath] + deriving (Eq, Show) + +data LookupOrder = Higher | Lower + deriving(Eq) + +instance Ord LookupOrder where + compare Higher Lower = GT + compare Lower Higher = LT + compare Lower Lower = EQ + compare Higher Higher = EQ + +instance Ord LookupPreference where + _ <= PreferDynamic = False + PreferDynamic <= _ = True + (PreferLocal _) <= _ = False + _ <= (PreferLocal _) = True + _ <= _ = True + +data ResolveMode + = ResolveStatic + | ResolveDynamic + +-- | Specifies how a symbol should be resolved in a given context. +data Resolver = Resolver { + resolverName :: String, + order :: LookupOrder, + resolve :: SymPath -> Context -> Maybe (Context, Binder), + resolverStack :: [String] +} + +data LookupConstraint + = Direct + | Children + | Full + +instance Semigroup Resolver where + resolver <> resolver' = + if (order resolver) >= (order resolver') + then resolver { + resolve = \s c -> (resolve resolver) s c <|> (resolve resolver') s c, + resolverStack = (resolverStack resolver) ++ (resolverStack resolver') + } + else resolver { + resolve = \s c -> (resolve resolver') s c <|> (resolve resolver) s c, + resolverStack = (resolverStack resolver') ++ (resolverStack resolver) + } + +instance Show Resolver where + show Resolver{resolverStack = s} = intercalate "-> " s + +-- TODO: Make (E.search.*Binder contextGlobalEnv) impossible. +mkDynamicResolver :: LookupConstraint -> Resolver +mkDynamicResolver Direct = + let r (SymPath _ n) ctx = fmap (ctx,) (maybeId (E.getValueBinder (contextGlobalEnv ctx) n)) + rname = "LocalDynamicResolver" + in Resolver rname Lower r [rname] +mkDynamicResolver Children = + let r (SymPath p n) ctx = + fmap (ctx,) (maybeId (E.findValueBinder (contextGlobalEnv ctx) (SymPath ("Dynamic" : p) n))) + rname = "GlobalDynamicResolver" + in Resolver rname Lower r [rname] +mkDynamicResolver Full = + let r (SymPath p n) ctx = + fmap (ctx,) (maybeId (E.searchValueBinder (contextGlobalEnv ctx) (SymPath ("Dynamic" : p) n))) + rname = "DynamicResolverFull" + in Resolver rname Lower r [rname] + + +mkLocalResolver :: LookupConstraint -> Resolver +mkLocalResolver Direct = + let r (SymPath _ n) ctx = + join $ fmap (\e -> fmap (ctx,) (maybeId (E.getValueBinder e n))) (contextInternalEnv ctx) + rname = "LocalDirectResolver" + in Resolver rname Higher r [rname] +mkLocalResolver Children = + let r path ctx = + join $ fmap (\e -> fmap (ctx,) (maybeId (E.findValueBinder e path))) (contextInternalEnv ctx) + rname = "LocalChildrenResolver" + in Resolver rname Higher r [rname] +mkLocalResolver Full = + let r path ctx = + join $ fmap (\e -> fmap (ctx,) (maybeId (E.searchValueBinder e path))) (contextInternalEnv ctx) + rname = "LocalFullResolver" + in Resolver rname Higher r [rname] + +mkGlobalResolver :: LookupConstraint -> Resolver +mkGlobalResolver Direct = + let r (SymPath _ n) ctx = + fmap (ctx,) (maybeId (E.getValueBinder (contextGlobalEnv ctx) n)) + rname = "GlobalDirectResolver" + in Resolver rname Lower r [rname] +mkGlobalResolver Children = + let r path ctx = + fmap (ctx,) (maybeId (E.findValueBinder (contextGlobalEnv ctx) path)) + rname = "GlobalChildrenResolver" + in Resolver rname Lower r [rname] +mkGlobalResolver Full = + let r path ctx = + fmap (ctx,) (maybeId (E.searchValueBinder (contextGlobalEnv ctx) path)) + rname = "GlobalFullResolver" + in Resolver rname Lower r [rname] + +-------------------------------------------------------------------------------- +-- Public functions + +-- | Resolves a symbol to a local binding that is stored directly in the +-- context's internal environment. +localDynamicResolver :: Resolver +localDynamicResolver = mkDynamicResolver Direct + +-- | Resolves a symbol to a binding in the global Dynamic module. +globalDynamicResolver :: Resolver +globalDynamicResolver = mkDynamicResolver Children + +-- | Resolves a symbol to a binding in the local environment if that symbol is +-- known to shadow another symbol. +localShadowResolver :: [SymPath] -> Resolver +localShadowResolver shadows = + let local = mkLocalResolver Direct + f = resolve local + rname = "LocalShadowResolver" + in Resolver + rname + Higher + (\spath ctx -> if spath `elem` shadows then (f spath ctx) else Nothing) + [rname] + +-- | Searches the (potentially) stale parents of internal environments for a +-- local binding. +localCacheResolver :: Resolver +localCacheResolver = + let cache = (mkLocalResolver Full) + in cache { + resolve = \path@(SymPath p _) ctx -> + if null p + then (resolve cache) path ctx + else Nothing, + resolverName = "LocalCacheResolver", + resolverStack = ["LocalCacheResolver"] + } + +-- | Resolves a symbol to a binding that is a direct child of the global +-- environment (a top-level binding). +topLevelResolver :: Resolver +topLevelResolver = (mkGlobalResolver Direct) {resolverName = "TopLevelResolver", resolverStack = ["TopLevelResolver"]} + +-- | Resolves a symbol to a child of the global environment, possibly in a +-- child module of the global environment. +globalResolver :: Resolver +globalResolver = mkGlobalResolver Children + +-- | Look everywhere. +universalResolver :: Resolver +universalResolver = + let re = (mkLocalResolver Full <> mkGlobalResolver Full <> mkDynamicResolver Full) + in re {resolverName = "UniversalResolver", + resolverStack = ["UniversalResolver"] ++ tail (resolverStack re)} + +-- | Resolves a symbol to a binding in the current module or one of its sub +-- modules. +currentModuleResolver :: Resolver +currentModuleResolver = + let r (SymPath p n) ctx = + -- TODO: Should not need search here; find should be sufficient. + fmap (ctx,) (maybeId (E.searchValueBinder (contextGlobalEnv ctx) (SymPath ((contextPath ctx)++p) n))) + rname = "CurrentModuleResolver" + in Resolver rname Higher r [rname] + +-- | Resolves a symbol to a binding in one of the modules currently "used". +usedModuleResolver :: Resolver +usedModuleResolver = + let r (SymPath p n) ctx = + let genv = (contextGlobalEnv ctx) + usemods = (Set.toList (envUseModules genv)) + searches = map (\(SymPath p' n') -> fmap (ctx,) (maybeId (E.searchValueBinder genv (SymPath (p'++(n':p)) n)))) usemods + in foldl (<|>) Nothing searches + rname = "UsedModuleResolver" + in Resolver rname Higher r [rname] + +-- | Resolves a symbol to a binding in the global type environment. +typeResolver :: Resolver +typeResolver = + let r path ctx = + fmap (ctx,) (maybeId (lookupBinderInTypeEnv ctx path)) + rname = "TypeResolver" + in Resolver rname Lower r [rname] + +-- | Standard sequence of resolvers to try when no other resolutions succeed. +-- Always has the lowest order. +fallbackResolver :: Resolver +fallbackResolver = + currentModuleResolver <> usedModuleResolver <> universalResolver <> typeResolver {order = Lower} + +-- | Sequence of resolvers to try when resolving symbols in function bodies. +functionBodySymbolResolver :: [SymPath] -> Resolver +functionBodySymbolResolver shadows = + localShadowResolver shadows <> standardResolver + +applyResolver :: Resolver -> SymPath -> Context -> Maybe (Context, Binder) +applyResolver resolver spath ctx = + (resolve resolver) spath ctx + +-- | Normally, local and global resolvers take precedence over dynamic +-- resolvers. This resolver inverts this behavior, combining a given resolver +-- with a dynamic resolver that always takes precedence. +forceDynamicResolver :: Resolver -> Resolver +forceDynamicResolver resolver = + localDynamicResolver {order = Higher} + <> globalDynamicResolver {order = Higher} + <> resolver + +-- | Given a resolver, returns a new resolver that will attempt to resolve +-- symbols globally first, regardless of the input resolver's precedence. +forceGlobalResolver :: Resolver -> Resolver +forceGlobalResolver resolver = + globalResolver {order = Higher} <> resolver + +-- | Resolve a symbol to a binding in the context's local environment. +localResolver :: Resolver +localResolver = + mkLocalResolver Children + +dynamicResolver :: Resolver +dynamicResolver = + localDynamicResolver <> globalDynamicResolver + +standardResolver :: Resolver +standardResolver = + -- n.b. we need to call the cache resolver specifically for the case: + -- primitiveEval, during evaluation of the *arg* argument. + -- + -- This is a bit strange--in theory, if the environment parents are correct, + -- we should never need to rely on the parent of an internal environment since + -- its parent should == the global environment. + localResolver <> localCacheResolver <> globalDynamicResolver {order = Higher} <> fallbackResolver + +standardResolverNoCache :: Resolver +standardResolverNoCache = + localResolver <> globalDynamicResolver {order = Higher} <> fallbackResolver + +-- | +staticEnvResolver :: Env -> Resolver +staticEnvResolver e = + let resolver = (mkLocalResolver Children) + in resolver { + resolve = \path ctx -> (resolve resolver) path ctx {contextInternalEnv = Just e}, + resolverName = "StaticEnvResolver", + resolverStack = ["StaticEnvResolver"] + } + +-------------------------------------------------------------------------------- +-- "legacy" resolvers. +-- These are 1:1 translations to the old implementation of direct lookups in +-- Eval.hs. We should replace these with more specific combinations of +-- resolvers. +-- +-- The following current issue prevents us: +-- There are several lookups that seem to rely on *search* methods to find the +-- right binding, these methods traverse cached parents. +-- +-- For example, a call to `doc ` in a module M results in a binding +-- M. in the global environment. Finding this in a defn call is +-- incorrect, since defn does not expect qualified names. So, the defn call's +-- name needs to remain the same. + +legacyFull :: Resolver +legacyFull = + ((mkDynamicResolver Full) {order=Higher}) + <> (mkLocalResolver Full) { + resolve = \s@(SymPath p _) c -> if null p then (resolve (mkLocalResolver Full)) s c else Nothing + } + <> (mkGlobalResolver Full) {order=Higher} + <> currentModuleResolver + <> typeResolver {order=Higher} + <> usedModuleResolver + +legacyPreferDynamic :: Resolver +legacyPreferDynamic = + (mkDynamicResolver Children) {order=Higher} + <> legacyFull + +legacyPreferGlobal :: Resolver +legacyPreferGlobal = + mkGlobalResolver Children + <> legacyFull + +legacyLocal :: [SymPath] -> Resolver +legacyLocal shadows = + localShadowResolver shadows + <> legacyPreferDynamic From 6d711db0299c0181a8606d8ff508771bd6eff19e Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Wed, 16 Feb 2022 16:52:52 -0500 Subject: [PATCH 2/8] refactor: move evaluation functions out of eval This refactor moves all the form-specific evaluation functions that were previously defined as local functions in the main eval loop into top-level functions in Eval.hs. This should make it easier to tweak and swap out these functions in the main eval loop. As a result of the move, the functions need to take additional parameters to carry state across the evaluator loops, namely, we need to pass: - a resolution mode - a resolver - a root xobj - a context While this may seem tedious, it gives us flexibility. Evaluators that don't need the global eval loop's resolver can refrain from using it, and it's easier to tell what's being passed since we're not referencing values captured much further up in a function's body. Additionally, I've moved out local fold function definitions "successiveEval" and tried to give them more expressive names. I also used shorter definitions (mostly dropping explicit case statements) where possible. I'm hoping this change will also make it easier to try and pinpoint opportunities to improve evaluator performance on large inputs. This commit contains no behavioral differences. --- src/Eval.hs | 425 +++++++++++++++++++++++++++++----------------------- 1 file changed, 235 insertions(+), 190 deletions(-) diff --git a/src/Eval.hs b/src/Eval.hs index 2a90e7bf7..744e45c0a 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -39,8 +39,6 @@ import Util import Prelude hiding (exp, mod) import Resolver -type Evaluator = [XObj] -> IO (Context, Either EvalError XObj) - -- Prefer dynamic bindings and use the standard resolution order when evaluating symbols. evalDynamic :: Context -> XObj -> IO (Context, Either EvalError XObj) evalDynamic ctx xobj = eval ctx xobj ResolveStatic legacyPreferDynamic @@ -101,7 +99,7 @@ eval ctx xobj@(XObj o info ty) mode resolver = -- then throwErr (PrivateBinding (getPath found)) ctx info -- else (ctx, Right (resolveDef found)) Arr objs -> do - (newCtx, evaled) <- foldlM successiveEval (ctx, Right []) objs + (newCtx, evaled) <- foldlM (evalAndCollect mode resolver) (ctx, Right []) objs pure ( newCtx, do @@ -109,7 +107,7 @@ eval ctx xobj@(XObj o info ty) mode resolver = Right (XObj (Arr ok) info ty) ) StaticArr objs -> do - (newCtx, evaled) <- foldlM successiveEval (ctx, Right []) objs + (newCtx, evaled) <- foldlM (evalAndCollect mode resolver) (ctx, Right []) objs pure ( newCtx, do @@ -130,19 +128,19 @@ eval ctx xobj@(XObj o info ty) mode resolver = Left e -> pure (evalError ctx (format e) (xobjInfo xobj)) Right form' -> case form' of - (IfPat _ _ _ _) -> evaluateIf form' + (IfPat _ _ _ _) -> evaluateIf xobj ctx resolver form' (DefnPat _ _ _ _) -> specialCommandDefine ctx xobj (DefPat _ _ _) -> specialCommandDefine ctx xobj - (ThePat _ _ _) -> evaluateThe form' - (LetPat _ _ _) -> evaluateLet form' - (FnPat _ _ _) -> evaluateFn form' - (AppPat (ClosurePat _ _ _) _) -> evaluateClosure form' - (AppPat (DynamicFnPat _ _ _) _) -> evaluateDynamicFn form' - (AppPat (MacroPat _ _ _) _) -> evaluateMacro form' - (AppPat (CommandPat _ _ _) _) -> evaluateCommand form' - (AppPat (PrimitivePat _ _ _) _) -> evaluatePrimitive form' + (ThePat _ _ _) -> evaluateThe xobj ctx resolver form' + (LetPat _ _ _) -> evaluateLet xobj ctx mode resolver form' + (FnPat _ _ _) -> evaluateFn xobj ctx resolver form' + (AppPat (ClosurePat _ _ _) _) -> evaluateClosure xobj ctx mode resolver form' + (AppPat (DynamicFnPat _ _ _) _) -> evaluateDynamicFn xobj ctx mode resolver form' + (AppPat (MacroPat _ _ _) _) -> evaluateMacro xobj ctx resolver form' + (AppPat (CommandPat _ _ _) _) -> evaluateCommand xobj ctx mode resolver form' + (AppPat (PrimitivePat _ _ _) _) -> evaluatePrimitive xobj ctx resolver form' (WithPat _ sym@(SymPat path _) forms) -> specialCommandWith ctx sym path forms - (DoPat _ forms) -> evaluateSideEffects forms + (DoPat _ forms) -> evaluateSideEffects xobj ctx mode resolver forms (WhilePat _ cond body) -> specialCommandWhile ctx cond body (SetPat _ iden value) -> specialCommandSet ctx (iden : [value]) -- This next match is a bit redundant looking at first glance, but @@ -164,11 +162,10 @@ eval ctx xobj@(XObj o info ty) mode resolver = case evald of Left err -> pure (evalError ctx (show err) (xobjInfo xobj)) Right x' -> case checkStatic' x' of - --_ -> evaluateApp (self : args) - Right _ -> evaluateApp (self : args) + Right _ -> evaluateApp xobj ctx mode resolver (self : args) Left er -> pure (ctx, Left er) - (AppPat (ListPat _) _) -> evaluateApp form' - (AppPat (SymPat _ _) _) -> evaluateApp form' + (AppPat (ListPat _) _) -> evaluateApp xobj ctx mode resolver form' + (AppPat (SymPat _ _) _) -> evaluateApp xobj ctx mode resolver form' (AppPat (XObj other _ _) _) | isResolvableStaticObj other -> pure (ctx, (Left (HasStaticCall xobj info))) @@ -183,180 +180,228 @@ eval ctx xobj@(XObj o info ty) mode resolver = checkStatic' (XObj (Match _) _ _) = Left (HasStaticCall xobj info) checkStatic' (XObj Ref _ _) = Left (HasStaticCall xobj info) checkStatic' x' = Right x' - successiveEval (ctx', acc) x = - case acc of - Left _ -> pure (ctx', acc) - Right l -> do - (newCtx, evald) <- eval ctx' x mode resolver - pure $ case evald of - Right res -> (newCtx, Right (l ++ [res])) - Left err -> (newCtx, Left err) - evaluateIf :: Evaluator - evaluateIf (IfPat _ cond true false) = do - (newCtx, evd) <- eval ctx cond ResolveStatic resolver - case evd of - Right cond' -> - case xobjObj cond' of - Bol b -> eval newCtx (if b then true else false) ResolveStatic resolver - _ -> - pure (throwErr (IfContainsNonBool cond) ctx (xobjInfo cond)) - Left e -> pure (newCtx, Left e) - evaluateIf _ = pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj)) - evaluateThe :: Evaluator - evaluateThe (ThePat the t value) = do - (newCtx, evaledValue) <- expandAll evalDynamic ctx value -- TODO: Why expand all here? - pure - ( newCtx, - do - okValue <- evaledValue - Right (XObj (Lst [the, t, okValue]) info ty) - ) - evaluateThe _ = pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj)) - evaluateLet :: Evaluator - evaluateLet (LetPat _ (ArrPat bindings) body) = - do - let binds = unwrapVar (pairwise bindings) [] - ni = Env Map.empty (contextInternalEnv ctx) Nothing Set.empty InternalEnv 0 - eitherCtx <- foldrM successiveEval' (Right (replaceInternalEnv ctx ni)) binds - case eitherCtx of - Left err -> pure (ctx, Left err) - Right newCtx -> do - let shadowResolver = - (legacyLocal (map (\(name, _) -> (SymPath [] name)) binds)) - (finalCtx, evaledBody) <- eval newCtx body ResolveStatic shadowResolver + +-------------------------------------------------------------------------------- +-- predefined form evaluators + +-- | An evaluator takes a root xobj, context, resolver and list of xobjs and +-- returns the result of evaluating the list given the root and other arguments. +-- +-- We define evaluators for each predefined form. See Forms.hs +type Evaluator = XObj -> Context -> Resolver -> [XObj] -> IO (Context, Either EvalError XObj) + +-- | Modal evaluators are evaluators that take an additional "ResolveMode" +-- argument. This is necessary for some forms for which the symbol resolution +-- mode should change while processing one or all of the form's members. +type ModalEvaluator = + XObj -> Context -> ResolveMode -> Resolver -> [XObj] -> IO (Context, Either EvalError XObj) + +-- | Evaluates an if form. (if condition true false) +evaluateIf :: Evaluator +evaluateIf _ ctx resolver (IfPat _ cond true false) = + do (nctx, result) <- eval ctx cond ResolveStatic resolver + either (pure . const (nctx, result)) (boolCheck nctx . xobjObj) result + where boolCheck :: Context -> Obj -> IO (Context, Either EvalError XObj) + boolCheck c (Bol b) = eval c (if b then true else false) ResolveStatic resolver + boolCheck _ _ = pure $ throwErr (IfContainsNonBool cond) ctx (xobjInfo cond) +evaluateIf root ctx _ _ = pure $ evalError ctx (format (GenericMalformed root)) (xobjInfo root) + +-- | Evaluates a the form. (the T x) +evaluateThe :: Evaluator +evaluateThe root ctx _ (ThePat the t value) = + let info = xobjInfo root + ty = xobjTy root + in do (nctx, result) <- expandAll evalDynamic ctx value -- TODO: Why expand all here? + let newForm = second (\x -> (XObj (Lst [the, t, x]) info ty)) result + pure (nctx, newForm) +evaluateThe root ctx _ _ = pure (evalError ctx (format (GenericMalformed root)) (xobjInfo root)) + +-- | Evaluates a let form. (let [name value] body) +evaluateLet :: ModalEvaluator +evaluateLet _ ctx mode resolver (LetPat _ (ArrPat bindings) body) = + do let binds = unwrapVar (pairwise bindings) [] + ni = E.nested (contextInternalEnv ctx) Nothing 0 + sresolver = (legacyLocal (map (\(name, _) -> (SymPath [] name)) binds)) + eitherCtx <- foldrM (evalAndUpdateBindings mode resolver) (Right (replaceInternalEnv ctx ni)) binds + case eitherCtx of + Left err -> pure (ctx, Left err) + Right newCtx -> + do (finalCtx, evaledBody) <- eval newCtx body ResolveStatic sresolver let Just e = contextInternalEnv finalCtx parentEnv = envParent e - pure - ( replaceInternalEnvMaybe finalCtx parentEnv, - do - okBody <- evaledBody - Right okBody - ) - where - unwrapVar [] acc = acc - unwrapVar ((XObj (Sym (SymPath [] x) _) _ _, y) : xs) acc = unwrapVar xs ((x, y) : acc) - unwrapVar _ _ = error "unwrapvar" - successiveEval' (n, x) = - \case - err@(Left _) -> pure err - Right ctx' -> do - -- Bind a reference to the let bind in a recursive - -- environment. This permits recursion in anonymous functions - -- in let binds such as: - -- (let [f (fn [x] (if (= x 1) x (f (dec x))))] (f 10)) - let origin = (contextInternalEnv ctx') - recFix = (E.recursive origin (Just "let-rec-env") 0) - Right envWithSelf = if isFn x then E.insertX recFix (SymPath [] n) x else Right recFix - ctx'' = replaceInternalEnv ctx' envWithSelf - (newCtx, res) <- eval ctx'' x mode resolver - case res of - Right okX -> - pure $ Right (fromRight (error "Failed to eval let binding!!") (bindLetDeclaration (newCtx {contextInternalEnv = origin}) n okX)) - Left err -> pure $ Left err - evaluateLet _ = pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj)) - evaluateFn :: Evaluator - evaluateFn (FnPat self args body) = do - (newCtx, expanded) <- macroExpand ctx body - pure $ - case expanded of - Right b -> - (newCtx, Right (XObj (Closure (XObj (Lst [self, args, b]) info ty) (CCtx newCtx)) info ty)) - Left err -> (ctx, Left err) - evaluateFn _ = pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj)) - evaluateClosure :: Evaluator - evaluateClosure (AppPat (ClosurePat params body c) args) = do - (newCtx, evaledArgs) <- foldlM successiveEval (ctx, Right []) args - case evaledArgs of - Right okArgs -> do - let newGlobals = (contextGlobalEnv newCtx) <> (contextGlobalEnv c) - newTypes = TypeEnv $ (getTypeEnv (contextTypeEnv newCtx)) <> (getTypeEnv (contextTypeEnv c)) - updater = replaceHistory' (contextHistory ctx) . replaceGlobalEnv' newGlobals . replaceTypeEnv' newTypes - (ctx', res) <- apply (updater c) body params okArgs - pure (replaceGlobalEnv newCtx (contextGlobalEnv ctx'), res) - Left err -> pure (newCtx, Left err) - evaluateClosure _ = pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj)) - evaluateDynamicFn :: Evaluator - evaluateDynamicFn (AppPat (DynamicFnPat _ params body) args) = do - (newCtx, evaledArgs) <- foldlM successiveEval (ctx, Right []) args - case evaledArgs of - Right okArgs -> apply newCtx body params okArgs - Left err -> pure (newCtx, Left err) - evaluateDynamicFn _ = pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj)) - evaluateMacro :: Evaluator - evaluateMacro (AppPat (MacroPat _ params body) args) = do - (ctx', res) <- apply ctx body params args - case res of - Right xobj' -> macroExpand ctx' xobj' - Left _ -> pure (ctx, res) - evaluateMacro _ = pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj)) - evaluateCommand :: Evaluator - evaluateCommand (AppPat (CommandPat (NullaryCommandFunction nullary) _ _) []) = - nullary ctx - evaluateCommand (AppPat (CommandPat (UnaryCommandFunction unary) _ _) [x]) = do - (c, evaledArgs) <- foldlM successiveEval (ctx, Right []) [x] - case evaledArgs of - Right args -> let [x'] = take 1 args in unary c x' - Left err -> pure (ctx, Left err) - evaluateCommand (AppPat (CommandPat (BinaryCommandFunction binary) _ _) [x, y]) = do - (c, evaledArgs) <- foldlM successiveEval (ctx, Right []) [x, y] - case evaledArgs of - Right args -> let [x', y'] = take 2 args in binary c x' y' - Left err -> pure (ctx, Left err) - evaluateCommand (AppPat (CommandPat (TernaryCommandFunction ternary) _ _) [x, y, z]) = do - (c, evaledArgs) <- foldlM successiveEval (ctx, Right []) [x, y, z] - case evaledArgs of - Right args' -> let [x', y', z'] = take 3 args' in ternary c x' y' z' - Left err -> pure (ctx, Left err) - evaluateCommand (AppPat (CommandPat (VariadicCommandFunction variadic) _ _) args) = do - (c, evaledArgs) <- foldlM successiveEval (ctx, Right []) args - case evaledArgs of - Right args' -> variadic c args' - Left err -> pure (ctx, Left err) - -- Should be caught during validation - evaluateCommand (AppPat (CommandPat _ _ _) _) = - pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj)) - evaluateCommand _ = pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj)) - evaluatePrimitive :: Evaluator - evaluatePrimitive (AppPat p@(PrimitivePat (NullaryPrimitive nullary) _ _) []) = - nullary p ctx - evaluatePrimitive (AppPat p@(PrimitivePat (UnaryPrimitive unary) _ _) [x]) = do - unary p ctx x - evaluatePrimitive (AppPat p@(PrimitivePat (BinaryPrimitive binary) _ _) [x, y]) = do - binary p ctx x y - evaluatePrimitive (AppPat p@(PrimitivePat (TernaryPrimitive ternary) _ _) [x, y, z]) = do - ternary p ctx x y z - evaluatePrimitive (AppPat p@(PrimitivePat (QuaternaryPrimitive quaternary) _ _) [x, y, z, w]) = do - quaternary p ctx x y z w - evaluatePrimitive (AppPat p@(PrimitivePat (VariadicPrimitive variadic) _ _) args) = do - variadic p ctx args - -- Should be caught during validation - evaluatePrimitive (AppPat (PrimitivePat _ _ _) _) = - pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj)) - evaluatePrimitive _ = pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj)) - evaluateApp :: Evaluator - evaluateApp (AppPat f' args) = - case f' of - l@(ListPat _) -> go l ResolveStatic - sym@(SymPat _ _) -> go sym mode - _ -> pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj)) - where - go x mode' = - do - (newCtx, f) <- eval ctx x mode' resolver - case f of - Right fun -> do - (newCtx', res) <- eval (pushFrame newCtx xobj) (XObj (Lst (fun : args)) (xobjInfo x) (xobjTy x)) ResolveStatic resolver - pure (popFrame newCtx', res) - x' -> pure (newCtx, x') - evaluateApp _ = pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj)) - evaluateSideEffects :: Evaluator - evaluateSideEffects forms = do - foldlM successiveEval' (ctx, dynamicNil) forms - where - successiveEval' (ctx', acc) x = - case acc of - err@(Left _) -> pure (ctx', err) - Right _ -> eval ctx' x mode resolver + pure (replaceInternalEnvMaybe finalCtx parentEnv, evaledBody) + where + unwrapVar :: [(XObj, XObj)] -> [(String, XObj)] -> [(String, XObj)] + unwrapVar [] acc = acc + unwrapVar ((XObj (Sym (SymPath [] x) _) _ _, y) : xs) acc = unwrapVar xs ((x, y) : acc) + unwrapVar _ _ = error "unwrapvar" +evaluateLet root ctx _ _ _ = pure (evalError ctx (format (GenericMalformed root)) (xobjInfo root)) + +-- | Evaluates a fn form (fn [parameter] body) +evaluateFn :: Evaluator +evaluateFn root ctx _ (FnPat self args body) = + let info = xobjInfo root + ty = xobjTy root + in do (newCtx, expanded) <- macroExpand ctx body + pure $ + either (const (newCtx, expanded)) + (\b -> (newCtx, Right (XObj (Closure (XObj (Lst [self, args, b]) info ty) (CCtx newCtx)) info ty))) + expanded +evaluateFn root ctx _ _ = pure (evalError ctx (format (GenericMalformed root)) (xobjInfo root)) + +-- | Evaluates a closure. +evaluateClosure :: ModalEvaluator +evaluateClosure _ ctx mode resolver (AppPat (ClosurePat params body c) args) = + do (newCtx, evaledArgs) <- foldlM (evalAndCollect mode resolver) (ctx, Right []) args + case evaledArgs of + Left err -> pure (newCtx, Left err) + Right okArgs -> do + let newGlobals = (contextGlobalEnv newCtx) <> (contextGlobalEnv c) + newTypes = TypeEnv $ (getTypeEnv (contextTypeEnv newCtx)) <> (getTypeEnv (contextTypeEnv c)) + updater = + replaceHistory' (contextHistory ctx) . replaceGlobalEnv' newGlobals . replaceTypeEnv' newTypes + (ctx', res) <- apply (updater c) body params okArgs + pure (replaceGlobalEnv newCtx (contextGlobalEnv ctx'), res) +evaluateClosure root ctx _ _ _ = pure (evalError ctx (format (GenericMalformed root)) (xobjInfo root)) + +-- | Evaluates a dynamic fn form. +evaluateDynamicFn :: ModalEvaluator +evaluateDynamicFn _ ctx mode resolver (AppPat (DynamicFnPat _ params body) args) = + do (newCtx, evaledArgs) <- foldlM (evalAndCollect mode resolver) (ctx, Right []) args + case evaledArgs of + Right okArgs -> apply newCtx body params okArgs + Left err -> pure (newCtx, Left err) +evaluateDynamicFn root ctx _ _ _ = pure (evalError ctx (format (GenericMalformed root)) (xobjInfo root)) + +-- | Evaluates a macro (defmacro name [parameter :rest rest-parameter] body) +evaluateMacro :: Evaluator +evaluateMacro _ ctx _ (AppPat (MacroPat _ params body) args) = do + (ctx', res) <- apply ctx body params args + either (pure . const (ctx, res)) (macroExpand ctx') res +evaluateMacro root ctx _ _ = pure (evalError ctx (format (GenericMalformed root)) (xobjInfo root)) + +-- | Evaluates a command. (command car argument) +evaluateCommand :: ModalEvaluator +evaluateCommand _ ctx _ _ (AppPat (CommandPat (NullaryCommandFunction nullary) _ _) []) = + nullary ctx +evaluateCommand _ ctx mode resolver (AppPat (CommandPat (UnaryCommandFunction unary) _ _) [x]) = do + (c, result) <- foldlM (evalAndCollect mode resolver) (ctx, Right []) [x] + either (\r -> pure (ctx, Left r)) (unary c . head) result +evaluateCommand _ ctx mode resolver (AppPat (CommandPat (BinaryCommandFunction binary) _ _) [x, y]) = do + (c, result) <- foldlM (evalAndCollect mode resolver) (ctx, Right []) [x, y] + either + (\r -> pure (ctx, Left r)) + (\r -> let [x', y'] = take 2 r in binary c x' y') + result +evaluateCommand _ ctx mode resolver (AppPat (CommandPat (TernaryCommandFunction ternary) _ _) [x, y, z]) = do + (c, result) <- foldlM (evalAndCollect mode resolver) (ctx, Right []) [x, y, z] + either + (\r -> pure (ctx, Left r)) + (\r -> let [x', y', z'] = take 3 r in ternary c x' y' z') + result +evaluateCommand _ ctx mode resolver (AppPat (CommandPat (VariadicCommandFunction variadic) _ _) args) = do + (c, result) <- foldlM (evalAndCollect mode resolver) (ctx, Right []) args + either + (\r -> pure (ctx, Left r)) + (variadic c) + result +-- Should be caught during validation +evaluateCommand root ctx _ _ (AppPat (CommandPat _ _ _) _) = + pure (evalError ctx (format (GenericMalformed root)) (xobjInfo root)) +evaluateCommand root ctx _ _ _ = pure (evalError ctx (format (GenericMalformed root)) (xobjInfo root)) + +-- | Evaluates a primitive. (primitive list arguments) +evaluatePrimitive :: Evaluator +evaluatePrimitive _ ctx _ (AppPat p@(PrimitivePat (NullaryPrimitive nullary) _ _) []) = + nullary p ctx +evaluatePrimitive _ ctx _ (AppPat p@(PrimitivePat (UnaryPrimitive unary) _ _) [x]) = do + unary p ctx x +evaluatePrimitive _ ctx _ (AppPat p@(PrimitivePat (BinaryPrimitive binary) _ _) [x, y]) = do + binary p ctx x y +evaluatePrimitive _ ctx _ (AppPat p@(PrimitivePat (TernaryPrimitive ternary) _ _) [x, y, z]) = do + ternary p ctx x y z +evaluatePrimitive _ ctx _ (AppPat p@(PrimitivePat (QuaternaryPrimitive quaternary) _ _) [x, y, z, w]) = do + quaternary p ctx x y z w +evaluatePrimitive _ ctx _ (AppPat p@(PrimitivePat (VariadicPrimitive variadic) _ _) args) = do + variadic p ctx args +-- Should be caught during validation +evaluatePrimitive root ctx _ (AppPat (PrimitivePat _ _ _) _) = + pure (evalError ctx (format (GenericMalformed root)) (xobjInfo root)) +evaluatePrimitive root ctx _ _ = pure (evalError ctx (format (GenericMalformed root)) (xobjInfo root)) + +-- | Evaluates any number of forms only for their side effects. (do forms) +evaluateSideEffects :: ModalEvaluator +evaluateSideEffects _ ctx mode resolver forms = + foldlM (evaluateEach mode resolver) (ctx, dynamicNil) forms + +-- | Evaluates a function application. (f argument) +evaluateApp :: ModalEvaluator +evaluateApp root ctx mode resolver (AppPat f' args) = + case f' of + l@(ListPat _) -> go l ResolveStatic + sym@(SymPat _ _) -> go sym mode + _ -> pure (evalError ctx (format (GenericMalformed root)) (xobjInfo root)) + where + evalAndPushFrame c xobj fun = + eval (pushFrame c root) + (XObj (Lst (fun : args)) (xobjInfo xobj) (xobjTy xobj)) + ResolveStatic + resolver + go x mode' = + do (newCtx, f) <- eval ctx x mode' resolver + either + (pure . const (newCtx, f)) + (\fun -> do (newCtx', res) <- evalAndPushFrame newCtx x fun + pure (popFrame newCtx', res)) + f +evaluateApp root ctx _ _ _ = + pure (evalError ctx (format (GenericMalformed root)) (xobjInfo root)) + +-------------------------------------------------------------------------------- +-- evaluation folds +-- +-- These functions should be used as arguments to fold* functions to evaluate +-- each form in a list of forms and return a final result. + +-- | Evaluates each form in a list of forms, returning the value of the final +-- form evaluated. Stops immediately on error. +evaluateEach :: ResolveMode -> Resolver -> (Context, Either EvalError XObj) -> XObj -> IO (Context, Either EvalError XObj) +evaluateEach mode resolver prev@(ctx, px) x = + either (pure . const prev) (const (eval ctx x mode resolver)) px + +-- | Evaluates each form in a list of forms and collects the results of each +-- evaluation into a list. Stops immediately on error. +evalAndCollect :: ResolveMode -> Resolver -> (Context, Either EvalError [XObj]) -> XObj -> IO (Context, Either EvalError [XObj]) +evalAndCollect mode resolver (ctx', acc) x = + case acc of + Left _ -> pure (ctx', acc) + Right l -> do + (newCtx, evald) <- eval ctx' x mode resolver + pure $ case evald of + Right res -> (newCtx, Right (l ++ [res])) + Left err -> (newCtx, Left err) --- + +-- | Evaluates each form in a list of forms and names and updates the +-- corresponding binding in a context's internal environment with the result of +-- the evaluation. Stops immediately on error. +evalAndUpdateBindings :: ResolveMode -> Resolver -> (String, XObj) -> Either EvalError Context -> IO (Either EvalError Context) +evalAndUpdateBindings _ _ _ e@(Left _) = pure e +evalAndUpdateBindings mode resolver (name, xobj) (Right ctx) = + do let origin = (contextInternalEnv ctx) + recFix = (E.recursive origin (Just "let-rec-env") 0) + Right envWithSelf = if isFn xobj + then E.insertX recFix (SymPath [] name) xobj + else Right recFix + nctx = replaceInternalEnv ctx envWithSelf + binderr = error "Failed to eval let binding!!" + (newCtx, res) <- eval nctx xobj mode resolver + pure $ + either + Left + (Right . fromRight binderr . bindLetDeclaration (newCtx {contextInternalEnv = origin}) name) + res + +-------------------------------------------------------------------------------- macroExpand :: Context -> XObj -> IO (Context, Either EvalError XObj) macroExpand ctx xobj = From 5ee79e969f781bef565977bf3010e19f90912aae Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Wed, 16 Feb 2022 17:08:40 -0500 Subject: [PATCH 3/8] refactor: translate a few more do's to either --- src/Eval.hs | 27 ++++++++++++--------------- 1 file changed, 12 insertions(+), 15 deletions(-) diff --git a/src/Eval.hs b/src/Eval.hs index 744e45c0a..3383ec706 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -100,25 +100,22 @@ eval ctx xobj@(XObj o info ty) mode resolver = -- else (ctx, Right (resolveDef found)) Arr objs -> do (newCtx, evaled) <- foldlM (evalAndCollect mode resolver) (ctx, Right []) objs - pure - ( newCtx, - do - ok <- evaled - Right (XObj (Arr ok) info ty) - ) + either + (\e -> pure (newCtx, Left e)) + (\x -> pure (newCtx, Right (XObj (Arr x) info ty))) + evaled StaticArr objs -> do (newCtx, evaled) <- foldlM (evalAndCollect mode resolver) (ctx, Right []) objs - pure - ( newCtx, - do - ok <- evaled - Right (XObj (StaticArr ok) info ty) - ) + either + (\e -> pure (newCtx, Left e)) + (\x -> pure (newCtx, Right (XObj (StaticArr x) info ty))) + evaled _ -> do (nctx, res) <- annotateWithinContext ctx xobj - pure $ case res of - Left e -> (nctx, Left e) - Right (val, _) -> (nctx, Right val) + either + (\e -> pure (nctx, Left e)) + (\(v, _) -> pure (nctx, Right v)) + res where resolveDef (XObj (Lst [XObj DefDynamic _ _, _, value]) _ _) = value resolveDef (XObj (Lst [XObj LocalDef _ _, _, value]) _ _) = value From 331fe2f9c811968297c5b147732ed6f9289a89bd Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Thu, 17 Feb 2022 15:50:40 -0500 Subject: [PATCH 4/8] refactor: add Show instance to ResolveMode --- src/Resolver.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Resolver.hs b/src/Resolver.hs index 139f89850..778296057 100644 --- a/src/Resolver.hs +++ b/src/Resolver.hs @@ -74,6 +74,7 @@ instance Ord LookupPreference where data ResolveMode = ResolveStatic | ResolveDynamic + deriving(Show) -- | Specifies how a symbol should be resolved in a given context. data Resolver = Resolver { From 5cc575237f4b204c8576beeddf55e4362a662342 Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Thu, 17 Feb 2022 15:51:08 -0500 Subject: [PATCH 5/8] refactor: lift remaining local functions from eval This commit finalizes the migration of local definitions in the main eval loop into top level functions. In addition: - I removed privacy checking. We do this in Expand.hs and it currently covers our test cases. - I consolidated some static form checks. Note that the evaluator is particularly sensitive about return values--I was stuck for a while because I inadvertently returned the head of a list from a static check instead of the list being evaluated itself -- this totally breaks the evaluator. Because of this, I set the return value of this function to Error||Unit. - I've also combined the array evaluation functions. - Finally, I've removed the Fn check from isResolvableObj. After checkStatic consolidation, this introduces a problematic case, and removing it doesn't seem to break anything, so it seems extraneous. --- src/Eval.hs | 297 +++++++++++++++++++++++++++------------------------- src/Obj.hs | 8 +- 2 files changed, 156 insertions(+), 149 deletions(-) diff --git a/src/Eval.hs b/src/Eval.hs index 3383ec706..8b3ee9c48 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -62,122 +62,19 @@ evalStatic ctx xobj = eval ctx xobj ResolveDynamic legacyPreferGlobal -- remnant of us using StateT, and might not be necessary anymore since we -- switched to more explicit state-passing.) eval :: Context -> XObj -> ResolveMode -> Resolver -> IO (Context, Either EvalError XObj) -eval ctx xobj@(XObj o info ty) mode resolver = +eval ctx xobj@(XObj o _ _) mode resolver = case o of - Lst body -> eval' body - Sym spath _ -> - pure $ - case mode of - ResolveDynamic -> - unwrapLookup $ - (applyResolver resolver spath ctx - >>= getXObj - >>= pure . second (second resolveDef) - >>= checkStatic) - ResolveStatic -> - unwrapLookup $ - (applyResolver resolver spath ctx - >>= getXObj - >>= pure . second (second resolveDef)) - where - getXObj :: (Context, Binder) -> Maybe (Context, Either EvalError XObj) - getXObj = pure . (second (pure . binderXObj)) - checkStatic :: (Context, Either EvalError XObj) -> Maybe (Context, Either EvalError XObj) - checkStatic v@(_, (Right (XObj (Lst ((XObj obj _ _) : _)) _ _))) = - if isResolvableStaticObj obj - then pure (ctx, Left (HasStaticCall xobj info)) - else pure v - checkStatic v = pure v - -- all else failed, error. - unwrapLookup = - fromMaybe - (throwErr (SymbolNotFound spath) ctx info) - -- TODO: Reintegrate this check -- in resolve? - --checkPrivate meta found = - -- pure $ - -- if metaIsTrue meta "private" - -- then throwErr (PrivateBinding (getPath found)) ctx info - -- else (ctx, Right (resolveDef found)) - Arr objs -> do - (newCtx, evaled) <- foldlM (evalAndCollect mode resolver) (ctx, Right []) objs - either - (\e -> pure (newCtx, Left e)) - (\x -> pure (newCtx, Right (XObj (Arr x) info ty))) - evaled - StaticArr objs -> do - (newCtx, evaled) <- foldlM (evalAndCollect mode resolver) (ctx, Right []) objs - either - (\e -> pure (newCtx, Left e)) - (\x -> pure (newCtx, Right (XObj (StaticArr x) info ty))) - evaled + Lst body -> evaluateList xobj ctx mode resolver body + Sym _ _ -> evaluateSymbol xobj ctx mode resolver [xobj] + Arr objs -> evaluateArray xobj ctx mode resolver objs + StaticArr objs -> evaluateArray xobj ctx mode resolver objs _ -> do (nctx, res) <- annotateWithinContext ctx xobj - either - (\e -> pure (nctx, Left e)) - (\(v, _) -> pure (nctx, Right v)) - res - where - resolveDef (XObj (Lst [XObj DefDynamic _ _, _, value]) _ _) = value - resolveDef (XObj (Lst [XObj LocalDef _ _, _, value]) _ _) = value - resolveDef x = x - eval' form = - case validate form of - Left e -> pure (evalError ctx (format e) (xobjInfo xobj)) - Right form' -> - case form' of - (IfPat _ _ _ _) -> evaluateIf xobj ctx resolver form' - (DefnPat _ _ _ _) -> specialCommandDefine ctx xobj - (DefPat _ _ _) -> specialCommandDefine ctx xobj - (ThePat _ _ _) -> evaluateThe xobj ctx resolver form' - (LetPat _ _ _) -> evaluateLet xobj ctx mode resolver form' - (FnPat _ _ _) -> evaluateFn xobj ctx resolver form' - (AppPat (ClosurePat _ _ _) _) -> evaluateClosure xobj ctx mode resolver form' - (AppPat (DynamicFnPat _ _ _) _) -> evaluateDynamicFn xobj ctx mode resolver form' - (AppPat (MacroPat _ _ _) _) -> evaluateMacro xobj ctx resolver form' - (AppPat (CommandPat _ _ _) _) -> evaluateCommand xobj ctx mode resolver form' - (AppPat (PrimitivePat _ _ _) _) -> evaluatePrimitive xobj ctx resolver form' - (WithPat _ sym@(SymPat path _) forms) -> specialCommandWith ctx sym path forms - (DoPat _ forms) -> evaluateSideEffects xobj ctx mode resolver forms - (WhilePat _ cond body) -> specialCommandWhile ctx cond body - (SetPat _ iden value) -> specialCommandSet ctx (iden : [value]) - -- This next match is a bit redundant looking at first glance, but - -- it is necessary to prevent hangs on input such as: `((def foo 2) - -- 4)`. Ideally, we could perform only *one* static check (the one - -- we do in eval). But the timing is wrong. - -- The `def` in the example above initially comes into the - -- evaluator as a *Sym*, **not** as a `Def` xobj. So, we need to - -- discriminate on the result of evaluating the symbol to eagerly - -- break the evaluation loop, otherwise we will proceed to evaluate - -- the def form, yielding Unit, and attempt to reevaluate unit - -- indefinitely on subsequent eval loops. - -- Importantly, the loop *is only broken on literal nested lists*. - -- That is, passing a *symbol* that, e.g. resolves to a defn list, won't - -- break our normal loop. - (AppPat self@(ListPat (x@(SymPat _ _) : _)) args) -> - do - (_, evald) <- eval ctx x ResolveDynamic resolver - case evald of - Left err -> pure (evalError ctx (show err) (xobjInfo xobj)) - Right x' -> case checkStatic' x' of - Right _ -> evaluateApp xobj ctx mode resolver (self : args) - Left er -> pure (ctx, Left er) - (AppPat (ListPat _) _) -> evaluateApp xobj ctx mode resolver form' - (AppPat (SymPat _ _) _) -> evaluateApp xobj ctx mode resolver form' - (AppPat (XObj other _ _) _) - | isResolvableStaticObj other -> - pure (ctx, (Left (HasStaticCall xobj info))) - [] -> pure (ctx, dynamicNil) - _ -> pure (throwErr (UnknownForm xobj) ctx (xobjInfo xobj)) - checkStatic' (XObj Def _ _) = Left (HasStaticCall xobj info) - checkStatic' (XObj (Defn _) _ _) = Left (HasStaticCall xobj info) - checkStatic' (XObj (Interface _ _) _ _) = Left (HasStaticCall xobj info) - checkStatic' (XObj (Instantiate _) _ _) = Left (HasStaticCall xobj info) - checkStatic' (XObj (Deftemplate _) _ _) = Left (HasStaticCall xobj info) - checkStatic' (XObj (External _) _ _) = Left (HasStaticCall xobj info) - checkStatic' (XObj (Match _) _ _) = Left (HasStaticCall xobj info) - checkStatic' (XObj Ref _ _) = Left (HasStaticCall xobj info) - checkStatic' x' = Right x' - + either + (\e -> pure (nctx, Left e)) + (\(v, _) -> pure (nctx, Right v)) + res + -------------------------------------------------------------------------------- -- predefined form evaluators @@ -190,9 +87,108 @@ type Evaluator = XObj -> Context -> Resolver -> [XObj] -> IO (Context, Either Ev -- | Modal evaluators are evaluators that take an additional "ResolveMode" -- argument. This is necessary for some forms for which the symbol resolution -- mode should change while processing one or all of the form's members. -type ModalEvaluator = +type ModalEvaluator = XObj -> Context -> ResolveMode -> Resolver -> [XObj] -> IO (Context, Either EvalError XObj) +-- | Evaluates a symbol. +evaluateSymbol :: ModalEvaluator +evaluateSymbol root ctx mode resolver [(XObj (Sym spath _) _ _)] = + pure $ + case mode of + ResolveDynamic -> + unwrapLookup $ + (applyResolver resolver spath ctx + >>= \(ctx', binder) -> getXObj (ctx', binder) + >>= pure . second (second resolveDef) + >>= \(c, x) -> + case x of + Right (XObj (Lst (xo@(XObj _ _ _) : _)) _ _) -> + pure $ either (\e -> (c, Left e)) (const (c, x)) (checkStatic root (xobjInfo root) xo) + _ -> pure (c, x)) + ResolveStatic -> + unwrapLookup $ + (applyResolver resolver spath ctx + >>= \(ctx', binder) -> getXObj (ctx', binder) + >>= pure . second (second resolveDef)) + where + getXObj :: (Context, Binder) -> Maybe (Context, Either EvalError XObj) + getXObj = pure . (second (pure . binderXObj)) + -- all else failed, error. + unwrapLookup :: Maybe (Context, Either EvalError XObj) -> (Context, Either EvalError XObj) + unwrapLookup = fromMaybe (throwErr (SymbolNotFound spath) ctx (xobjInfo root)) + resolveDef (XObj (Lst [XObj DefDynamic _ _, _, value]) _ _) = value + resolveDef (XObj (Lst [XObj LocalDef _ _, _, value]) _ _) = value + resolveDef x = x +evaluateSymbol root ctx _ _ _ = pure $ evalError ctx (format (GenericMalformed root)) (xobjInfo root) + +-- | Evaluates a list. (forms) +evaluateList :: ModalEvaluator +evaluateList root ctx mode resolver form = + case validate form of + Left e -> pure (evalError ctx (format e) (xobjInfo root)) + Right form' -> + case form' of + (IfPat _ _ _ _) -> evaluateIf root ctx resolver form' + (DefnPat _ _ _ _) -> specialCommandDefine ctx root + (DefPat _ _ _) -> specialCommandDefine ctx root + (ThePat _ _ _) -> evaluateThe root ctx resolver form' + (LetPat _ _ _) -> evaluateLet root ctx mode resolver form' + (FnPat _ _ _) -> evaluateFn root ctx resolver form' + (AppPat (ClosurePat _ _ _) _) -> evaluateClosure root ctx mode resolver form' + (AppPat (DynamicFnPat _ _ _) _) -> evaluateDynamicFn root ctx mode resolver form' + (AppPat (MacroPat _ _ _) _) -> evaluateMacro root ctx resolver form' + (AppPat (CommandPat _ _ _) _) -> evaluateCommand root ctx mode resolver form' + (AppPat (PrimitivePat _ _ _) _) -> evaluatePrimitive root ctx resolver form' + (WithPat _ sym@(SymPat path _) forms) -> specialCommandWith ctx sym path forms + (DoPat _ forms) -> evaluateSideEffects root ctx mode resolver forms + (WhilePat _ cond body) -> specialCommandWhile ctx cond body + (SetPat _ iden value) -> specialCommandSet ctx (iden : [value]) + -- This next match is a bit redundant looking at first glance, but + -- it is necessary to prevent hangs on input such as: `((def foo 2) + -- 4)`. Ideally, we could perform only *one* static check (the one + -- we do in eval). But the timing is wrong. + -- The `def` in the example above initially comes into the + -- evaluator as a *Sym*, **not** as a `Def` xobj. So, we need to + -- discriminate on the result of evaluating the symbol to eagerly + -- break the evaluation loop, otherwise we will proceed to evaluate + -- the def form, yielding Unit, and attempt to reevaluate unit + -- indefinitely on subsequent eval loops. + -- Importantly, the loop *is only broken on literal nested lists*. + -- That is, passing a *symbol* that, e.g. resolves to a defn list, won't + -- break our normal loop. + (AppPat self@(ListPat (x@(SymPat _ _) : _)) args) -> + do + (_, evald) <- eval ctx x ResolveDynamic resolver + case evald of + Left err -> pure (evalError ctx (show err) (xobjInfo root)) + Right x' -> case checkStatic root (xobjInfo root) x' of + Right _ -> evaluateApp root ctx mode resolver (self : args) + Left er -> pure (ctx, Left er) + (AppPat (ListPat _) _) -> evaluateApp root ctx mode resolver form' + (AppPat (SymPat _ _) _) -> evaluateApp root ctx mode resolver form' + (AppPat (XObj other _ _) _) + | isResolvableStaticObj other -> + pure (ctx, (Left (HasStaticCall root (xobjInfo root)))) + [] -> pure (ctx, dynamicNil) + _ -> pure (throwErr (UnknownForm root) ctx (xobjInfo root)) + +-- | Evaluates arrays and static array forms. [one two...] +evaluateArray :: ModalEvaluator +evaluateArray root ctx mode resolver forms = + do + (newCtx, evaled) <- foldlM (evalAndCollect mode resolver) (ctx, Right []) forms + either + (\e -> pure (newCtx, Left e)) + (\x -> pure (replace newCtx root x)) + evaled + where replace :: Context -> XObj -> [XObj] -> (Context, Either EvalError XObj) + replace c (XObj (Arr _) info ty) ys = + (c, Right (XObj (Arr ys) info ty)) + replace c (XObj (StaticArr _) info ty) ys = + (c, Right (XObj (StaticArr ys) info ty)) + replace c x _ = + evalError c (format (GenericMalformed x)) (xobjInfo x) + -- | Evaluates an if form. (if condition true false) evaluateIf :: Evaluator evaluateIf _ ctx resolver (IfPat _ cond true false) = @@ -201,11 +197,11 @@ evaluateIf _ ctx resolver (IfPat _ cond true false) = where boolCheck :: Context -> Obj -> IO (Context, Either EvalError XObj) boolCheck c (Bol b) = eval c (if b then true else false) ResolveStatic resolver boolCheck _ _ = pure $ throwErr (IfContainsNonBool cond) ctx (xobjInfo cond) -evaluateIf root ctx _ _ = pure $ evalError ctx (format (GenericMalformed root)) (xobjInfo root) +evaluateIf root ctx _ _ = pure $ evalError ctx (format (GenericMalformed root)) (xobjInfo root) -- | Evaluates a the form. (the T x) evaluateThe :: Evaluator -evaluateThe root ctx _ (ThePat the t value) = +evaluateThe root ctx _ (ThePat the t value) = let info = xobjInfo root ty = xobjTy root in do (nctx, result) <- expandAll evalDynamic ctx value -- TODO: Why expand all here? @@ -222,11 +218,11 @@ evaluateLet _ ctx mode resolver (LetPat _ (ArrPat bindings) body) = eitherCtx <- foldrM (evalAndUpdateBindings mode resolver) (Right (replaceInternalEnv ctx ni)) binds case eitherCtx of Left err -> pure (ctx, Left err) - Right newCtx -> + Right newCtx -> do (finalCtx, evaledBody) <- eval newCtx body ResolveStatic sresolver let Just e = contextInternalEnv finalCtx parentEnv = envParent e - pure (replaceInternalEnvMaybe finalCtx parentEnv, evaledBody) + pure (replaceInternalEnvMaybe finalCtx parentEnv, evaledBody) where unwrapVar :: [(XObj, XObj)] -> [(String, XObj)] -> [(String, XObj)] unwrapVar [] acc = acc @@ -248,7 +244,7 @@ evaluateFn root ctx _ _ = pure (evalError ctx (format (GenericMalformed root)) ( -- | Evaluates a closure. evaluateClosure :: ModalEvaluator -evaluateClosure _ ctx mode resolver (AppPat (ClosurePat params body c) args) = +evaluateClosure _ ctx mode resolver (AppPat (ClosurePat params body c) args) = do (newCtx, evaledArgs) <- foldlM (evalAndCollect mode resolver) (ctx, Right []) args case evaledArgs of Left err -> pure (newCtx, Left err) @@ -263,7 +259,7 @@ evaluateClosure root ctx _ _ _ = pure (evalError ctx (format (GenericMalformed r -- | Evaluates a dynamic fn form. evaluateDynamicFn :: ModalEvaluator -evaluateDynamicFn _ ctx mode resolver (AppPat (DynamicFnPat _ params body) args) = +evaluateDynamicFn _ ctx mode resolver (AppPat (DynamicFnPat _ params body) args) = do (newCtx, evaledArgs) <- foldlM (evalAndCollect mode resolver) (ctx, Right []) args case evaledArgs of Right okArgs -> apply newCtx body params okArgs @@ -286,21 +282,21 @@ evaluateCommand _ ctx mode resolver (AppPat (CommandPat (UnaryCommandFunction un either (\r -> pure (ctx, Left r)) (unary c . head) result evaluateCommand _ ctx mode resolver (AppPat (CommandPat (BinaryCommandFunction binary) _ _) [x, y]) = do (c, result) <- foldlM (evalAndCollect mode resolver) (ctx, Right []) [x, y] - either - (\r -> pure (ctx, Left r)) - (\r -> let [x', y'] = take 2 r in binary c x' y') - result + either + (\r -> pure (ctx, Left r)) + (\r -> let [x', y'] = take 2 r in binary c x' y') + result evaluateCommand _ ctx mode resolver (AppPat (CommandPat (TernaryCommandFunction ternary) _ _) [x, y, z]) = do (c, result) <- foldlM (evalAndCollect mode resolver) (ctx, Right []) [x, y, z] - either - (\r -> pure (ctx, Left r)) - (\r -> let [x', y', z'] = take 3 r in ternary c x' y' z') + either + (\r -> pure (ctx, Left r)) + (\r -> let [x', y', z'] = take 3 r in ternary c x' y' z') result evaluateCommand _ ctx mode resolver (AppPat (CommandPat (VariadicCommandFunction variadic) _ _) args) = do (c, result) <- foldlM (evalAndCollect mode resolver) (ctx, Right []) args - either - (\r -> pure (ctx, Left r)) - (variadic c) + either + (\r -> pure (ctx, Left r)) + (variadic c) result -- Should be caught during validation evaluateCommand root ctx _ _ (AppPat (CommandPat _ _ _) _) = @@ -339,23 +335,23 @@ evaluateApp root ctx mode resolver (AppPat f' args) = sym@(SymPat _ _) -> go sym mode _ -> pure (evalError ctx (format (GenericMalformed root)) (xobjInfo root)) where - evalAndPushFrame c xobj fun = - eval (pushFrame c root) - (XObj (Lst (fun : args)) (xobjInfo xobj) (xobjTy xobj)) - ResolveStatic + evalAndPushFrame c xobj fun = + eval (pushFrame c root) + (XObj (Lst (fun : args)) (xobjInfo xobj) (xobjTy xobj)) + ResolveStatic resolver go x mode' = do (newCtx, f) <- eval ctx x mode' resolver - either - (pure . const (newCtx, f)) + either + (pure . const (newCtx, f)) (\fun -> do (newCtx', res) <- evalAndPushFrame newCtx x fun pure (popFrame newCtx', res)) f -evaluateApp root ctx _ _ _ = +evaluateApp root ctx _ _ _ = pure (evalError ctx (format (GenericMalformed root)) (xobjInfo root)) -------------------------------------------------------------------------------- --- evaluation folds +-- evaluation folds -- -- These functions should be used as arguments to fold* functions to evaluate -- each form in a list of forms and return a final result. @@ -383,23 +379,34 @@ evalAndCollect mode resolver (ctx', acc) x = -- the evaluation. Stops immediately on error. evalAndUpdateBindings :: ResolveMode -> Resolver -> (String, XObj) -> Either EvalError Context -> IO (Either EvalError Context) evalAndUpdateBindings _ _ _ e@(Left _) = pure e -evalAndUpdateBindings mode resolver (name, xobj) (Right ctx) = +evalAndUpdateBindings mode resolver (name, xobj) (Right ctx) = do let origin = (contextInternalEnv ctx) recFix = (E.recursive origin (Just "let-rec-env") 0) - Right envWithSelf = if isFn xobj - then E.insertX recFix (SymPath [] name) xobj + Right envWithSelf = if isFn xobj + then E.insertX recFix (SymPath [] name) xobj else Right recFix nctx = replaceInternalEnv ctx envWithSelf binderr = error "Failed to eval let binding!!" (newCtx, res) <- eval nctx xobj mode resolver pure $ - either + either Left - (Right . fromRight binderr . bindLetDeclaration (newCtx {contextInternalEnv = origin}) name) + (Right . fromRight binderr . bindLetDeclaration (newCtx {contextInternalEnv = origin}) name) res -------------------------------------------------------------------------------- +-- | Checks whether or not a form is static, returning an error if so. +-- Often, the form being passed to this function is a child or fragment of the +-- form that's actually being evaluated. It's a mistake to return the fragment +-- instead of the form being processed, so this returns Unit to ensure that +-- doesn't happen. +checkStatic :: XObj -> (Maybe Info) -> XObj -> Either EvalError () +checkStatic root info xobj = + if isResolvableStaticObj (xobjObj xobj) + then Left (HasStaticCall root info) + else Right () + macroExpand :: Context -> XObj -> IO (Context, Either EvalError XObj) macroExpand ctx xobj = case xobj of @@ -423,10 +430,10 @@ macroExpand ctx xobj = pure (ctx, Right xobj) XObj (Lst [XObj (Sym (SymPath [] "quote") _) _ _, _]) _ _ -> pure (ctx, Right xobj) - XObj (Lst [XObj (Lst (XObj Macro _ _ : _)) _ _]) _ _ -> + XObj (Lst [XObj (Lst (XObj Macro _ _ : _)) _ _]) _ _ -> evalDynamic ctx xobj XObj (Lst (x@(XObj (Sym _ _) _ _) : args)) i t -> do - (_, f) <- evalDynamic ctx x + (_, f) <- evalDynamic ctx x case f of Right m@(XObj (Lst (XObj Macro _ _ : _)) _ _) -> do (newCtx', res) <- evalDynamic ctx (XObj (Lst (m : args)) i t) diff --git a/src/Obj.hs b/src/Obj.hs index 02f5d9084..c95d5f25a 100644 --- a/src/Obj.hs +++ b/src/Obj.hs @@ -1092,11 +1092,11 @@ wrapInRefTyIfMatchRef MatchValue t = t isResolvableStaticObj :: Obj -> Bool isResolvableStaticObj Def = True isResolvableStaticObj (Defn _) = True -isResolvableStaticObj (External _) = True -isResolvableStaticObj (Deftemplate _) = True -isResolvableStaticObj (Instantiate _) = True -isResolvableStaticObj (Fn _ _) = True isResolvableStaticObj (Interface _ _) = True +isResolvableStaticObj (Instantiate _) = True +isResolvableStaticObj (Deftemplate _) = True +isResolvableStaticObj (External _) = True +isResolvableStaticObj (Match _) = True isResolvableStaticObj Ref = True isResolvableStaticObj _ = False From 2c12128dffeb9ef762890f36a4afbcec56ef8d0a Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Thu, 17 Feb 2022 16:13:39 -0500 Subject: [PATCH 6/8] refactor: cleanup resolver code Remove unused functions and data definitions; add some comments. --- src/Resolver.hs | 196 +++++++++++------------------------------------- 1 file changed, 45 insertions(+), 151 deletions(-) diff --git a/src/Resolver.hs b/src/Resolver.hs index 778296057..383ac9eb5 100644 --- a/src/Resolver.hs +++ b/src/Resolver.hs @@ -6,11 +6,11 @@ -- -- Resolvers are combined using their Semigroup instance, for example: -- --- topLevelResolver <> localDynamicResolver +-- topLevelResolver <> localDynamicResolver -- -- produces a resolver that first attempts to find a symbol at the -- global top level, then attempts to find the symbol (by name only) in the --- Dynamic module. +-- Dynamic module. -- -- Resolvers have default orders. In the case above, the localDynamicResolver is -- of lower order than topLevelResolver, so it will be tried only if @@ -19,7 +19,7 @@ -- One can always tweak the order by setting the order of a resolver explicitly: -- -- topLevelResolver {order = Lower } <> localDynamicResolver {order = Higher} --- +-- -- will result in a resolver that first applies the localDynamicResolver, then, -- if it fails will apply the topLevelResolver. The semigroup instance combines -- resolvers left to right unless the order of the right argument is higher than @@ -49,12 +49,7 @@ import Context -------------------------------------------------------------------------------- -- Data -data LookupPreference - = PreferDynamic - | PreferGlobal - | PreferLocal [SymPath] - deriving (Eq, Show) - +-- | Determines the order in which Resolvers should be chained. data LookupOrder = Higher | Lower deriving(Eq) @@ -64,13 +59,7 @@ instance Ord LookupOrder where compare Lower Lower = EQ compare Higher Higher = EQ -instance Ord LookupPreference where - _ <= PreferDynamic = False - PreferDynamic <= _ = True - (PreferLocal _) <= _ = False - _ <= (PreferLocal _) = True - _ <= _ = True - +-- | Specifies whether we're resolving all or only dynamic symbols. data ResolveMode = ResolveStatic | ResolveDynamic @@ -84,7 +73,8 @@ data Resolver = Resolver { resolverStack :: [String] } -data LookupConstraint +-- | Specifies how a Resolver should traverse environments. +data LookupConstraint = Direct | Children | Full @@ -98,15 +88,23 @@ instance Semigroup Resolver where } else resolver { resolve = \s c -> (resolve resolver') s c <|> (resolve resolver) s c, - resolverStack = (resolverStack resolver') ++ (resolverStack resolver) + resolverStack = (resolverStack resolver') ++ (resolverStack resolver) } instance Show Resolver where show Resolver{resolverStack = s} = intercalate "-> " s +-- | Applies a resolver to find a symbols corresponding binder. +applyResolver :: Resolver -> SymPath -> Context -> Maybe (Context, Binder) +applyResolver resolver spath ctx = + (resolve resolver) spath ctx + +-------------------------------------------------------------------------------- +-- Constructors + -- TODO: Make (E.search.*Binder contextGlobalEnv) impossible. -mkDynamicResolver :: LookupConstraint -> Resolver -mkDynamicResolver Direct = +mkDynamicResolver :: LookupConstraint -> Resolver +mkDynamicResolver Direct = let r (SymPath _ n) ctx = fmap (ctx,) (maybeId (E.getValueBinder (contextGlobalEnv ctx) n)) rname = "LocalDynamicResolver" in Resolver rname Lower r [rname] @@ -121,57 +119,47 @@ mkDynamicResolver Full = rname = "DynamicResolverFull" in Resolver rname Lower r [rname] - mkLocalResolver :: LookupConstraint -> Resolver -mkLocalResolver Direct = +mkLocalResolver Direct = let r (SymPath _ n) ctx = - join $ fmap (\e -> fmap (ctx,) (maybeId (E.getValueBinder e n))) (contextInternalEnv ctx) + join $ fmap (\e -> fmap (ctx,) (maybeId (E.getValueBinder e n))) (contextInternalEnv ctx) rname = "LocalDirectResolver" in Resolver rname Higher r [rname] -mkLocalResolver Children = - let r path ctx = - join $ fmap (\e -> fmap (ctx,) (maybeId (E.findValueBinder e path))) (contextInternalEnv ctx) +mkLocalResolver Children = + let r path ctx = + join $ fmap (\e -> fmap (ctx,) (maybeId (E.findValueBinder e path))) (contextInternalEnv ctx) rname = "LocalChildrenResolver" in Resolver rname Higher r [rname] -mkLocalResolver Full = - let r path ctx = +mkLocalResolver Full = + let r path ctx = join $ fmap (\e -> fmap (ctx,) (maybeId (E.searchValueBinder e path))) (contextInternalEnv ctx) rname = "LocalFullResolver" in Resolver rname Higher r [rname] mkGlobalResolver :: LookupConstraint -> Resolver -mkGlobalResolver Direct = +mkGlobalResolver Direct = let r (SymPath _ n) ctx = fmap (ctx,) (maybeId (E.getValueBinder (contextGlobalEnv ctx) n)) rname = "GlobalDirectResolver" in Resolver rname Lower r [rname] -mkGlobalResolver Children = +mkGlobalResolver Children = let r path ctx = fmap (ctx,) (maybeId (E.findValueBinder (contextGlobalEnv ctx) path)) rname = "GlobalChildrenResolver" in Resolver rname Lower r [rname] -mkGlobalResolver Full = +mkGlobalResolver Full = let r path ctx = fmap (ctx,) (maybeId (E.searchValueBinder (contextGlobalEnv ctx) path)) rname = "GlobalFullResolver" in Resolver rname Lower r [rname] -------------------------------------------------------------------------------- --- Public functions - --- | Resolves a symbol to a local binding that is stored directly in the --- context's internal environment. -localDynamicResolver :: Resolver -localDynamicResolver = mkDynamicResolver Direct - --- | Resolves a symbol to a binding in the global Dynamic module. -globalDynamicResolver :: Resolver -globalDynamicResolver = mkDynamicResolver Children +-- Base resolvers -- | Resolves a symbol to a binding in the local environment if that symbol is -- known to shadow another symbol. localShadowResolver :: [SymPath] -> Resolver -localShadowResolver shadows = +localShadowResolver shadows = let local = mkLocalResolver Direct f = resolve local rname = "LocalShadowResolver" @@ -181,42 +169,11 @@ localShadowResolver shadows = (\spath ctx -> if spath `elem` shadows then (f spath ctx) else Nothing) [rname] --- | Searches the (potentially) stale parents of internal environments for a --- local binding. -localCacheResolver :: Resolver -localCacheResolver = - let cache = (mkLocalResolver Full) - in cache { - resolve = \path@(SymPath p _) ctx -> - if null p - then (resolve cache) path ctx - else Nothing, - resolverName = "LocalCacheResolver", - resolverStack = ["LocalCacheResolver"] - } - --- | Resolves a symbol to a binding that is a direct child of the global --- environment (a top-level binding). -topLevelResolver :: Resolver -topLevelResolver = (mkGlobalResolver Direct) {resolverName = "TopLevelResolver", resolverStack = ["TopLevelResolver"]} - --- | Resolves a symbol to a child of the global environment, possibly in a --- child module of the global environment. -globalResolver :: Resolver -globalResolver = mkGlobalResolver Children - --- | Look everywhere. -universalResolver :: Resolver -universalResolver = - let re = (mkLocalResolver Full <> mkGlobalResolver Full <> mkDynamicResolver Full) - in re {resolverName = "UniversalResolver", - resolverStack = ["UniversalResolver"] ++ tail (resolverStack re)} - -- | Resolves a symbol to a binding in the current module or one of its sub -- modules. currentModuleResolver :: Resolver -currentModuleResolver = - let r (SymPath p n) ctx = +currentModuleResolver = + let r (SymPath p n) ctx = -- TODO: Should not need search here; find should be sufficient. fmap (ctx,) (maybeId (E.searchValueBinder (contextGlobalEnv ctx) (SymPath ((contextPath ctx)++p) n))) rname = "CurrentModuleResolver" @@ -224,86 +181,23 @@ currentModuleResolver = -- | Resolves a symbol to a binding in one of the modules currently "used". usedModuleResolver :: Resolver -usedModuleResolver = - let r (SymPath p n) ctx = +usedModuleResolver = + let r (SymPath p n) ctx = let genv = (contextGlobalEnv ctx) usemods = (Set.toList (envUseModules genv)) searches = map (\(SymPath p' n') -> fmap (ctx,) (maybeId (E.searchValueBinder genv (SymPath (p'++(n':p)) n)))) usemods - in foldl (<|>) Nothing searches + in foldl (<|>) Nothing searches rname = "UsedModuleResolver" in Resolver rname Higher r [rname] -- | Resolves a symbol to a binding in the global type environment. -typeResolver :: Resolver -typeResolver = +typeResolver :: Resolver +typeResolver = let r path ctx = fmap (ctx,) (maybeId (lookupBinderInTypeEnv ctx path)) rname = "TypeResolver" in Resolver rname Lower r [rname] --- | Standard sequence of resolvers to try when no other resolutions succeed. --- Always has the lowest order. -fallbackResolver :: Resolver -fallbackResolver = - currentModuleResolver <> usedModuleResolver <> universalResolver <> typeResolver {order = Lower} - --- | Sequence of resolvers to try when resolving symbols in function bodies. -functionBodySymbolResolver :: [SymPath] -> Resolver -functionBodySymbolResolver shadows = - localShadowResolver shadows <> standardResolver - -applyResolver :: Resolver -> SymPath -> Context -> Maybe (Context, Binder) -applyResolver resolver spath ctx = - (resolve resolver) spath ctx - --- | Normally, local and global resolvers take precedence over dynamic --- resolvers. This resolver inverts this behavior, combining a given resolver --- with a dynamic resolver that always takes precedence. -forceDynamicResolver :: Resolver -> Resolver -forceDynamicResolver resolver = - localDynamicResolver {order = Higher} - <> globalDynamicResolver {order = Higher} - <> resolver - --- | Given a resolver, returns a new resolver that will attempt to resolve --- symbols globally first, regardless of the input resolver's precedence. -forceGlobalResolver :: Resolver -> Resolver -forceGlobalResolver resolver = - globalResolver {order = Higher} <> resolver - --- | Resolve a symbol to a binding in the context's local environment. -localResolver :: Resolver -localResolver = - mkLocalResolver Children - -dynamicResolver :: Resolver -dynamicResolver = - localDynamicResolver <> globalDynamicResolver - -standardResolver :: Resolver -standardResolver = - -- n.b. we need to call the cache resolver specifically for the case: - -- primitiveEval, during evaluation of the *arg* argument. - -- - -- This is a bit strange--in theory, if the environment parents are correct, - -- we should never need to rely on the parent of an internal environment since - -- its parent should == the global environment. - localResolver <> localCacheResolver <> globalDynamicResolver {order = Higher} <> fallbackResolver - -standardResolverNoCache :: Resolver -standardResolverNoCache = - localResolver <> globalDynamicResolver {order = Higher} <> fallbackResolver - --- | -staticEnvResolver :: Env -> Resolver -staticEnvResolver e = - let resolver = (mkLocalResolver Children) - in resolver { - resolve = \path ctx -> (resolve resolver) path ctx {contextInternalEnv = Just e}, - resolverName = "StaticEnvResolver", - resolverStack = ["StaticEnvResolver"] - } - -------------------------------------------------------------------------------- -- "legacy" resolvers. -- These are 1:1 translations to the old implementation of direct lookups in @@ -313,17 +207,17 @@ staticEnvResolver e = -- The following current issue prevents us: -- There are several lookups that seem to rely on *search* methods to find the -- right binding, these methods traverse cached parents. --- +-- -- For example, a call to `doc ` in a module M results in a binding -- M. in the global environment. Finding this in a defn call is -- incorrect, since defn does not expect qualified names. So, the defn call's -- name needs to remain the same. legacyFull :: Resolver -legacyFull = +legacyFull = ((mkDynamicResolver Full) {order=Higher}) <> (mkLocalResolver Full) { - resolve = \s@(SymPath p _) c -> if null p then (resolve (mkLocalResolver Full)) s c else Nothing + resolve = \s@(SymPath p _) c -> if null p then (resolve (mkLocalResolver Full)) s c else Nothing } <> (mkGlobalResolver Full) {order=Higher} <> currentModuleResolver @@ -331,16 +225,16 @@ legacyFull = <> usedModuleResolver legacyPreferDynamic :: Resolver -legacyPreferDynamic = - (mkDynamicResolver Children) {order=Higher} +legacyPreferDynamic = + (mkDynamicResolver Children) {order=Higher} <> legacyFull legacyPreferGlobal :: Resolver -legacyPreferGlobal = +legacyPreferGlobal = mkGlobalResolver Children <> legacyFull legacyLocal :: [SymPath] -> Resolver -legacyLocal shadows = - localShadowResolver shadows +legacyLocal shadows = + localShadowResolver shadows <> legacyPreferDynamic From e517b829e5a2d4e5b8c3ab616444b516457d9280 Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Thu, 17 Feb 2022 18:11:29 -0500 Subject: [PATCH 7/8] chore: fix typo in src/Eval.hs Co-authored-by: Veit Heller --- src/Eval.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Eval.hs b/src/Eval.hs index 8b3ee9c48..aa338e011 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -559,7 +559,7 @@ executeCommand ctx@(Context env _ _ _ _ _ _ _) xobj = -- when given a naked binding (no path) as an argument; (s-expr inc) -- NOTE! The "ResolveDynamic" override call to eval PreferDynamic (which is -- otherwise just evalDynamic) is somehow crucial. Without it, function - -- names in modules are fully expanded to thier full names, breaking defns. + -- names in modules are fully expanded to their full names, breaking defns. -- This is because of the calls to "isResolvableStaticXObj" in eval' on list -- patterns -- this alters the behavior of succssiveEval such that it drops -- certain results? I think? It's a hunch. This behavior is incredibly From c6f5f357860e27753cedcc410018426b4ddaad9a Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Thu, 17 Feb 2022 18:11:50 -0500 Subject: [PATCH 8/8] chore: fix typo in src/Resolver.hs Co-authored-by: Veit Heller --- src/Resolver.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Resolver.hs b/src/Resolver.hs index 383ac9eb5..1dd934ccf 100644 --- a/src/Resolver.hs +++ b/src/Resolver.hs @@ -33,7 +33,7 @@ -- If you need to debug resolvers, thier show instance prints a string depicting -- the order in which they were run, e.g.: -- --- TopLevelReolver -> "LocalDynamicResolver" +-- TopLevelResolver -> "LocalDynamicResolver" module Resolver where import Obj