fix call-by-value evaluator base on NBE

1 files changed, 13 insertions, 6 deletions

diff --git a/lambda-calcul/haskell/src/Minilang/Lambda/Eval.hs b/lambda-calcul/haskell/src/Minilang/Lambda/Eval.hs
index 9d56c49..e5530eb 100644
--- a/lambda-calcul/haskell/src/Minilang/Lambda/Eval.hs
+++ b/lambda-calcul/haskell/src/Minilang/Lambda/Eval.hs
@@ -4,7 +4,8 @@
 module Minilang.Lambda.Eval where
 
 import Data.Aeson (FromJSON, ToJSON)
-import Data.Text (Text)
+import Data.String (IsString (..))
+import Data.Text (Text, pack)
 import GHC.Generics (Generic)
 
 data Term
@@ -13,6 +14,9 @@ data Term
   | App Term Term
   deriving (Show, Read, Eq, Generic, ToJSON, FromJSON)
 
+instance IsString Term where
+  fromString = Var . pack
+
 data Value = Clos EnvValue Text Term | VNeut Neutral
   deriving (Show, Read, Eq)
 
@@ -26,15 +30,21 @@ type EnvValue = [(Text, Value)]
 newEnv :: Env
 newEnv = []
 
+normalise :: Term -> Term
+normalise term = readBack (eval [] term)
+
 -- call-by-value evaluator
 -- from https://davidchristiansen.dk/tutorials/nbe/#%28part._untyped-eval%29
 eval :: EnvValue -> Term -> Value
 eval env = \case
   Var x -> case lookup x env of
     Just term -> term
-    Nothing -> error $ "Unbound variable: " ++ show x
+    Nothing -> VNeut (NVar x)
   Lam x body -> Clos env x body
-  App f a -> apply (eval env f) (eval env a)
+  App f a ->
+    let f' = eval env f
+        a' = eval env a
+     in f' `seq` a' `seq` apply f' a'
 
 apply :: Value -> Value -> Value
 apply f a =
@@ -56,9 +66,6 @@ readBack = go []
       VNeut (NVar n) -> Var n
       VNeut (NApp f a) -> App (go names (VNeut f)) (go names a)
 
-normalise :: Term -> Term
-normalise term = readBack (eval [] term)
-
 freshName :: Text -> [Text] -> Text
 freshName x names
   | x `elem` names = freshName (x <> "'") names