wrk: add Er State

src/Evaluator.hs

@@ -65,7 +65,6 @@ 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
@@ -99,6 +98,7 @@ data EvalError
   | EvalErrorType TypeError
   | EvalErrorCase SrcLoc Value
   | EvalErrorUser Syntax
+  | EvalErrorIdent Syntax
   deriving (Show, Typeable)
 makePrisms ''EvalError
 instance Exception EvalError
@@ -157,6 +157,7 @@ data Kont where
   InLog   :: !VEnv -> !Kont -> Kont
   InError :: !VEnv -> !Kont -> Kont
 
+
   InSyntaxErrorMessage   :: ![Core] -> !VEnv -> !Kont -> Kont
   InSyntaxErrorLocations :: !Syntax -> ![Core] -> ![Syntax] -> !VEnv -> !Kont -> Kont
 
@@ -168,6 +169,8 @@ data EState where
   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
 
 
 -- -----------------------------------------------------------------------------
@@ -186,7 +189,7 @@ step (Up v e k) =
     -- 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
+    (InFun val env kont) -> applyAsClosure env v val kont
 
 
     --
@@ -210,22 +213,22 @@ step (Up v e k) =
         case _unSyntax stx of
           (Stx _ _ expr) -> case expr of
             Integer _ ->
-              error $ show $ EvalErrorType $ TypeError
-                                { _typeErrorExpected = "id"
-                                , _typeErrorActual   = "integer"
-                                }
+              Er (EvalErrorType
+                   $ TypeError { typeErrorExpected = "id"
+                               , typeErrorActual   = "integer"
+                               }) e k
             String _ ->
-              error $ show $ EvalErrorType $ TypeError
-                                { _typeErrorExpected = "id"
-                                , _typeErrorActual   = "string"
-                                }
+              Er (EvalErrorType
+                  $ TypeError { _typeErrorExpected = "id"
+                              , _typeErrorActual   = "string"
+                              }) e k
             List _ ->
-              error $ show $ EvalErrorType $ TypeError
-                                { _typeErrorExpected = "id"
-                                , _typeErrorActual   = "list"
-                                }
+              Er (EvalErrorType
+                  $ TypeError { _typeErrorExpected = "id"
+                              , _typeErrorActual   = "list"
+                              }) e k
             name@(Id _) -> Down (unCore scope) env (InScope name env kont)
-      other -> error $ "In Ident " ++ show other
+      other -> Up (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
 
@@ -240,19 +243,18 @@ step (Up v e k) =
           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"
-              }
+              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
 
     -- done
     (InList scope [] dones env kont) ->
@@ -321,7 +323,7 @@ step (Down c env k)  =
     (CoreVar var) ->
       case lookupVal var env of
         Just val -> Up val env k
-        _        -> error $ show $ EvalErrorUnbound var
+        _        -> Er (EvalErrorUnbound var) env k
 
     (CoreLet ident var def body) ->
       Down (unCore def) env (InLetDef ident var (unCore body) env k)
@@ -379,16 +381,16 @@ step (Down c env k)  =
     (CoreSyntaxError err) ->
       Down (unCore $ _syntaxErrorMessage err) env (InSyntaxErrorMessage (_syntaxErrorLocations err) env k)
 
+-- for now we just throw the exception. Once we have a debugger we'll do
+-- something more advanced.
+step (Er err env k)  = error $ show err
 
 -- -----------------------------------------------------------------------------
 -- Helper Functions
 
 
-evalAsClosure :: Value -> Closure
-evalAsClosure = \case
-    ValueClosure closure -> closure
-    other                -> error $ show $ evalErrorType "function" other
-
+-- TODO these need to return a State to catch the Er
+-- should absord their call sites into the body of each of these functions
 evalAsInteger :: Value -> Integer
 evalAsInteger = \case
   ValueInteger i -> i
@@ -432,13 +434,15 @@ apply (FO (FOClosure {..})) value =
   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
+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