From c8ab7d2dcf85c5cec86d1a06ba54ab97198c6114 Mon Sep 17 00:00:00 2001
From: Sean Gillespie <sean@mistersg.net>
Date: Sat, 27 Jan 2018 18:51:18 -0500
Subject: [PATCH] Add let support in Lambda evaluator
---
src/Language/Lambda.hs | 3 +-
src/Language/Lambda/Eval.hs | 48 ++++++++++++++++++++++++++------
test/Language/Lambda/EvalSpec.hs | 20 ++++++++++++-
3 files changed, 60 insertions(+), 11 deletions(-)
diff --git a/src/Language/Lambda.hs b/src/Language/Lambda.hs
index 3ba7d4d..0311263 100644
--- a/src/Language/Lambda.hs
+++ b/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
diff --git a/src/Language/Lambda/Eval.hs b/src/Language/Lambda/Eval.hs
index e6532c3..8400022 100644
--- a/src/Language/Lambda/Eval.hs
+++ b/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
diff --git a/test/Language/Lambda/EvalSpec.hs b/test/Language/Lambda/EvalSpec.hs
index bf7e41e..21afaf9 100644
--- a/test/Language/Lambda/EvalSpec.hs
+++ b/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 []
--
GitLab