diff --git a/repl/Main.hs b/repl/Main.hs index da02cbab..319a0309 100644 --- a/repl/Main.hs +++ b/repl/Main.hs @@ -4,11 +4,9 @@ {-# LANGUAGE ViewPatterns #-} module Main where -import Control.Exception +import Control.Exception hiding (evaluate) import Control.Lens hiding (argument) import Control.Monad -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Except import Data.Foldable (for_) import Data.IORef @@ -148,7 +146,6 @@ repl ctx startWorld = do prettyPrint expr putStrLn "" currentWorld <- readIORef theWorld - runExceptT (runReaderT (runEval (eval expr)) (phaseEnv runtime currentWorld)) >>= - \case - Left evalErr -> print evalErr - Right val -> prettyPrintLn val + case evaluateIn (phaseEnv runtime currentWorld) expr of + Left evalErr -> print $ erroneousValue $ projectError evalErr + Right val -> prettyPrintLn val diff --git a/src/Evaluator.hs b/src/Evaluator.hs index d5aa114c..026a4603 100644 --- a/src/Evaluator.hs +++ b/src/Evaluator.hs @@ -1,20 +1,77 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GADTSyntax #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ParallelListComp #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} -module Evaluator where + +{- Note [The CEK interpreter]: + +The Klister interpreter is a straightforward implementation of a CEK +interpreter. The interpreter keeps three kinds of state: + +-- C: Control ::= The thing that is being evaluated +-- E: Environment ::= The interpreter environment +-- K: Kontinuation ::= The syntactic context of the thing that is being interpreted + +Why a CEK? A CEK interpreter allows us to have precise control over the +evaluation of a klister program. For example, because the interpreter keeps a +reference to the kontinuation we can provide stack traces. This handle also +makes a more advanced debugger possible. Upon an evaluation error we could save +the kontinuation stack, over write a variable in the environment a la common +lisp or even rewind the evaluation + +See Matthias Felleison's course website for a good reference: +https://felleisen.org/matthias/4400-s20/lecture23.html + +The bird's eye view: + +The evaluator crawl's the input AST and progresses in three modes: + +-- 'Down': meaning that the evaluator is searching for a redex to evaluate and +-- therefore moving "down" the AST. + +-- 'Up': meaning that the evaluator has evaluated some redex to a value and is +-- passing that value "up" the execution stack. + +-- 'Er': meaning that something has gone wrong, the stack is captured and the Er +-- will float up to be handled by the caller of the evaluator. + +All interesting things happen by matching on 'Kont', the continuation. This +allows the evaluator to know exactly what needs to happen in order to continue. + +-- TODO: #108 describe the how the debugger hooks in + +-} + +module Evaluator + ( EvalError (..) + , EvalResult (..) + , TypeError (..) + , evaluate + , evaluateIn + , evaluateWithExtendedEnv + , evalErrorType + , evalErrorText + , projectError + , erroneousValue + , applyInEnv + , apply + , doTypeCase + , try + ) where import Control.Lens hiding (List, elements) -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Except (MonadError(throwError)) -import Control.Monad.Reader (MonadReader(ask, local)) -import Control.Monad.Trans.Except (ExceptT) -import Control.Monad.Trans.Reader (ReaderT) +import Control.Exception hiding (TypeError, evaluate) +import Data.Data (Typeable) import Data.Text (Text) import qualified Data.Text as T +import Data.List (foldl') +import Datatype import Core import Env import ShortShow @@ -23,6 +80,14 @@ import Syntax.SrcLoc import Type import Value +-- ----------------------------------------------------------------------------- +-- Interpreter Data Types + + +data EvalResult + = ExampleResult SrcLoc VEnv Core (Scheme Ty) Value + | IOResult (IO ()) + -- TODO: more precise representation type Type = Text @@ -38,8 +103,343 @@ data EvalError | EvalErrorType TypeError | EvalErrorCase SrcLoc Value | EvalErrorUser Syntax - deriving (Show) + | EvalErrorIdent Value + deriving (Show, Typeable) makePrisms ''EvalError +instance Exception EvalError + +-- | The Kontinuation type. The naming convention InFoo means that the subject +-- of evaluation in the CEK machine is Foo. For example, when the continuation +-- is 'InArg' the subject of evaluation is the argument of the function and the +-- continuation holds the un-evaluated function symbol in its first field. +data Kont where + + Halt :: Kont + -- ^ Marks the evaluator finishing + + -- functions + InArg :: !(CoreF TypePattern ConstructorPattern Core) -> !VEnv -> !Kont -> Kont + -- ^ The argument is being evaluated, so hold onto the function symbol. + InFun :: !Value -> !VEnv -> !Kont -> Kont + -- ^ The function is being evaluated, so hold onto the evaluated argument. + + InLetDef :: !Ident -> !Var -> !(CoreF TypePattern ConstructorPattern Core) -> !VEnv -> !Kont -> Kont + -- ^ Evaluating the let def + + -- constructors + InCtor :: !Constructor -> ![CoreF TypePattern ConstructorPattern Core] -> ![Value] -> !VEnv -> !Kont -> Kont + + -- Cases + InCaseScrut :: ![(SyntaxPattern, Core)] -> !SrcLoc -> !VEnv -> !Kont -> Kont + InDataCaseScrut :: ![(ConstructorPattern, Core)] -> !SrcLoc -> !VEnv -> !Kont -> Kont + InTypeCaseScrut :: ![(TypePattern, Core)] -> !SrcLoc -> !VEnv -> !Kont -> Kont + + -- lists + InConsHd :: !Core -> !(CoreF TypePattern ConstructorPattern Core) -> !VEnv -> !Kont -> Kont + InConsTl :: !Core -> !Syntax -> !VEnv -> !Kont -> Kont + InList :: !Core -> ![Core] -> ![Syntax] -> !VEnv -> !Kont -> Kont + + -- idents + InIdent :: !Core -> !VEnv -> !Kont -> Kont + InIdentEqL :: !HowEq -> !Core -> !VEnv -> !Kont -> Kont + InIdentEqR :: !HowEq -> !Value -> !VEnv -> !Kont -> Kont + + -- Macros + InPureMacro :: !VEnv -> !Kont -> Kont + InBindMacroHd :: !Core -> !VEnv -> !Kont -> Kont + InBindMacroTl :: !MacroAction -> !VEnv -> !Kont -> Kont + + -- atomics + InInteger :: !Core -> !VEnv -> !Kont -> Kont + InString :: !Core -> !VEnv -> !Kont -> Kont + InLoc :: !Core -> !VEnv -> !Kont -> Kont + InLocStx :: !SrcLoc -> !VEnv -> !Kont -> Kont + + -- scope + InScope :: !(ExprF Syntax) -> !VEnv -> !Kont -> Kont + + -- logs and errors + InLog :: !VEnv -> !Kont -> Kont + InError :: !VEnv -> !Kont -> Kont + + + InSyntaxErrorMessage :: ![Core] -> !VEnv -> !Kont -> Kont + InSyntaxErrorLocations :: !Syntax -> ![Core] -> ![Syntax] -> !VEnv -> !Kont -> Kont + +-- | The state of the evaluator +data EState where + Down :: !(CoreF TypePattern ConstructorPattern Core) -> !VEnv -> !Kont -> EState + -- ^ 'Down', we are searching the AST for a redux and building up the stack of + -- continuations + Up :: !Value -> !VEnv -> !Kont -> EState + -- ^ 'Up', means we have performed some evaluation on a redex and are + -- returning a value up the stack + Er :: !EvalError -> !VEnv -> !Kont -> EState + -- ^ 'Er', meaning that we are in an error state and running the debugger + + +-- ----------------------------------------------------------------------------- +-- The evaluator. The CEK machine is a state machine, the @step@ function moves +-- the state machine a single step of evaluation. This is the heart of the +-- evaluator. + + +-- | Make a single step transition in the CEK state machine. +step :: EState -> EState +step done@(Up _val _ Halt) = done + +-- for now we just bail out. Once we have a debugger we'll do something more +-- advanced. +step done@(Er _err _env _k) = done + +-- Upsweep, returning a value after evaluating a redex +step (Up v e k) = + case k of + -- functions + -- we evaluated the arg to get a closed so now we evaluate the fun + (InArg c env kont) -> Down c env (InFun v e kont) + -- we evaluated the fun so now do the application + (InFun val env kont) -> applyAsClosure env v val kont + + + -- lets + -- we have the value for the def, now eval the body + (InLetDef id' var body env kont) -> Down body (extend id' var v env) kont + + -- done, FIXME use a banker's queue instead of a list + (InCtor c [] v_args _env kont) -> Up (ValueCtor c (reverse $ v : v_args)) e kont + -- still processing + (InCtor c (a:as) vs env kont) -> Down a env (InCtor c as (v:vs) env kont) + + + -- Cases + (InCaseScrut cs loc env kont) -> doCase loc v cs env kont + (InDataCaseScrut cs loc env kont) -> doDataCase loc v cs env kont + (InTypeCaseScrut cs loc env kont) -> + evalAsType v + (\good -> Up (ValueMacroAction $ MacroActionTypeCase e loc good cs) env kont) + (\err -> Er err env kont) + + + -- Idents + (InIdent scope env kont) -> case v of + ValueSyntax stx -> + case _unSyntax stx of + (Stx _ _ expr) -> case expr of + Integer _ -> + Er (EvalErrorType + $ TypeError { _typeErrorExpected = "id" + , _typeErrorActual = "integer" + }) e k + String _ -> + Er (EvalErrorType + $ TypeError { _typeErrorExpected = "id" + , _typeErrorActual = "string" + }) e k + List _ -> + Er (EvalErrorType + $ TypeError { _typeErrorExpected = "id" + , _typeErrorActual = "list" + }) e k + name@(Id _) -> Down (unCore scope) env (InScope name env kont) + other -> Er (EvalErrorIdent other) e k + (InIdentEqL how r env kont) -> Down (unCore r) env (InIdentEqR how v env kont) + (InIdentEqR how lv env kont) -> Up (ValueMacroAction $ MacroActionIdentEq how lv v) env kont + + -- Short circuit to speed this up, we could issue an Down and do this recursively + (InScope expr env kont) -> + evalAsSyntax v + (\(Syntax (Stx scopeSet loc _)) -> Up (ValueSyntax $ Syntax $ Stx scopeSet loc expr) env kont) + (\err -> Er err env kont) + + + -- pairs + (InConsHd scope tl env kont) -> + evalAsSyntax v + (\good -> Down tl env (InConsTl scope good env kont)) + (\err -> Er err env kont) + (InConsTl scope hd env kont) -> + evalAsSyntax v + (\(Syntax (Stx _ _ expr)) -> + case expr of + List tl -> Down (unCore scope) env (InScope (List $ hd : tl) env kont) + String _ -> + Er (EvalErrorType + $ TypeError { _typeErrorExpected = "list" + , _typeErrorActual = "string" + }) e k + Id _ -> Er (EvalErrorType + $ TypeError { _typeErrorExpected = "list" + , _typeErrorActual = "id" + }) e k + Integer _ -> Er (EvalErrorType + $ TypeError { _typeErrorExpected = "list" + , _typeErrorActual = "integer" + }) e k + ) + (\err -> Er err env kont) + + + -- lists + -- base case + (InList scope [] dones env kont) -> + evalAsSyntax v + (\good -> Down (unCore scope) e (InScope (List $ reverse $ good : dones) env kont)) + (\err -> Er err env kont) + -- still some todo + (InList scope (el:els) dones env kont) -> + evalAsSyntax v + (\good -> Down (unCore el) env (InList scope els (good : dones) env kont)) + (\err -> Er err env kont) + + + -- Macros + (InPureMacro env kont) -> Up (ValueMacroAction $ MacroActionPure v) env kont + (InBindMacroHd tl env kont) -> + evalAsMacroAction v + (\good -> Down (unCore tl) env (InBindMacroTl good env kont)) + (\err -> Er err env kont) + + (InBindMacroTl macroAction env kont) -> + evalAsClosure v + (\good -> Up (ValueMacroAction $ MacroActionBind macroAction good) env kont) + (\err -> Er err env kont) + + + -- Syntax and Atomics + (InInteger scope env kont) -> + evalAsInteger v + (\good -> Down (unCore scope) env (InScope (Integer good) env kont)) + (\err -> Er err env kont) + (InString scope env kont) -> + evalAsString v + (\good -> Down (unCore scope) env (InScope (String good) env kont)) + (\err -> Er err env kont) + (InLoc stx env kont) -> + evalAsSyntax v + (\(Syntax (Stx _ newLoc _)) -> Down (unCore stx) env (InLocStx newLoc env kont) ) + (\err -> Er err env kont) + (InLocStx loc env kont) -> + evalAsSyntax v + (\(Syntax (Stx scs _ contents)) -> Up (ValueSyntax $ Syntax $ Stx scs loc contents) env kont) + (\err -> Er err env kont) + (InLog env kont) -> + evalAsSyntax v + (\good -> Up (ValueMacroAction (MacroActionLog good)) env kont) + (\err -> Er err env kont) + + + -- Errors + (InError env kont) -> + evalAsSyntax v + (\good -> Er (EvalErrorUser good) env kont) + (\err -> Er err env kont) + (InSyntaxErrorMessage locs env kont) -> + evalAsSyntax v + (\msg_syn -> + case locs of + -- done + [] -> Up (ValueMacroAction $ MacroActionSyntaxError + (SyntaxError { _syntaxErrorMessage = msg_syn + , _syntaxErrorLocations = mempty + })) env kont + (l:ls) -> Down (unCore l) env (InSyntaxErrorLocations msg_syn ls mempty env kont) + ) + (\err -> Er err env kont) + -- done + (InSyntaxErrorLocations msg_syn [] dones env kont) -> + Up (ValueMacroAction + $ MacroActionSyntaxError (SyntaxError { _syntaxErrorMessage = msg_syn + , _syntaxErrorLocations = dones + })) env kont + (InSyntaxErrorLocations msg (l:ls) dones env kont) -> + evalAsSyntax v + (\good -> Down (unCore l) env (InSyntaxErrorLocations msg ls (good : dones) env kont)) + (\err -> Er err env kont) + +-- the downsweep, searching for a redex to evaluate. +step (Down c env k) = + case c of + + -- atoms + (CoreString s) -> Up (ValueString s) env k + (CoreInteger i) -> Up (ValueInteger i) env k + (CoreIntegerSyntax (ScopedInteger int scope)) -> Down (unCore int) env (InInteger scope env k) + (CoreStringSyntax (ScopedString str scope)) -> Down (unCore str) env (InString scope env k) + (CoreSyntax s) -> Up (ValueSyntax s) env k + (CoreError what) -> Down (unCore what) env (InError env k) + (CoreEmpty (ScopedEmpty scope)) -> Down (unCore scope) env (InScope (List mempty) env k) + CoreMakeIntroducer -> Up (ValueMacroAction MacroActionIntroducer) env k + CoreWhichProblem -> Up (ValueMacroAction MacroActionWhichProblem) env k + + + -- variables and binders + (CoreVar var) -> + case lookupVal var env of + Just val -> Up val env k + _ -> Er (EvalErrorUnbound var) env k + + (CoreLet ident var def body) -> + Down (unCore def) env (InLetDef ident var (unCore body) env k) + + (CoreLetFun fIdent fVar argIdent argVar def body) -> + let vFun = ValueClosure $ FO $ FOClosure + { _closureEnv = Env.insert fVar fIdent vFun env + , _closureIdent = argIdent + , _closureVar = argVar + , _closureBody = def + } + newEnv = Env.insert fVar fIdent vFun env + in Down (unCore body) newEnv k + + (CoreCtor con args) -> case args of + -- just a symbol, shortcut out + [] -> Up (ValueCtor con mempty) env k + -- process fields left to right + (f:fs) -> Down (unCore f) env (InCtor con (fmap unCore fs) mempty env k) + + + -- lambdas and application + (CoreLam ident var body) -> + let lam = ValueClosure $ FO $ FOClosure + { _closureEnv = env + , _closureIdent = ident + , _closureVar = var + , _closureBody = body + } + in Up lam env k + (CoreApp fun arg) -> Down (unCore arg) env (InArg (unCore fun) env k) + + + -- cases + (CoreCase loc scrutinee cases) -> Down (unCore scrutinee) env (InCaseScrut cases loc env k) + (CoreDataCase loc scrutinee cases) -> Down (unCore scrutinee) env (InDataCaseScrut cases loc env k) + (CoreTypeCase loc scrut cases) -> Down (unCore scrut) env (InTypeCaseScrut cases loc env k) + + (CoreIdent (ScopedIdent ident scope)) -> Down (unCore ident) env (InIdent scope env k) + (CoreIdentEq how l r) -> Down (unCore l) env (InIdentEqL how r env k) + + (CoreCons (ScopedCons hd tl scope)) -> Down (unCore hd) env (InConsHd scope (unCore tl) env k) + -- empty, short circuit + (CoreList (ScopedList ls scope)) -> case ls of + [] -> Down (unCore scope) env (InScope (List []) env k) + (e:es) -> Down (unCore e) env (InList scope es mempty env k) + (CoreReplaceLoc loc stx) -> Down (unCore loc) env (InLoc stx env k) + + + -- macros + (CorePureMacro arg) -> Down (unCore arg) env (InPureMacro env k) + (CoreBindMacro hd tl) -> Down (unCore hd) env (InBindMacroHd tl env k) + + + -- others + (CoreLog msg) -> Down (unCore msg) env (InLog env k) + (CoreSyntaxError err) -> + Down (unCore $ _syntaxErrorMessage err) env (InSyntaxErrorMessage (_syntaxErrorLocations err) env k) + + +-- ----------------------------------------------------------------------------- +-- Helper Functions evalErrorText :: EvalError -> Text evalErrorText (EvalErrorUnbound x) = "Unbound: " <> T.pack (show x) @@ -50,313 +450,221 @@ evalErrorText (EvalErrorCase loc val) = evalErrorText (EvalErrorUser what) = T.pack (shortShow (stxLoc what)) <> ":\n\t" <> syntaxText what +evalErrorText (EvalErrorIdent v) = "Attempt to bind identifier to non-value: " <> valueText v -newtype Eval a = Eval - { runEval :: ReaderT VEnv (ExceptT EvalError IO) a } - deriving (Functor, Applicative, Monad, - MonadReader VEnv, MonadError EvalError, - MonadIO) +type ContinueWith a = a -> EState +type OnFailure = EvalError -> EState -withEnv :: VEnv -> Eval a -> Eval a -withEnv = local . const +evalAsClosure :: Value -> ContinueWith Closure -> OnFailure -> EState +evalAsClosure closure_to_be on_success on_error = + case closure_to_be of + ValueClosure closure -> on_success closure + other -> on_error (evalErrorType "function" other) -withExtendedEnv :: Ident -> Var -> Value -> Eval a -> Eval a -withExtendedEnv n x v act = local (Env.insert x n v) act +evalAsInteger :: Value -> ContinueWith Integer -> OnFailure -> EState +evalAsInteger int_to_be on_success on_error = + case int_to_be of + ValueInteger i -> on_success i + other -> on_error (evalErrorType "integer" other) -withManyExtendedEnv :: [(Ident, Var, Value)] -> Eval a -> Eval a -withManyExtendedEnv exts act = local (inserter exts) act - where - inserter [] = id - inserter ((n, x, v) : rest) = Env.insert x n v . inserter rest +evalAsSyntax :: Value -> ContinueWith Syntax -> OnFailure -> EState +evalAsSyntax syn_to_be on_success on_error = + case syn_to_be of + ValueSyntax syntax -> on_success syntax + other -> on_error (evalErrorType "syntax" other) +evalAsString :: Value -> ContinueWith Text -> OnFailure -> EState +evalAsString str_to_be on_success on_error = + case str_to_be of + ValueString str -> on_success str + other -> on_error (evalErrorType "string" other) -data EvalResult - = ExampleResult SrcLoc VEnv Core (Scheme Ty) Value - | IOResult (IO ()) +evalAsMacroAction :: Value -> (MacroAction -> EState) -> (EvalError -> EState) -> EState +evalAsMacroAction v on_success on_error = case v of + ValueMacroAction macroAction -> on_success macroAction + other -> on_error (evalErrorType "macro action" other) + +evalAsType :: Value -> ContinueWith Ty -> OnFailure -> EState +evalAsType v on_success on_error = + case v of + ValueType t -> on_success t + other -> on_error (evalErrorType "type" other) -apply :: Closure -> Value -> Eval Value -apply (FO (FOClosure {..})) value = do +applyInEnv :: VEnv -> Closure -> Value -> Either EState Value +applyInEnv old_env (FO (FOClosure {..})) value = + let env = Env.insert _closureVar + _closureIdent + value + (_closureEnv <> old_env) + in evaluateIn env _closureBody +applyInEnv _ (HO prim) value = return $! prim value + +apply :: Closure -> Value -> Either EState Value +apply (FO (FOClosure {..})) value = let env = Env.insert _closureVar _closureIdent value _closureEnv - withEnv env $ - eval _closureBody -apply (HO prim) value = pure (prim value) - -eval :: Core -> Eval Value -eval (Core (CoreVar var)) = do - env <- ask - case lookupVal var env of - Just value -> pure value - _ -> throwError $ EvalErrorUnbound var -eval (Core (CoreLet ident var def body)) = do - val <- eval def - env <- ask - withEnv (Env.insert var ident val env) (eval body) -eval (Core (CoreLetFun funIdent funVar argIdent argVar def body)) = do - env <- ask - let vFun = - ValueClosure $ FO $ FOClosure - { _closureEnv = Env.insert funVar funIdent vFun env - , _closureIdent = argIdent - , _closureVar = argVar - , _closureBody = def - } - withEnv (Env.insert funVar funIdent vFun env) (eval body) -eval (Core (CoreLam ident var body)) = do - env <- ask - pure $ ValueClosure $ FO $ FOClosure - { _closureEnv = env - , _closureIdent = ident - , _closureVar = var - , _closureBody = body - } -eval (Core (CoreApp fun arg)) = do - closure <- evalAsClosure fun - value <- eval arg - apply closure value -eval (Core (CoreCtor c args)) = - ValueCtor c <$> traverse eval args -eval (Core (CoreDataCase loc scrut cases)) = do - value <- eval scrut - doDataCase loc value cases -eval (Core (CoreString str)) = pure (ValueString str) -eval (Core (CoreError what)) = do - msg <- evalAsSyntax what - throwError $ EvalErrorUser msg -eval (Core (CorePureMacro arg)) = do - value <- eval arg - pure $ ValueMacroAction - $ MacroActionPure value -eval (Core (CoreBindMacro hd tl)) = do - macroAction <- evalAsMacroAction hd - closure <- evalAsClosure tl - pure $ ValueMacroAction - $ MacroActionBind macroAction closure -eval (Core (CoreSyntaxError syntaxErrorExpr)) = do - syntaxErrorValue <- traverse evalAsSyntax syntaxErrorExpr - pure $ ValueMacroAction - $ MacroActionSyntaxError syntaxErrorValue -eval (Core (CoreIdentEq how e1 e2)) = - ValueMacroAction <$> (MacroActionIdentEq how <$> eval e1 <*> eval e2) -eval (Core (CoreLog msg)) = do - msgVal <- evalAsSyntax msg - return $ ValueMacroAction (MacroActionLog msgVal) -eval (Core CoreMakeIntroducer) = - return $ ValueMacroAction MacroActionIntroducer -eval (Core CoreWhichProblem) = do - return $ ValueMacroAction MacroActionWhichProblem -eval (Core (CoreInteger i)) = - pure $ ValueInteger i -eval (Core (CoreSyntax syntax)) = do - pure $ ValueSyntax syntax -eval (Core (CoreCase loc scrutinee cases)) = do - v <- eval scrutinee - doCase loc v cases -eval (Core (CoreIdent (ScopedIdent ident scope))) = do - identSyntax <- evalAsSyntax ident - case identSyntax of - Syntax (Stx _ _ expr) -> - case expr of - Integer _ -> - throwError $ EvalErrorType $ TypeError - { _typeErrorExpected = "id" - , _typeErrorActual = "integer" - } - String _ -> - throwError $ EvalErrorType $ TypeError - { _typeErrorExpected = "id" - , _typeErrorActual = "string" - } - List _ -> - throwError $ EvalErrorType $ TypeError - { _typeErrorExpected = "id" - , _typeErrorActual = "list" - } - Id name -> withScopeOf scope $ Id name -eval (Core (CoreEmpty (ScopedEmpty scope))) = withScopeOf scope (List []) -eval (Core (CoreCons (ScopedCons hd tl scope))) = do - hdSyntax <- evalAsSyntax hd - tlSyntax <- evalAsSyntax tl - case tlSyntax of - Syntax (Stx _ _ expr) -> - case expr of - List vs -> withScopeOf scope $ List $ hdSyntax : vs - String _ -> - throwError $ EvalErrorType $ TypeError - { _typeErrorExpected = "list" - , _typeErrorActual = "string" - } - Id _ -> - throwError $ EvalErrorType $ TypeError - { _typeErrorExpected = "list" - , _typeErrorActual = "id" - } - Integer _ -> - throwError $ EvalErrorType $ TypeError - { _typeErrorExpected = "list" - , _typeErrorActual = "integer" - } -eval (Core (CoreList (ScopedList elements scope))) = do - vec <- List <$> traverse evalAsSyntax elements - withScopeOf scope vec -eval (Core (CoreIntegerSyntax (ScopedInteger int scope))) = do - intV <- evalAsInteger int - withScopeOf scope (Integer intV) -eval (Core (CoreStringSyntax (ScopedString str scope))) = do - strV <- evalAsString str - withScopeOf scope (String strV) -eval (Core (CoreReplaceLoc loc stx)) = do - Syntax (Stx _ newLoc _) <- evalAsSyntax loc - Syntax (Stx scs _ contents) <- evalAsSyntax stx - return $ ValueSyntax $ Syntax $ Stx scs newLoc contents -eval (Core (CoreTypeCase loc scrut cases)) = do - ty <- evalAsType scrut - env <- ask - return $ ValueMacroAction $ MacroActionTypeCase env loc ty cases - -evalErrorType :: Text -> Value -> Eval a + in evaluateIn env _closureBody +apply (HO prim) value = return $! prim value + +applyAsClosure :: VEnv -> Value -> Value -> Kont -> EState +applyAsClosure e v_closure value k = case v_closure of + ValueClosure closure -> app closure + other -> Er (evalErrorType "function" other) e k + + where app (FO (FOClosure{..})) = + let env = Env.insert _closureVar _closureIdent value (_closureEnv <> e) + in Down (unCore _closureBody) env k + app (HO prim) = Up (prim value) mempty k + +-- | predicate to check for done state +final :: EState -> Bool +final (Up _v _env Halt) = True +final (Er _err _env _k) = True +final _ = False + +-- | Initial state +start :: VEnv -> CoreF TypePattern ConstructorPattern Core -> EState +start e c = Down c e Halt + +yield :: EState -> Either EState Value +yield (Up v _ Halt) = Right v +yield e@Er{} = Left e +yield _ = error "evaluate: completed impossibly" + +extend :: Ident -> Var -> Value -> VEnv -> VEnv +extend i var = Env.insert var i + +extends :: [(Ident, Var, Value)] -> VEnv -> VEnv +extends exts env = foldl' (\acc (n,x,v) -> Env.insert x n v acc) env exts + +evalErrorType :: Text -> Value -> EvalError evalErrorType expected got = - throwError $ EvalErrorType $ TypeError + EvalErrorType $ TypeError { _typeErrorExpected = expected , _typeErrorActual = describeVal got } -evalAsClosure :: Core -> Eval Closure -evalAsClosure core = do - value <- eval core - case value of - ValueClosure closure -> - pure closure - other -> evalErrorType "function" other - -evalAsInteger :: Core -> Eval Integer -evalAsInteger core = do - value <- eval core - case value of - ValueInteger i -> pure i - other -> evalErrorType "integer" other - -evalAsSyntax :: Core -> Eval Syntax -evalAsSyntax core = do - value <- eval core - case value of - ValueSyntax syntax -> pure syntax - other -> evalErrorType "syntax" other - -evalAsString :: Core -> Eval Text -evalAsString core = do - value <- eval core - case value of - ValueString str -> pure str - other -> evalErrorType "string" other - -evalAsMacroAction :: Core -> Eval MacroAction -evalAsMacroAction core = do - value <- eval core - case value of - ValueMacroAction macroAction -> pure macroAction - other -> evalErrorType "macro action" other - -evalAsType :: Core -> Eval Ty -evalAsType core = do - value <- eval core - case value of - ValueType t -> pure t - other -> evalErrorType "type" other - -withScopeOf :: Core -> ExprF Syntax -> Eval Value -withScopeOf scope expr = do - scopeSyntax <- evalAsSyntax scope - case scopeSyntax of - Syntax (Stx scopeSet loc _) -> - pure $ ValueSyntax $ Syntax $ Stx scopeSet loc expr - -doDataCase :: SrcLoc -> Value -> [(ConstructorPattern, Core)] -> Eval Value -doDataCase loc v0 [] = throwError (EvalErrorCase loc v0) -doDataCase loc v0 ((pat, rhs) : ps) = - match (doDataCase loc v0 ps) (eval rhs) [(unConstructorPattern pat, v0)] +doTypeCase :: VEnv -> SrcLoc -> Ty -> [(TypePattern, Core)] -> Either EState Value +-- We pass @Right $ ValueType v0@ here so that the Core type-case still matches +-- on the outermost constructor instead of failing immedaitely. This behavior +-- comports with the other cases and could allow a debugger to fixup an +-- expression while knowing the type-case. +doTypeCase _env _blameLoc v0 [] = Right $ ValueType v0 +doTypeCase env blameLoc (Ty v0) ((p, rhs0) : ps) = + do v <- doTypeCase env blameLoc (Ty v0) ps + match v p rhs0 v0 where - match :: - Eval Value {- ^ Failure continuation -} -> - Eval Value {- ^ Success continuation, to be used in an extended environment -} -> - [(ConstructorPatternF ConstructorPattern, Value)] {- ^ Subpatterns and their scrutinees -} -> - Eval Value - match _fk sk [] = sk - match fk sk ((CtorPattern ctor subPats, tgt) : more) = - case tgt of - ValueCtor c args - | c == ctor -> - if length subPats /= length args - then error $ "Type checker bug: wrong number of pattern vars for constructor " ++ show c - else match fk sk (zip (map unConstructorPattern subPats) args ++ more) - _otherValue -> fk - match fk sk ((PatternVar n x, tgt) : more) = - match fk (withExtendedEnv n x tgt $ sk) more - -doTypeCase :: SrcLoc -> Ty -> [(TypePattern, Core)] -> Eval Value -doTypeCase blameLoc v0 [] = throwError (EvalErrorCase blameLoc (ValueType v0)) -doTypeCase blameLoc (Ty v0) ((p, rhs0) : ps) = match (doTypeCase blameLoc (Ty v0) ps) p rhs0 v0 - where - match :: Eval Value -> TypePattern -> Core -> TyF Ty -> Eval Value + match :: Value -> TypePattern -> Core -> TyF Ty -> Either EState Value match next (TypePattern t) rhs scrut = case (t, scrut) of -- unification variables never match; instead, type-case remains stuck -- until the variable is unified with a concrete type constructor or a -- skolem variable. - (TyF (TMetaVar _) _, _) -> next - (_, TyF (TMetaVar _) _) -> next + (TyF (TMetaVar _) _, _) -> return next + (_, TyF (TMetaVar _) _) -> return next (TyF ctor1 args1, TyF ctor2 args2) | ctor1 == ctor2 && length args1 == length args2 -> - withManyExtendedEnv [ (n, x, ValueType arg) - | (n, x) <- args1 - | arg <- args2] - (eval rhs) - (_, _) -> next + evaluateWithExtendedEnv env [ (n, x, ValueType arg) + | (n, x) <- args1 + | arg <- args2 + ] rhs + (_, _) -> return next match _next (AnyType n x) rhs scrut = - withExtendedEnv n x (ValueType (Ty scrut)) (eval rhs) + evaluateWithExtendedEnv env [(n, x, ValueType (Ty scrut))] rhs -doCase :: SrcLoc -> Value -> [(SyntaxPattern, Core)] -> Eval Value -doCase blameLoc v0 [] = throwError (EvalErrorCase blameLoc v0) -doCase blameLoc v0 ((p, rhs0) : ps) = match (doCase blameLoc v0 ps) p rhs0 v0 +-- TODO SAT this +doCase :: SrcLoc -> Value -> [(SyntaxPattern, Core)] -> VEnv -> Kont -> EState +doCase blameLoc v0 [] e kont = Er (EvalErrorCase blameLoc v0) e kont +doCase blameLoc v0 ((p, rhs0) : ps) e kont = match (doCase blameLoc v0 ps e kont) p rhs0 v0 e kont where - match next (SyntaxPatternIdentifier n x) rhs = - \case + match next (SyntaxPatternIdentifier n x) rhs scrutinee env k = + case scrutinee of v@(ValueSyntax (Syntax (Stx _ _ (Id _)))) -> - withExtendedEnv n x v (eval rhs) + step $ Down (unCore rhs) (extend n x v env) k _ -> next - match next (SyntaxPatternInteger n x) rhs = - \case + match next (SyntaxPatternInteger n x) rhs scrutinee env k = + case scrutinee of ValueSyntax (Syntax (Stx _ _ (Integer int))) -> - withExtendedEnv n x (ValueInteger int) (eval rhs) + step $ Down (unCore rhs) (extend n x (ValueInteger int) env) k _ -> next - match next (SyntaxPatternString n x) rhs = - \case + match next (SyntaxPatternString n x) rhs scrutinee env k = + case scrutinee of ValueSyntax (Syntax (Stx _ _ (String str))) -> - withExtendedEnv n x (ValueString str) (eval rhs) + step $ Down (unCore rhs) (extend n x (ValueString str) env) k _ -> next - match next SyntaxPatternEmpty rhs = - \case + match next SyntaxPatternEmpty rhs scrutinee env k = + case scrutinee of (ValueSyntax (Syntax (Stx _ _ (List [])))) -> - eval rhs + step $ Down (unCore rhs) env k _ -> next - match next (SyntaxPatternCons nx x nxs xs) rhs = - \case + match next (SyntaxPatternCons nx x nxs xs) rhs scrutinee env k = + case scrutinee of (ValueSyntax (Syntax (Stx scs loc (List (v:vs))))) -> - withExtendedEnv nx x (ValueSyntax v) $ - withExtendedEnv nxs xs (ValueSyntax (Syntax (Stx scs loc (List vs)))) $ - eval rhs + let mkEnv = extend nx x (ValueSyntax v) + . extend nxs xs (ValueSyntax (Syntax (Stx scs loc (List vs)))) + in step $ Down (unCore rhs) (mkEnv env) k _ -> next - match next (SyntaxPatternList xs) rhs = - \case + match next (SyntaxPatternList xs) rhs scrutinee env k = + case scrutinee of (ValueSyntax (Syntax (Stx _ _ (List vs)))) | length vs == length xs -> - withManyExtendedEnv [(n, x, (ValueSyntax v)) - | (n,x) <- xs - | v <- vs] $ - eval rhs + let vals = [ (n, x, ValueSyntax v) + | (n,x) <- xs + | v <- vs + ] + in step $ Down (unCore rhs) (vals `extends` env) k _ -> next - match _next SyntaxPatternAny rhs = - const (eval rhs) + match _next SyntaxPatternAny rhs _scrutinee env k = + step $ Down (unCore rhs) env k + +doDataCase :: SrcLoc -> Value -> [(ConstructorPattern, Core)] -> VEnv -> Kont -> EState +doDataCase loc v0 [] env kont = Er (EvalErrorCase loc v0) env kont +doDataCase loc v0 ((pat, rhs) : ps) env kont = + match (doDataCase loc v0 ps env kont) (\newEnv -> step $ Down (unCore rhs) newEnv kont) [(unConstructorPattern pat, v0)] + where + match + :: EState {- ^ Failure continuation -} + -> (VEnv -> EState) {- ^ Success continuation, to be used in an extended environment -} + -> [(ConstructorPatternF ConstructorPattern, Value)] {- ^ Subpatterns and their scrutinees -} + -> EState + match _fk sk [] = sk env + match fk sk ((CtorPattern ctor subPats, tgt) : more) = + case tgt of + ValueCtor c args + | c == ctor -> + if length subPats /= length args + then error $ "Type checker bug: wrong number of pattern vars for constructor " ++ show c + else match fk sk (zip (map unConstructorPattern subPats) args ++ more) + _otherValue -> fk + match fk sk ((PatternVar n x, tgt) : more) = + match fk (sk . extend n x tgt) more + +-- ----------------------------------------------------------------------------- +-- Top level API + +evaluate :: Core -> Either EState Value +evaluate = evaluateIn mempty + +evaluateIn :: VEnv -> Core -> Either EState Value +evaluateIn e = yield . until final step . start e . unCore + +evaluateWithExtendedEnv :: VEnv -> [(Ident, Var, Value)] -> Core -> Either EState Value +evaluateWithExtendedEnv env exts = evaluateIn (inserter exts) + where + inserter = foldl' (\acc (n,x,v) -> Env.insert x n v acc) env + +-- TODO DYG: Move to separate module +projectError :: EState -> EvalError +projectError (Er err _env _k) = err +projectError _ = error "debugger: impossible" + +erroneousValue :: EvalError -> Value +erroneousValue (EvalErrorCase _loc v) = v +erroneousValue (EvalErrorIdent v) = v +erroneousValue _ = + error $ mconcat [ "erroneousValue: " + , "Evaluator concluded in an error that did not return a value" + ] diff --git a/src/Expander.hs b/src/Expander.hs index ff581681..6854f5b8 100644 --- a/src/Expander.hs +++ b/src/Expander.hs @@ -2,15 +2,11 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} module Expander ( @@ -26,7 +22,7 @@ module Expander ( , initializeKernel , initializeLanguage , currentPhase - , expandEval + , evalInCurrentPhase , ExpansionErr(..) , ExpanderContext , expanderCurrentBindingTable @@ -45,8 +41,6 @@ import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.Except (MonadError(catchError, throwError)) import Control.Monad.Reader (MonadReader(local)) import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.Monad.Trans.Except (runExceptT) -import Control.Monad.Trans.Reader (runReaderT) import Control.Monad.Trans.State.Strict (StateT, execStateT, modify', runStateT) import Data.Foldable import Data.Function (on) @@ -89,6 +83,7 @@ import Value import World import qualified ScopeSet + import qualified Util.Set as Set import qualified Util.Store as S @@ -277,7 +272,7 @@ evalMod (Expanded em _) = execStateT (traverseOf_ (moduleBody . each) evalDecl e Define x n sch e -> do ptr <- liftIO newSchemePtr lift $ linkScheme ptr sch - val <- lift $ expandEval (eval e) + val <- lift $ evalInCurrentPhase e p <- lift currentPhase lift $ modifyState $ over (expanderWorld . worldTypeContexts . at p) $ @@ -304,10 +299,10 @@ evalMod (Expanded em _) = execStateT (traverseOf_ (moduleBody . each) evalDecl e Example loc sch expr -> do env <- lift currentEnv - value <- lift $ expandEval (eval expr) + value <- lift $ evalInCurrentPhase expr modify' (:|> ExampleResult loc env expr sch value) Run loc expr -> do - lift (expandEval (eval expr)) >>= + lift (evalInCurrentPhase expr) >>= \case (ValueIOAction act) -> modify' (:|> (IOResult . void $ act)) @@ -318,7 +313,7 @@ evalMod (Expanded em _) = execStateT (traverseOf_ (moduleBody . each) evalDecl e DefineMacros macros -> do p <- lift currentPhase lift $ inEarlierPhase $ for_ macros $ \(x, n, e) -> do - v <- expandEval (eval e) + v <- evalInCurrentPhase e modifyState $ over (expanderWorld . worldTransformerEnvironments . at p) $ Just . maybe (Env.singleton n x v) (Env.insert n x v) @@ -558,18 +553,14 @@ initializeKernel outputChannel = do ValueIOAction $ do vx <- mx vioy <- case f of - HO fun -> do - pure (fun vx) + HO fun -> pure (fun vx) FO clos -> do let env = view closureEnv clos var = view closureVar clos ident = view closureIdent clos body = view closureBody clos - out <- runExceptT $ flip runReaderT env $ runEval $ - withExtendedEnv ident var vx $ - eval body - case out of - Left err -> error (T.unpack (pretty err)) + case (evaluateWithExtendedEnv env [(ident, var, vx)] body) of + Left err -> error (T.unpack (pretty $ projectError err)) Right vioy -> pure vioy let ValueIOAction my = vioy my @@ -914,13 +905,19 @@ runTask (tid, localData, task) = withLocal localData $ do case ty of Ty (TyF (TMetaVar ptr) _) | ptr == ptr' -> stillStuck tid task _ -> forkAwaitingTypeCase loc dest (tMetaVar ptr') env cases kont - other -> do - selectedBranch <- expandEval $ withEnv env $ doTypeCase loc (Ty other) cases - case selectedBranch of + other -> case doTypeCase env loc (Ty other) cases of + Right v -> case v of ValueMacroAction nextStep -> do forkInterpretMacroAction dest nextStep kont otherVal -> do - expandEval $ evalErrorType "macro action" otherVal + p <- currentPhase + throwError $ MacroEvaluationError p $ evalErrorType "macro action" otherVal + Left err -> do + -- an error occurred in the evaluator, so just report it + p <- currentPhase + throwError + $ MacroEvaluationError p + $ projectError err AwaitingMacro dest (TaskAwaitMacro b v x deps mdest stx) -> do newDeps <- concat <$> traverse dependencies deps case newDeps of @@ -935,7 +932,7 @@ runTask (tid, localData, task) = withLocal localData $ do Nothing -> error "Internal error - macro body not fully expanded" Just macroImpl -> do p <- currentPhase - macroImplVal <- inEarlierPhase $ expandEval $ eval macroImpl + macroImplVal <- inEarlierPhase $ evalInCurrentPhase macroImpl let tenv = Env.singleton v x macroImplVal -- Extend the env! modifyState $ over (expanderCurrentTransformerEnvs . at p) $ @@ -951,7 +948,7 @@ runTask (tid, localData, task) = withLocal localData $ do Nothing -> stillStuck tid task Just e -> do p <- currentPhase - v <- expandEval (eval e) + v <- evalInCurrentPhase e let env = Env.singleton x n v modifyState $ over (expanderCurrentEnvs . at p) $ Just . maybe env (<> env) @@ -983,24 +980,36 @@ runTask (tid, localData, task) = withLocal localData $ do case value of ValueSyntax syntax -> do forkExpandSyntax dest syntax - other -> expandEval $ evalErrorType "syntax" other + other -> do + p <- currentPhase + throwError $ MacroEvaluationError p $ evalErrorType "syntax" other ContinueMacroAction dest value (closure:kont) -> do - result <- expandEval $ apply closure value - case result of - ValueMacroAction macroAction -> do - forkInterpretMacroAction dest macroAction kont - other -> expandEval $ evalErrorType "macro action" other + case apply closure value of + Left err -> do + p <- currentPhase + throwError + $ MacroEvaluationError p + $ evalErrorType "macro action" + $ erroneousValue + $ projectError err + Right v -> + case v of + ValueMacroAction macroAction -> do + forkInterpretMacroAction dest macroAction kont + other -> do + p <- currentPhase + throwError $ MacroEvaluationError p $ evalErrorType "macro action" other EvalDefnAction x n p expr -> linkedCore expr >>= \case Nothing -> stillStuck tid task Just definiens -> inPhase p $ do - val <- expandEval (eval definiens) + val <- evalInCurrentPhase definiens modifyState $ over (expanderCurrentEnvs . at p) $ - \case - Nothing -> Just $ Env.singleton x n val - Just env -> Just $ env <> Env.singleton x n val + \case + Nothing -> Just $ Env.singleton x n val + Just env -> Just $ env <> Env.singleton x n val GeneralizeType edest ty schdest -> do ready <- isExprChecked edest if ready @@ -1301,13 +1310,19 @@ expandOneForm prob stx implV <- Env.lookupVal transformerName <$> currentTransformerEnv case implV of Just (ValueClosure macroImpl) -> do - macroVal <- inEarlierPhase $ expandEval $ - apply macroImpl $ - ValueSyntax $ addScope p stepScope stx + macroVal <- inEarlierPhase + $ pure + $ apply macroImpl + $ ValueSyntax + $ addScope p stepScope stx case macroVal of - ValueMacroAction act -> do - res <- interpretMacroAction prob act - case res of + Left err -> throwError + $ ValueNotMacro + $ erroneousValue + $ projectError err + Right mv -> case mv of + ValueMacroAction act -> + interpretMacroAction prob act >>= \case StuckOnType loc ty env cases kont -> forkAwaitingTypeCase loc prob ty env cases kont Done expanded -> @@ -1315,8 +1330,8 @@ expandOneForm prob stx ValueSyntax expansionResult -> forkExpandSyntax prob (flipScope p stepScope expansionResult) other -> throwError $ ValueNotSyntax other - other -> - throwError $ ValueNotMacro other + other -> + throwError $ ValueNotMacro other Nothing -> throwError $ InternalError $ "No transformer yet created for " ++ shortShow ident ++ @@ -1400,12 +1415,17 @@ interpretMacroAction prob = phase <- view (expanderLocal . expanderPhase) s <- getState let env = fromMaybe Env.empty . - view (expanderWorld . worldEnvironments . at phase) $ - s - value <- expandEval $ withEnv env $ apply closure boundResult - case value of - ValueMacroAction act -> interpretMacroAction prob act - other -> throwError $ ValueNotMacro other + view (expanderWorld . worldEnvironments . at phase) $ s + case applyInEnv env closure boundResult of + -- FIXME DYG: what error to throw here + Left err -> throwError + $ ValueNotMacro + $ erroneousValue + $ projectError err + Right v -> + case v of + ValueMacroAction act -> interpretMacroAction prob act + other -> throwError $ ValueNotMacro other MacroActionSyntaxError syntaxError -> throwError $ MacroRaisedSyntaxError syntaxError MacroActionIdentEq how v1 v2 -> do diff --git a/src/Expander/Monad.hs b/src/Expander/Monad.hs index 7a8c34c4..62f7ce3c 100644 --- a/src/Expander/Monad.hs +++ b/src/Expander/Monad.hs @@ -6,6 +6,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -funbox-strict-fields #-} {-# LANGUAGE BangPatterns #-} @@ -34,7 +35,7 @@ module Expander.Monad , inTypeBinder , dependencies , execExpand - , expandEval + , evalInCurrentPhase , freshBinding , freshConstructor , freshDatatype @@ -860,14 +861,14 @@ setTasks = modifyState . set expanderTasks clearTasks :: Expand () clearTasks = modifyState $ set expanderTasks [] -expandEval :: Eval a -> Expand a -expandEval evalAction = do +evalInCurrentPhase :: Core -> Expand Value +evalInCurrentPhase evalAction = do env <- currentEnv - out <- liftIO $ runExceptT $ runReaderT (runEval evalAction) env + let out = evaluateIn env evalAction case out of Left err -> do p <- currentPhase - throwError $ MacroEvaluationError p err + throwError $ MacroEvaluationError p $ projectError err Right val -> return val currentTransformerEnv :: Expand TEnv diff --git a/src/Pretty.hs b/src/Pretty.hs index 238d37c5..86b409bd 100644 --- a/src/Pretty.hs +++ b/src/Pretty.hs @@ -624,6 +624,7 @@ instance Pretty VarInfo EvalError where group $ hang 2 $ vsep [text "No case matched at" <+> pp env blame <> ":" , pp env val] pp env (EvalErrorUser (Syntax (Stx _ loc msg))) = group $ hang 2 $ vsep [pp env loc <> ":", pp env msg] + pp env (EvalErrorIdent v) = text "Attempt to bind identifier to non-value: " <+> pp env v instance Pretty VarInfo EvalResult where pp env (ExampleResult loc valEnv coreExpr sch val) =