fix partiality for evaluation

chapter9/happy/Eval.hs

@@ -1,7 +1,10 @@
-module Eval where
+module Eval (
+  runEval,
+) where
+
 import Syntax
 
-import Control.Monad.Identity
+import Control.Monad.Except
 import qualified Data.Map as Map
 
 data Value
@@ -14,10 +17,11 @@ instance Show Value where
   show (VBool x) = show x
   show VClosure{} = "<<closure>>"
 
-type Evaluate t = Identity t
+type Eval t = Except String t
+
 type Scope = Map.Map String Value
 
-eval :: Eval.Scope -> Expr -> Identity Value
+eval :: Eval.Scope -> Expr -> Eval Value
 eval env expr = case expr of
   Lit (LInt x) -> return $ VInt (fromIntegral x)
   Lit (LBool x) -> return $ VBool x
@@ -41,12 +45,12 @@ binop Eql (VInt a) (VInt b) = VBool (a==b)
 extend :: Scope -> String -> Value -> Scope
 extend env v t = Map.insert v t env
 
-apply :: Value -> Value -> Evaluate Value
+apply :: Value -> Value -> Eval Value
 apply (VClosure v t0 e) t1 = eval (extend e v t1) t0
-apply _ _  = error "Tried to apply closure"
+apply _ _  = throwError "Tried to apply closure"
 
 emptyScope :: Scope
 emptyScope = Map.empty
 
-runEval :: Expr -> Value
-runEval x = runIdentity (eval emptyScope x)
+runEval :: Expr -> Either String Value
+runEval x = runExcept (eval emptyScope x)

chapter9/happy/Lexer.x

@@ -5,6 +5,9 @@ module Lexer (
 ) where
 
 import Syntax
+
+import Control.Monad.Except
+
 }
 
 %wrapper "basic"
@@ -58,6 +61,7 @@ data Token
   | TokenEOF
   deriving (Eq,Show)
 
+scanTokens :: String -> [Token]
 scanTokens = alexScanTokens
 
 }

chapter9/happy/Main.hs

@@ -1,4 +1,5 @@
-import Eval
+import Syntax (Expr)
+import Eval (runEval)
 import Parser (parseExpr, parseTokens)
 
 import Control.Monad.Trans
@@ -7,13 +8,23 @@ import System.Console.Haskeline
 process :: String -> IO ()
 process input = do
   let tokens = parseTokens input
-  print tokens
+  putStrLn ("Tokens: " ++ show tokens)
   let ast = parseExpr input
+  putStrLn ("Syntax: " ++ show ast)
   case ast of
     Left err -> do
-      putStrLn "Parser Error:"
+      putStrLn "Parse Error:"
       print err
-    Right ast -> print $ runEval ast
+    Right ast -> exec ast
+
+exec :: Expr -> IO ()
+exec ast = do
+  let result = runEval ast
+  case result of
+    Left err -> do
+      putStrLn "Runtime Error:"
+      putStrLn err
+    Right res -> print res
 
 main :: IO ()
 main = runInputT defaultSettings loop

chapter9/happy/README.md

@@ -13,16 +13,14 @@ Usage:
 
 ```ocaml
 Happy> 42
-[TokenNum 42]
+Tokens: [TokenNum 42]
+Syntax: Right (Lit (LInt 42))
 42
 
 Happy> (\x -> x) 1
-[TokenLParen,TokenLambda,TokenSym "x",TokenArrow,TokenSym "x",TokenRParen,TokenNum 1]
+Tokens: [TokenLParen,TokenLambda,TokenSym "x",TokenArrow,TokenSym "x",TokenRParen,TokenNum 1]
+Syntax: Right (App (Lam "x" (Var "x")) (Lit (LInt 1)))
 1
-
-Happy> \x -> x*x*x*x*x - x + 1
-[TokenLambda,TokenSym "x",TokenArrow,TokenSym "x",TokenMul,TokenSym "x",TokenMul,TokenSym "x",TokenMul,TokenSym "x",TokenMul,TokenSym "x",TokenSub,TokenSym "x",TokenAdd,TokenNum 1]
-<<closure>>
 ```
 
 License