Add let support in Lambda evaluator

Author: sgillespie

src/Language/Lambda.hs

@@ -25,8 +25,7 @@ type Globals = Map.Map String (LambdaExpr String)
 evalString :: Globals
            -> String
            -> Either ParseError (LambdaExpr String, Globals)
-evalString globals str = flip (,) globals <$> eval'
-  where eval' = evalExpr uniques <$> parseExpr str
+evalString globals str = evalExpr globals uniques <$> parseExpr str
 
 uniques :: [String]
 uniques = concatMap (\p -> map (:p) . reverse $ ['a'..'z']) suffix

src/Language/Lambda/Eval.hs

@@ -3,18 +3,50 @@ module Language.Lambda.Eval where
 import Data.List
 import Data.Maybe
 
+import qualified Data.Map as Map
+
 import Language.Lambda.Expression
 
-evalExpr :: Eq n => [n] -> LambdaExpr n -> LambdaExpr n
-evalExpr uniqs (Abs name expr) = Abs name . evalExpr uniqs $ expr
-evalExpr _     expr@(Var _)    = expr
-evalExpr uniqs (App e1   e2)   = betaReduce uniqs (evalExpr uniqs e1)
-                                                  (evalExpr uniqs e2)
+-- | Evaluate an expression
+evalExpr :: (Eq n, Ord n)
+         => Map.Map n (LambdaExpr n) -- ^ globals
+         -> [n]                      -- ^ unique supply
+         -> LambdaExpr n             -- ^ the expression to evaluate
+         -> (LambdaExpr n, Map.Map n (LambdaExpr n))
+evalExpr globals uniqs (Let name expr)
+  = (Let name expr', Map.insert name expr' globals)
+  where expr' = evalExpr' uniqs (subGlobals globals expr)
+evalExpr globals uniqs expr = (evalExpr' uniqs expr', globals)
+  where expr' = subGlobals globals expr
 
-betaReduce :: Eq n => [n] -> LambdaExpr n -> LambdaExpr n -> LambdaExpr n
-betaReduce uniqs (App e1 e1') e2 = App (betaReduce uniqs e1 e1') e2
+subGlobals :: (Eq n, Ord n)
+           => Map.Map n (LambdaExpr n) -- ^ globals
+           -> LambdaExpr n             -- ^ the expression
+           -> LambdaExpr n
+subGlobals g e@(Var x) = Map.findWithDefault e x g
+subGlobals g (App e1 e2) = App (subGlobals g e1) (subGlobals g e2)
+subGlobals g (Abs n expr) = Abs n (subGlobals g expr)
+subGlobals _ expr = expr
+
+-- | Evaluate an expression; does not support `let`
+evalExpr' :: Eq n
+          => [n]                      -- ^ unique supply
+          -> LambdaExpr n             -- ^ the expression to evaluate
+          -> LambdaExpr n
+evalExpr' _     expr@(Var _) = expr
+evalExpr' uniqs (Abs name expr) = Abs name . evalExpr' uniqs $ expr
+evalExpr' uniqs (Let name expr) = Let name . evalExpr' uniqs $ expr
+evalExpr' uniqs (App e1 e2)     = betaReduce uniqs (evalExpr' uniqs e1)
+                                                   (evalExpr' uniqs e2)
+
+betaReduce :: Eq n
+           => [n]
+           -> LambdaExpr n
+           -> LambdaExpr n
+           -> LambdaExpr n
 betaReduce _     expr@(Var _) e2 = App expr e2
-betaReduce uniqs (Abs n  e1)  e2 = evalExpr uniqs . sub n e1' $ e2
+betaReduce uniqs (App e1 e1') e2 = App (betaReduce uniqs e1 e1') e2
+betaReduce uniqs (Abs n  e1)  e2 = evalExpr' uniqs . sub n e1' $ e2
   where fvs = freeVarsOf e2
         e1' = alphaConvert uniqs fvs e1
 

test/Language/Lambda/EvalSpec.hs

@@ -1,5 +1,6 @@
 module Language.Lambda.EvalSpec where
 
+import Data.Map (empty, insert)
 import Test.Hspec
 
 import Language.Lambda
@@ -9,7 +10,7 @@ import Language.Lambda.Expression
 spec :: Spec
 spec = do
   describe "evalExpr" $ do
-    let evalExpr' = evalExpr uniques
+    let evalExpr' = fst <$> evalExpr empty uniques
 
     it "beta reduces" $ do
       let expr = App (Abs "x" (Var "x")) (Var "z")
@@ -28,6 +29,23 @@ spec = do
                      (Abs "f" (Var "x"))
       evalExpr' expr `shouldBe` Abs "z" (Var "x")
 
+    it "reduces let bodies" $ do
+      let expr = Let "x" $ App (Abs "y" (Var "y")) (Var "z")
+      evalExpr' expr `shouldBe` Let "x" (Var "z")
+
+    it "let expressions update state" $ do
+      let expr = Let "w" (Var "x")
+          (_, globals) = evalExpr empty uniques expr
+
+      globals `shouldBe` insert "w" (Var "x") empty
+
+    it "subs global variables" $ do
+      let globals = insert "w" (Var "x") empty
+          expr = Var "w"
+
+      fst (evalExpr globals uniques expr)
+        `shouldBe` Var "x"
+
   describe "betaReduce" $ do
     let betaReduce' = betaReduce []