From a35e8d0a47f1d356a1e9adeed340bee52451e2ce Mon Sep 17 00:00:00 2001
From: Sean Gillespie <sean@mistersg.net>
Date: Thu, 25 Jan 2018 18:09:29 -0500
Subject: [PATCH] Add support for let expressions in parser and pretty printer

---
 src/Language/Lambda/Expression.hs      | 11 +++++++++++
 src/Language/Lambda/Parser.hs          |  9 ++++++++-
 test/Language/Lambda/ExpressionSpec.hs |  7 +++++++
 test/Language/Lambda/ParserSpec.hs     |  6 +++++-
 4 files changed, 31 insertions(+), 2 deletions(-)

diff --git a/src/Language/Lambda/Expression.hs b/src/Language/Lambda/Expression.hs
index 13e29b2..7ab2e4e 100644
--- a/src/Language/Lambda/Expression.hs
+++ b/src/Language/Lambda/Expression.hs
@@ -9,6 +9,7 @@ data LambdaExpr name
   = Var name
   | App (LambdaExpr name) (LambdaExpr name)
   | Abs name (LambdaExpr name)
+  | Let name (LambdaExpr name)
   deriving (Eq, Show)
 
 -- Pretty printing
@@ -20,6 +21,7 @@ pprExpr :: PrettyPrint n => PDoc String -> LambdaExpr n -> PDoc String
 pprExpr pdoc (Var n)      = prettyPrint n `add` pdoc
 pprExpr pdoc (Abs n body) = pprAbs pdoc n body
 pprExpr pdoc (App e1 e2)  = pprApp pdoc e1 e2
+pprExpr pdoc (Let n expr) = pprLet pdoc n expr
 
 -- Pretty print an abstraction 
 pprAbs :: PrettyPrint n => PDoc String -> n -> LambdaExpr n -> PDoc String
@@ -45,6 +47,15 @@ pprApp pdoc e1@(Abs _ _) e2 = betweenParens (pprExpr pdoc e1) pdoc
 pprApp pdoc e1 e2
   = pprExpr pdoc e1 `mappend` addSpace (pprExpr pdoc e2)
 
+pprLet :: PrettyPrint n
+       => PDoc String
+       -> n
+       -> LambdaExpr n
+       -> PDoc String
+pprLet pdoc name expr
+  = intercalate ss " " pdoc
+  where ss = ["let", prettyPrint name, "=", prettyPrint expr]
+
 uncurry :: n -> LambdaExpr n -> ([n], LambdaExpr n)
 uncurry n = uncurry' [n]
   where uncurry' ns (Abs n' body') = uncurry' (n':ns) body'
diff --git a/src/Language/Lambda/Parser.hs b/src/Language/Lambda/Parser.hs
index 99fe676..a94964b 100644
--- a/src/Language/Lambda/Parser.hs
+++ b/src/Language/Lambda/Parser.hs
@@ -15,7 +15,7 @@ expr :: Parser (LambdaExpr String)
 expr = try app <|> term
 
 term :: Parser (LambdaExpr String)
-term = abs <|> var <|> parens
+term = let' <|> abs <|> var <|> parens
 
 var :: Parser (LambdaExpr String)
 var = Var <$> identifier
@@ -28,6 +28,10 @@ abs = curry <$> idents <*> expr
 app :: Parser (LambdaExpr String)
 app = chainl1 term (return App)
 
+let' :: Parser (LambdaExpr String)
+let' = Let <$> ident <*> expr
+  where ident = keyword "let" *> identifier <* symbol '='
+
 parens :: Parser (LambdaExpr String)
 parens = symbol '(' *> expr <* symbol ')'
 
@@ -44,3 +48,6 @@ identifier = lexeme ((:) <$> first <*> many rest)
 
 symbol :: Char -> Parser ()
 symbol = void . lexeme . char
+
+keyword :: String -> Parser ()
+keyword = void . lexeme . string
diff --git a/test/Language/Lambda/ExpressionSpec.hs b/test/Language/Lambda/ExpressionSpec.hs
index cb575a2..2c7314b 100644
--- a/test/Language/Lambda/ExpressionSpec.hs
+++ b/test/Language/Lambda/ExpressionSpec.hs
@@ -17,6 +17,9 @@ spec = describe "prettyPrint" $ do
       prettyPrint (App (Var "a") (Var "b"))
         `shouldBe` "a b"
 
+    it "prints simple let expressions" $
+      prettyPrint (Let "x" (Var "y")) `shouldBe` "let x = y"
+
     it "prints nested abstractions" $
       prettyPrint (Abs "f" (Abs "x" (Var "x")))
         `shouldBe` "λf x. x"
@@ -37,3 +40,7 @@ spec = describe "prettyPrint" $ do
       
       prettyPrint (App (Abs "f" (Var "f")) (Abs "g" (Var "g")))
         `shouldBe` "(λf. f) (λg. g)"
+
+    it "prints complex let expressions" $
+      prettyPrint (Let "x" (Abs "a" (Abs "b" (App (Var "a") (Var "b")))))
+        `shouldBe` "let x = λa b. a b"
diff --git a/test/Language/Lambda/ParserSpec.hs b/test/Language/Lambda/ParserSpec.hs
index 8ceddc7..9ccf365 100644
--- a/test/Language/Lambda/ParserSpec.hs
+++ b/test/Language/Lambda/ParserSpec.hs
@@ -27,13 +27,17 @@ spec = describe "parseExpr" $ do
   it "parses chained applications" $
     parseExpr "f x y" `shouldBe` Right (App (App (Var "f") (Var "x")) (Var "y"))
 
+  it "parses simple let expressions" $
+    parseExpr "let x = z" `shouldBe` Right (Let "x" (Var "z"))
+
   it "parses complex expressions" $ do
     let exprs = [
           "\\f x. f x",
           "(\\p x y. y) (\\p x y. x)",
           "f (\\x. x)",
           "(\\x . f x) g y",
-          "(\\f . (\\ x y. f x y) f x y) w x y"
+          "(\\f . (\\ x y. f x y) f x y) w x y",
+          "let x = \\f x. f x"
           ]
     
     mapM_ (flip shouldSatisfy isRight . parseExpr) exprs
-- 
GitLab