diff --git a/klister.cabal b/klister.cabal index a6fea522..272a9daf 100644 --- a/klister.cabal +++ b/klister.cabal @@ -61,6 +61,7 @@ library Core.Builder Datatype Env + CEKEvaluator Evaluator Expander Expander.DeclScope diff --git a/repl/Main.hs b/repl/Main.hs index da02cbab..c1fa06f6 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 @@ -22,7 +20,7 @@ import System.Exit (exitFailure, exitSuccess) import System.IO import System.Directory -import Evaluator +import CEKEvaluator import Expander import ModuleName import Parser @@ -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 + prettyPrintLn $ evaluateIn (phaseEnv runtime currentWorld) expr + -- Left evalErr -> print evalErr + -- Right val -> prettyPrintLn val diff --git a/src/CEKEvaluator.hs b/src/CEKEvaluator.hs new file mode 100644 index 00000000..2d484f7a --- /dev/null +++ b/src/CEKEvaluator.hs @@ -0,0 +1,554 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GADTSyntax #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +{- 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 + +The bird's eye view: + +-} + +module CEKEvaluator + ( EvalError (..) + , EvalResult (..) + , TypeError (..) + , evaluate + , evaluateIn + , evaluateWithExtendedEnv + , evalErrorType + , applyInEnv + , apply + , doTypeCase + , try + ) where + +import Control.Lens hiding (List, elements) +import Control.Exception hiding (TypeError, evaluate) +import Data.Data (Typeable) +import Data.Text (Text) +import Data.List (foldl') +import qualified Data.Text as T + +import Datatype +import Core +import Env +import ShortShow +import Syntax +import Syntax.SrcLoc +import Type +import Value + +-- ----------------------------------------------------------------------------- +-- Top level API + +evaluate :: Core -> Value +evaluate = evaluateIn mempty + +evaluateIn :: VEnv -> Core -> Value +evaluateIn e = yield . until final step . start e . unCore + where + yield (Up v _ Halt) = v + yield _ = error "evaluate: completed impossibly" + +evaluateWithExtendedEnv :: VEnv -> [(Ident, Var, Value)] -> Core -> Value +evaluateWithExtendedEnv env exts = evaluateIn (inserter exts) + where + inserter = foldl' (\acc (n,x,v) -> Env.insert x n v acc) env + +-- ----------------------------------------------------------------------------- +-- Interpreter Data Types + + +data EvalResult + = ExampleResult SrcLoc VEnv Core (Scheme Ty) Value + | IOResult (IO ()) + +-- TODO: more precise representation +type Type = Text + +data TypeError = TypeError + { _typeErrorExpected :: Type + , _typeErrorActual :: Type + } + deriving (Eq, Show) +makeLenses ''TypeError + +data EvalError + = EvalErrorUnbound Var + | EvalErrorType TypeError + | EvalErrorCase SrcLoc Value + | EvalErrorUser Syntax + 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 + + +-- ----------------------------------------------------------------------------- +-- 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 +-- 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) -> apply' env (evalAsClosure v) val kont + + + -- + -- 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, this could be a hack + (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) -> + Up (ValueMacroAction $ MacroActionTypeCase e loc (evalAsType v) cs) env kont + + -- Syntax + (InIdent scope env kont) -> case v of + ValueSyntax stx -> + case _unSyntax stx of + (Stx _ _ expr) -> case expr of + Integer _ -> + error $ show $ EvalErrorType $ TypeError + { _typeErrorExpected = "id" + , _typeErrorActual = "integer" + } + String _ -> + error $ show $ EvalErrorType $ TypeError + { _typeErrorExpected = "id" + , _typeErrorActual = "string" + } + List _ -> + error $ show $ EvalErrorType $ TypeError + { _typeErrorExpected = "id" + , _typeErrorActual = "list" + } + name@(Id _) -> Down (unCore scope) env (InScope name env kont) + other -> error $ "In Ident " ++ show other + (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) -> case evalAsSyntax v of + Syntax (Stx scopeSet loc _) -> Up (ValueSyntax $ Syntax $ Stx scopeSet loc expr) env kont + + -- lists + (InConsHd scope tl env kont) -> Down tl env (InConsTl scope (evalAsSyntax v) env kont) + (InConsTl scope hd env kont) -> case evalAsSyntax v of + Syntax (Stx _ _ expr) -> + case expr of + List tl -> Down (unCore scope) env (InScope (List $ hd : tl) env kont) + String _ -> + error $ show $ EvalErrorType $ TypeError + { _typeErrorExpected = "list" + , _typeErrorActual = "string" + } + Id _ -> error $ show $ EvalErrorType $ TypeError + { _typeErrorExpected = "list" + , _typeErrorActual = "id" + } + Integer _ -> + error $ show $ EvalErrorType $ TypeError + { _typeErrorExpected = "list" + , _typeErrorActual = "integer" + } + + -- done + (InList scope [] dones env kont) -> + Down (unCore scope) e (InScope (List $ reverse $ evalAsSyntax v : dones) env kont) + -- still some todo + (InList scope (el:els) dones env kont) -> + Down (unCore el) env (InList scope els (evalAsSyntax v : dones) env kont) + + -- Macros + (InPureMacro env kont) -> Up (ValueMacroAction $ MacroActionPure v) env kont + (InBindMacroHd tl env kont) -> + Down (unCore tl) env (InBindMacroTl (evalAsMacroAction v) env kont) + (InBindMacroTl macroAction env kont) -> + Up (ValueMacroAction $ MacroActionBind macroAction (evalAsClosure v)) env kont + + -- Syntax and Atomics + (InInteger scope env kont) -> + Down (unCore scope) env (InScope (Integer $ evalAsInteger v) env kont) + (InString scope env kont) -> + Down (unCore scope) env (InScope (String $ evalAsString v) env kont) + (InLoc stx env kont) -> case evalAsSyntax v of + Syntax (Stx _ newLoc _) -> Down (unCore stx) env (InLocStx newLoc env kont) + (InLocStx loc env kont) -> case evalAsSyntax v of + Syntax (Stx scs _ contents) -> Up (ValueSyntax $ Syntax $ Stx scs loc contents) env kont + (InLog env kont) -> Up (ValueMacroAction (MacroActionLog $ evalAsSyntax v)) env kont + + -- Errors and TODO: a debugger hook + (InError _env _kont) -> error $ show v + (InSyntaxErrorMessage locs env kont) -> + let msg_syn = evalAsSyntax v + in 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) + + -- 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) -> + Down (unCore l) env (InSyntaxErrorLocations msg ls (evalAsSyntax v : dones) 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 + _ -> error $ show $ EvalErrorUnbound var + + (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 + + +evalAsClosure :: Value -> Closure +evalAsClosure = \case + ValueClosure closure -> closure + other -> error $ show $ evalErrorType "function" other + +evalAsInteger :: Value -> Integer +evalAsInteger = \case + ValueInteger i -> i + other -> error $ show $ evalErrorType "integer" other + +evalAsSyntax :: Value -> Syntax +evalAsSyntax = \case + ValueSyntax syntax -> syntax + other -> error $ show $ evalErrorType "syntax" other + +evalAsString :: Value -> Text +evalAsString = \case + ValueString str -> str + other -> error $ show $ evalErrorType "string" other + +evalAsMacroAction :: Value -> MacroAction +evalAsMacroAction = \case + ValueMacroAction macroAction -> macroAction + other -> error $ show $ evalErrorType "macro action" other + +evalAsType :: Value -> Ty +evalAsType = \case + ValueType t -> t + other -> error $ show $ evalErrorType "type" other + +applyInEnv :: VEnv -> Closure -> Value -> 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 = prim value + +apply :: Closure -> Value -> Value +apply (FO (FOClosure {..})) value = + let env = Env.insert _closureVar + _closureIdent + value + _closureEnv + in evaluateIn env _closureBody +apply (HO prim) value = prim value + +apply' :: VEnv -> Closure -> Value -> Kont -> EState +apply' e (FO (FOClosure{..})) value k = Down (unCore _closureBody) env k + where env = Env.insert _closureVar + _closureIdent + value + (_closureEnv <> e) +apply' _ (HO prim) value k = Up (prim value) mempty k + +-- | predicate to check for done state +final :: EState -> Bool +final (Up _v _env Halt) = True +final _ = False + +-- | Initial state +start :: VEnv -> CoreF TypePattern ConstructorPattern Core -> EState +start e c = Down c e Halt + + +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 = + EvalErrorType $ TypeError + { _typeErrorExpected = expected + , _typeErrorActual = describeVal got + } + +doTypeCase :: VEnv -> SrcLoc -> Ty -> [(TypePattern, Core)] -> Value +doTypeCase _ blameLoc v0 [] = error $ show (EvalErrorCase blameLoc (ValueType v0)) +doTypeCase env blameLoc (Ty v0) ((p, rhs0) : ps) = match (doTypeCase env blameLoc (Ty v0) ps) p rhs0 v0 + where + match :: Value -> TypePattern -> Core -> TyF Ty -> 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 ctor1 args1, TyF ctor2 args2) + | ctor1 == ctor2 && length args1 == length args2 -> + evaluateWithExtendedEnv env [ (n, x, ValueType arg) + | (n, x) <- args1 + | arg <- args2 + ] rhs + (_, _) -> next + match _next (AnyType n x) rhs scrut = + evaluateWithExtendedEnv env [(n, x, ValueType (Ty scrut))] rhs + +-- TODO SAT this +doCase :: SrcLoc -> Value -> [(SyntaxPattern, Core)] -> VEnv -> Kont -> EState +doCase blameLoc v0 [] _e _k = error $ show (EvalErrorCase blameLoc v0) +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 scrutinee env k = + case scrutinee of + v@(ValueSyntax (Syntax (Stx _ _ (Id _)))) -> + step $ Down (unCore rhs) (extend n x v env) k + _ -> next + match next (SyntaxPatternInteger n x) rhs scrutinee env k = + case scrutinee of + ValueSyntax (Syntax (Stx _ _ (Integer int))) -> + step $ Down (unCore rhs) (extend n x (ValueInteger int) env) k + _ -> next + match next (SyntaxPatternString n x) rhs scrutinee env k = + case scrutinee of + ValueSyntax (Syntax (Stx _ _ (String str))) -> + step $ Down (unCore rhs) (extend n x (ValueString str) env) k + _ -> next + match next SyntaxPatternEmpty rhs scrutinee env k = + case scrutinee of + (ValueSyntax (Syntax (Stx _ _ (List [])))) -> + step $ Down (unCore rhs) env k + _ -> next + match next (SyntaxPatternCons nx x nxs xs) rhs scrutinee env k = + case scrutinee of + (ValueSyntax (Syntax (Stx scs loc (List (v:vs))))) -> + 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 scrutinee env k = + case scrutinee of + (ValueSyntax (Syntax (Stx _ _ (List vs)))) + | length vs == length xs -> + 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 _scrutinee env k = + step $ Down (unCore rhs) env k + +doDataCase :: SrcLoc -> Value -> [(ConstructorPattern, Core)] -> VEnv -> Kont -> EState +doDataCase loc v0 [] _e _kont = error $ show (EvalErrorCase loc v0) +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 + diff --git a/src/Evaluator.hs b/src/Evaluator.hs index d5aa114c..d3e473bf 100644 --- a/src/Evaluator.hs +++ b/src/Evaluator.hs @@ -4,359 +4,355 @@ {-# LANGUAGE ParallelListComp #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} -module Evaluator where +module Evaluator () 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 Data.Text (Text) -import qualified Data.Text as T +-- import Control.Lens hiding (List, elements) +-- import Control.Monad.Except +-- import Control.Monad.Reader +-- import Data.Text (Text) +-- import qualified Data.Text as T -import Core -import Env -import ShortShow -import Syntax -import Syntax.SrcLoc -import Type -import Value +-- import Core +-- import Env +-- import ShortShow +-- import Syntax +-- import Syntax.SrcLoc +-- import Type +-- import Value --- TODO: more precise representation -type Type = Text +-- -- TODO: more precise representation +-- type Type = Text -data TypeError = TypeError - { _typeErrorExpected :: Type - , _typeErrorActual :: Type - } - deriving (Eq, Show) -makeLenses ''TypeError +-- data TypeError = TypeError +-- { _typeErrorExpected :: Type +-- , _typeErrorActual :: Type +-- } +-- deriving (Eq, Show) +-- makeLenses ''TypeError -data EvalError - = EvalErrorUnbound Var - | EvalErrorType TypeError - | EvalErrorCase SrcLoc Value - | EvalErrorUser Syntax - deriving (Show) -makePrisms ''EvalError +-- data EvalError +-- = EvalErrorUnbound Var +-- | EvalErrorType TypeError +-- | EvalErrorCase SrcLoc Value +-- | EvalErrorUser Syntax +-- deriving (Show) +-- makePrisms ''EvalError -evalErrorText :: EvalError -> Text -evalErrorText (EvalErrorUnbound x) = "Unbound: " <> T.pack (show x) -evalErrorText (EvalErrorType (TypeError expected got)) = - "Wrong type. Expected a " <> expected <> " but got a " <> got -evalErrorText (EvalErrorCase loc val) = - "Didn't match any pattern at " <> T.pack (shortShow loc) <> ": " <> valueText val -evalErrorText (EvalErrorUser what) = - T.pack (shortShow (stxLoc what)) <> ":\n\t" <> - syntaxText what +-- evalErrorText :: EvalError -> Text +-- evalErrorText (EvalErrorUnbound x) = "Unbound: " <> T.pack (show x) +-- evalErrorText (EvalErrorType (TypeError expected got)) = +-- "Wrong type. Expected a " <> expected <> " but got a " <> got +-- evalErrorText (EvalErrorCase loc val) = +-- "Didn't match any pattern at " <> T.pack (shortShow loc) <> ": " <> valueText val +-- evalErrorText (EvalErrorUser what) = +-- T.pack (shortShow (stxLoc what)) <> ":\n\t" <> +-- syntaxText what -newtype Eval a = Eval - { runEval :: ReaderT VEnv (ExceptT EvalError IO) a } - deriving (Functor, Applicative, Monad, - MonadReader VEnv, MonadError EvalError, - MonadIO) +-- newtype Eval a = Eval +-- { runEval :: ReaderT VEnv (ExceptT EvalError IO) a } +-- deriving (Functor, Applicative, Monad, +-- MonadReader VEnv, MonadError EvalError, +-- MonadIO) -withEnv :: VEnv -> Eval a -> Eval a -withEnv = local . const +-- withEnv :: VEnv -> Eval a -> Eval a +-- withEnv = local . const -withExtendedEnv :: Ident -> Var -> Value -> Eval a -> Eval a -withExtendedEnv n x v act = local (Env.insert x n v) act +-- withExtendedEnv :: Ident -> Var -> Value -> Eval a -> Eval a +-- withExtendedEnv n x v act = local (Env.insert x n v) act -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 +-- 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 -data EvalResult - = ExampleResult SrcLoc VEnv Core (Scheme Ty) Value - | IOResult (IO ()) +-- data EvalResult +-- = ExampleResult SrcLoc VEnv Core (Scheme Ty) Value +-- | IOResult (IO ()) -apply :: Closure -> Value -> Eval Value -apply (FO (FOClosure {..})) value = do - let env = Env.insert _closureVar - _closureIdent - value - _closureEnv - withEnv env $ - eval _closureBody -apply (HO prim) value = pure (prim value) +-- apply :: Closure -> Value -> Eval Value +-- apply (FO (FOClosure {..})) value = do +-- 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 +-- 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 -evalErrorType expected got = - throwError $ EvalErrorType $ TypeError - { _typeErrorExpected = expected - , _typeErrorActual = describeVal got - } +-- evalErrorType :: Text -> Value -> Eval a +-- evalErrorType expected got = +-- throwError $ 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 +-- 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 +-- 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 +-- 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 +-- 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 +-- evalAsMacroAction :: Core -> Eval MacroAction +-- evalAsMacroAction core = +-- case evaluate 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 +-- evalAsType :: Core -> Eval Ty +-- evalAsType core = do +-- value <- evaluate 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 +-- 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)] - 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 +-- 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) (evaluate rhs) [(unConstructorPattern pat, 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 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 +-- 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 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 ctor1 args1, TyF ctor2 args2) - | ctor1 == ctor2 && length args1 == length args2 -> - withManyExtendedEnv [ (n, x, ValueType arg) - | (n, x) <- args1 - | arg <- args2] - (eval rhs) - (_, _) -> next - match _next (AnyType n x) rhs scrut = - withExtendedEnv n x (ValueType (Ty scrut)) (eval rhs) +-- (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 +-- match _next (AnyType n x) rhs scrut = +-- withExtendedEnv n x (ValueType (Ty scrut)) (eval 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 - where - match next (SyntaxPatternIdentifier n x) rhs = - \case - v@(ValueSyntax (Syntax (Stx _ _ (Id _)))) -> - withExtendedEnv n x v (eval rhs) - _ -> next - match next (SyntaxPatternInteger n x) rhs = - \case - ValueSyntax (Syntax (Stx _ _ (Integer int))) -> - withExtendedEnv n x (ValueInteger int) (eval rhs) - _ -> next - match next (SyntaxPatternString n x) rhs = - \case - ValueSyntax (Syntax (Stx _ _ (String str))) -> - withExtendedEnv n x (ValueString str) (eval rhs) - _ -> next - match next SyntaxPatternEmpty rhs = - \case - (ValueSyntax (Syntax (Stx _ _ (List [])))) -> - eval rhs - _ -> next - match next (SyntaxPatternCons nx x nxs xs) rhs = - \case - (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 - _ -> next - match next (SyntaxPatternList xs) rhs = - \case - (ValueSyntax (Syntax (Stx _ _ (List vs)))) - | length vs == length xs -> - withManyExtendedEnv [(n, x, (ValueSyntax v)) - | (n,x) <- xs - | v <- vs] $ - eval rhs - _ -> next - match _next SyntaxPatternAny rhs = - const (eval 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 +-- where +-- match next (SyntaxPatternIdentifier n x) rhs = +-- \case +-- v@(ValueSyntax (Syntax (Stx _ _ (Id _)))) -> +-- withExtendedEnv n x v (eval rhs) +-- _ -> next +-- match next (SyntaxPatternInteger n x) rhs = +-- \case +-- ValueSyntax (Syntax (Stx _ _ (Integer int))) -> +-- withExtendedEnv n x (ValueInteger int) (eval rhs) +-- _ -> next +-- match next (SyntaxPatternString n x) rhs = +-- \case +-- ValueSyntax (Syntax (Stx _ _ (String str))) -> +-- withExtendedEnv n x (ValueString str) (eval rhs) +-- _ -> next +-- match next SyntaxPatternEmpty rhs = +-- \case +-- (ValueSyntax (Syntax (Stx _ _ (List [])))) -> +-- eval rhs +-- _ -> next +-- match next (SyntaxPatternCons nx x nxs xs) rhs = +-- \case +-- (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 +-- _ -> next +-- match next (SyntaxPatternList xs) rhs = +-- \case +-- (ValueSyntax (Syntax (Stx _ _ (List vs)))) +-- | length vs == length xs -> +-- withManyExtendedEnv [(n, x, (ValueSyntax v)) +-- | (n,x) <- xs +-- | v <- vs] $ +-- eval rhs +-- _ -> next +-- match _next SyntaxPatternAny rhs = +-- const (eval rhs) diff --git a/src/Expander.hs b/src/Expander.hs index ff581681..c7f0ff6f 100644 --- a/src/Expander.hs +++ b/src/Expander.hs @@ -66,7 +66,7 @@ import Binding import Core import Datatype import qualified Env -import Evaluator +import CEKEvaluator import qualified Expander.Primitives as Prims import Expander.DeclScope import Expander.Syntax @@ -89,6 +89,8 @@ import Value import World import qualified ScopeSet +import Debug.Trace + import qualified Util.Set as Set import qualified Util.Store as S @@ -277,7 +279,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 $ expandEval e p <- lift currentPhase lift $ modifyState $ over (expanderWorld . worldTypeContexts . at p) $ @@ -304,10 +306,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 $ expandEval expr modify' (:|> ExampleResult loc env expr sch value) Run loc expr -> do - lift (expandEval (eval expr)) >>= + lift (expandEval expr) >>= \case (ValueIOAction act) -> modify' (:|> (IOResult . void $ act)) @@ -318,7 +320,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 <- expandEval e modifyState $ over (expanderWorld . worldTransformerEnvironments . at p) $ Just . maybe (Env.singleton n x v) (Env.insert n x v) @@ -558,19 +560,16 @@ 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 Right (evaluateWithExtendedEnv env [(ident, var, vx)] body) of + -- Left err -> error (T.unpack (pretty err)) Right vioy -> pure vioy + _ -> error "ValueIOAction error" let ValueIOAction my = vioy my ) @@ -914,13 +913,12 @@ 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 - ValueMacroAction nextStep -> do - forkInterpretMacroAction dest nextStep kont - otherVal -> do - expandEval $ evalErrorType "macro action" otherVal + other -> case doTypeCase env loc (Ty other) cases of + ValueMacroAction nextStep -> do + forkInterpretMacroAction dest nextStep kont + otherVal -> do + p <- currentPhase + throwError $ MacroEvaluationError p $ evalErrorType "macro action" otherVal AwaitingMacro dest (TaskAwaitMacro b v x deps mdest stx) -> do newDeps <- concat <$> traverse dependencies deps case newDeps of @@ -935,7 +933,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 $ expandEval macroImpl let tenv = Env.singleton v x macroImplVal -- Extend the env! modifyState $ over (expanderCurrentTransformerEnvs . at p) $ @@ -951,7 +949,7 @@ runTask (tid, localData, task) = withLocal localData $ do Nothing -> stillStuck tid task Just e -> do p <- currentPhase - v <- expandEval (eval e) + v <- expandEval e let env = Env.singleton x n v modifyState $ over (expanderCurrentEnvs . at p) $ Just . maybe env (<> env) @@ -983,20 +981,23 @@ 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 + case apply closure value of ValueMacroAction macroAction -> do forkInterpretMacroAction dest macroAction kont - other -> expandEval $ evalErrorType "macro action" other + 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) + let val = trace "EvalDefnAction" $ evaluate definiens modifyState $ over (expanderCurrentEnvs . at p) $ \case Nothing -> Just $ Env.singleton x n val @@ -1301,9 +1302,11 @@ 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 @@ -1400,10 +1403,8 @@ 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 + view (expanderWorld . worldEnvironments . at phase) $ s + case applyInEnv env closure boundResult of ValueMacroAction act -> interpretMacroAction prob act other -> throwError $ ValueNotMacro other MacroActionSyntaxError syntaxError -> diff --git a/src/Expander/Error.hs b/src/Expander/Error.hs index c4134733..b7b95083 100644 --- a/src/Expander/Error.hs +++ b/src/Expander/Error.hs @@ -19,7 +19,7 @@ import Data.Foldable import Core import Datatype -import Evaluator +import CEKEvaluator import Expander.Task import Kind import KlisterPath diff --git a/src/Expander/Monad.hs b/src/Expander/Monad.hs index 7a8c34c4..993d443f 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 #-} @@ -176,7 +177,7 @@ import Control.Lens.IORef import Core import Datatype import Env -import Evaluator +import CEKEvaluator import Expander.DeclScope import Expander.Error import Expander.Task @@ -860,10 +861,10 @@ setTasks = modifyState . set expanderTasks clearTasks :: Expand () clearTasks = modifyState $ set expanderTasks [] -expandEval :: Eval a -> Expand a +expandEval :: Core -> Expand Value expandEval evalAction = do env <- currentEnv - out <- liftIO $ runExceptT $ runReaderT (runEval evalAction) env + let out = Right $ evaluateIn env evalAction case out of Left err -> do p <- currentPhase diff --git a/src/Pretty.hs b/src/Pretty.hs index 238d37c5..b5c3aef0 100644 --- a/src/Pretty.hs +++ b/src/Pretty.hs @@ -26,7 +26,7 @@ import Binding.Info import Core import Datatype import Env -import Evaluator (EvalResult(..), EvalError(..), TypeError(..)) +import CEKEvaluator (EvalResult(..), EvalError(..), TypeError(..)) import Kind import Module import ModuleName diff --git a/src/World.hs b/src/World.hs index 8e38203c..c493923d 100644 --- a/src/World.hs +++ b/src/World.hs @@ -13,7 +13,7 @@ import Data.Maybe (fromMaybe) import Core (MacroVar, Var) import Datatype import Env -import Evaluator (EvalResult) +import CEKEvaluator (EvalResult) import Module import ModuleName import Phase diff --git a/tests/Golden.hs b/tests/Golden.hs index f6b8df15..ba02234b 100644 --- a/tests/Golden.hs +++ b/tests/Golden.hs @@ -25,7 +25,7 @@ import System.IO (Handle, openFile, hClose, IOMode(WriteMode)) import System.IO.Silently (hCapture_) import System.Directory -import Evaluator +import CEKEvaluator import Expander import Expander.Monad import ModuleName diff --git a/tests/Test.hs b/tests/Test.hs index 29f12e90..767d95c7 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -34,7 +34,7 @@ import qualified Hedgehog.Internal.Property as Prop (forAllT) import Alpha import Core import Core.Builder -import Evaluator (EvalResult(..)) +import CEKEvaluator (EvalResult(..)) import Expander import Expander.Monad import Module