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..aa338e011 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,15 @@ import TypeError import Types import Util import Prelude hiding (exp, mod) +import Resolver --- TODO: Formalize "lookup order preference" a bit better and move into --- the Context module. -data LookupPreference - = PreferDynamic - | PreferGlobal - | PreferLocal [SymPath] - deriving (Show) +-- 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 -data Resolver - = ResolveGlobal - | ResolveLocal - -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 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,345 +61,351 @@ 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 _ _) mode resolver = case o of - Lst body -> eval' body - Sym spath@(SymPath p n) _ -> - pure $ - case resolver of - ResolveGlobal -> unwrapLookup ((tryAllLookups preference) >>= checkStatic) - ResolveLocal -> unwrapLookup (tryAllLookups preference) - where - 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) - -- 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)) - Arr objs -> do - (newCtx, evaled) <- foldlM successiveEval (ctx, Right []) objs - pure - ( newCtx, - do - ok <- evaled - Right (XObj (Arr ok) info ty) - ) - StaticArr objs -> do - (newCtx, evaled) <- foldlM successiveEval (ctx, Right []) objs - pure - ( newCtx, - do - ok <- evaled - Right (XObj (StaticArr ok) info ty) - ) + 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 - 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 + +-------------------------------------------------------------------------------- +-- 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 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 - eval' form = - case validate form of - Left e -> pure (evalError ctx (format e) (xobjInfo xobj)) - Right form' -> - case form' of - (IfPat _ _ _ _) -> evaluateIf 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' - (WithPat _ sym@(SymPat path _) forms) -> specialCommandWith ctx sym path forms - (DoPat _ forms) -> evaluateSideEffects 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 preference ResolveGlobal - case evald of - Left err -> pure (evalError ctx (show err) (xobjInfo xobj)) - Right x' -> case checkStatic' x' of - 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, 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' - successiveEval (ctx', acc) x = - case acc of - Left _ -> pure (ctx', acc) - Right l -> do - (newCtx, evald) <- eval ctx' x preference 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 - case evd of - Right cond' -> - case xobjObj cond' of - Bol b -> eval newCtx (if b then true else false) preference ResolveLocal - _ -> - 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? - 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 - (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 - ) - 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 preference 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 ResolveLocal - sym@(SymPat _ _) -> go sym resolver - _ -> pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj)) - where - go x resolve = +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 - (newCtx, f) <- eval ctx x preference resolve - case f of - Right fun -> do - (newCtx', res) <- eval (pushFrame newCtx xobj) (XObj (Lst (fun : args)) (xobjInfo x) (xobjTy x)) preference ResolveLocal - 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 preference resolver + (_, 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) = + 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, 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 + +-------------------------------------------------------------------------------- + +-- | 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 = @@ -436,12 +430,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 +494,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 +557,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 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 + -- 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 +658,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 +702,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 +768,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 +978,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 +996,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 +1058,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 +1091,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 +1099,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 +1153,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 +1162,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/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 diff --git a/src/Resolver.hs b/src/Resolver.hs new file mode 100644 index 000000000..1dd934ccf --- /dev/null +++ b/src/Resolver.hs @@ -0,0 +1,240 @@ +{-# 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.: +-- +-- TopLevelResolver -> "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 + +-- | Determines the order in which Resolvers should be chained. +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 + +-- | Specifies whether we're resolving all or only dynamic symbols. +data ResolveMode + = ResolveStatic + | ResolveDynamic + deriving(Show) + +-- | 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] +} + +-- | Specifies how a Resolver should traverse environments. +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 + +-- | 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 = + 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] + +-------------------------------------------------------------------------------- +-- 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 = + 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] + +-- | 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] + +-------------------------------------------------------------------------------- +-- "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