wrk: misc cleanup

klister.cabal

@@ -42,7 +42,6 @@ common deps
     megaparsec           >= 7.0.5 && < 9.7,
     mtl                  >= 2.2.2 && < 2.4,
     prettyprinter        >= 1.2 && < 1.8,
-    prettyprinter        >= 1.2 && < 1.8,
     text                 >= 1.2,
     transformers         ^>= 0.6
 

src/Evaluator.hs

@@ -83,6 +83,7 @@ module Evaluator
   , try
   , projectError
   , projectKont
+  , constructErrorType
   ) where
 
 import Control.Lens hiding (List, elements)
@@ -101,8 +102,6 @@ import Syntax.SrcLoc
 import Type
 import Value
 
-import Debug.Trace
-
 -- -----------------------------------------------------------------------------
 -- Interpreter Data Types
 
@@ -119,7 +118,6 @@ data TypeError = TypeError
   , _typeErrorActual   :: Type
   }
   deriving (Eq, Show)
-makeLenses ''TypeError
 
 data EvalError
   = EvalErrorUnbound Var
@@ -578,9 +576,21 @@ 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
-    }
+  { _typeErrorExpected = expected
+  , _typeErrorActual   = describeVal got
+  }
+
+-- this is a copy of 'evalErrorType' but with no memory of how we got to this
+-- error state. This should just be a stopgap and we should remove it. Its sole
+-- use case is in the expander where we have redundant error checks due to
+-- functions such as @doTypeCase@
+constructErrorType :: Text -> Value -> EState
+constructErrorType expected got = Er err mempty Halt
+  where
+    err = EvalErrorType $ TypeError
+      { _typeErrorExpected = expected
+      , _typeErrorActual   = describeVal got
+      }
 
 doTypeCase :: VEnv -> SrcLoc -> Ty -> [(TypePattern, Core)] -> Either EState Value
 -- We pass @Right $ ValueType v0@ here so that the Core type-case still matches

src/Expander.hs

@@ -912,8 +912,7 @@ runTask (tid, localData, task) = withLocal localData $ do
               forkInterpretMacroAction dest nextStep kont
             otherVal -> do
               p <- currentPhase
-              -- debug $ MacroEvaluationError p $ evalErrorType "macro action" otherVal
-              error "MacroEvaluationError p $ evalErrorType \"macro action\" otherVal"
+              debug $ MacroEvaluationError p $ constructErrorType "macro action" otherVal
           Left err -> do
             -- an error occurred in the evaluator, so just report it
             p <- currentPhase
@@ -982,8 +981,7 @@ runTask (tid, localData, task) = withLocal localData $ do
           forkExpandSyntax dest syntax
         other -> do
           p <- currentPhase
-          -- debug $ MacroEvaluationError p $ evalErrorType "syntax" other
-          error "MacroEvaluationError p $ evalErrorType \"syntax\" other"
+          debug $ MacroEvaluationError p $ constructErrorType "syntax" other
     ContinueMacroAction dest value (closure:kont) -> do
       case apply closure value of
         Left err -> do
@@ -995,8 +993,7 @@ runTask (tid, localData, task) = withLocal localData $ do
               forkInterpretMacroAction dest macroAction kont
             other -> do
               p <- currentPhase
-              -- debug $ MacroEvaluationError p $ evalErrorType "macro action" other
-              error "MacroEvaluationError p $ evalErrorType \"macro action\" other"
+              debug $ MacroEvaluationError p $ constructErrorType "macro action" other
     EvalDefnAction x n p expr ->
       linkedCore expr >>=
       \case
@@ -1325,15 +1322,11 @@ expandOneForm prob stx
                         ValueSyntax expansionResult ->
                           forkExpandSyntax prob (flipScope p stepScope expansionResult)
                         other -> debug $ ValueNotSyntax other
-                  other -> error "ValueNotMacro other"
-                    -- debug $ ValueNotMacro other
-            Nothing -> error $ show $ InternalError $
+                  other -> debug $ ValueNotMacro $ constructErrorType "error in user macro" other
+            Nothing -> debug $ InternalError $
               "No transformer yet created for " ++ shortShow ident ++
               " (" ++ show transformerName ++ ") at phase " ++ shortShow p
-              -- debug $ InternalError $
-              -- "No transformer yet created for " ++ shortShow ident ++
-              -- " (" ++ show transformerName ++ ") at phase " ++ shortShow p
-            Just other -> error "debug $ ValueNotMacro other"
+            Just other -> debug $ ValueNotMacro $ constructErrorType "expected macro but got value" other
   | otherwise =
     case prob of
       ModuleDest {} ->