2 files changed, 47 insertions, 3 deletions
diff --git a/lambda-calcul/haskell/src/Minilang/Lambda/Parser.hs b/lambda-calcul/haskell/src/Minilang/Lambda/Parser.hs
index 28da47f..37834d3 100644
--- a/lambda-calcul/haskell/src/Minilang/Lambda/Parser.hs
+++ b/lambda-calcul/haskell/src/Minilang/Lambda/Parser.hs
@@ -11,6 +11,8 @@ import Data.Void (Void)
 import Text.Megaparsec (Parsec, between, empty, errorBundlePretty, manyTill, notFollowedBy, optional, parse, try)
 import Text.Megaparsec.Char (alphaNumChar, char, letterChar, space1, string, symbolChar)
 import qualified Text.Megaparsec.Char.Lexer as L
+import Minilang.Lambda.Eval (Term)
+import qualified Minilang.Lambda.Eval as Eval
 
 type Parser = Parsec Void Text
 
@@ -20,6 +22,20 @@ data ParseError = ParseError Text
 data AST = Sym Text | Abs [Text] AST | App AST AST [AST]
   deriving (Eq, Show)
 
+desugar :: AST -> Term
+desugar = \case
+  Sym sym -> Eval.Var sym
+  Abs bound body ->
+    foldr
+      Eval.Lam
+      (desugar body)
+      bound
+  App x y rest ->
+    foldl
+      (\acc a -> Eval.App acc (desugar a))
+      (Eval.App (desugar x) (desugar y))
+      rest
+
 pretty :: AST -> Text
 pretty = \case
   Sym sym -> sym
diff --git a/lambda-calcul/haskell/test/Minilang/Lambda/ParserSpec.hs b/lambda-calcul/haskell/test/Minilang/Lambda/ParserSpec.hs
index a1b47c2..d4c90bd 100644
--- a/lambda-calcul/haskell/test/Minilang/Lambda/ParserSpec.hs
+++ b/lambda-calcul/haskell/test/Minilang/Lambda/ParserSpec.hs
@@ -1,15 +1,17 @@
-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Minilang.Lambda.ParserSpec where
 
+import Data.Function ((&))
 import Data.Text (Text, pack)
 import qualified Data.Text as Text
-import Minilang.Lambda.Parser (AST (..), initialChars, parse, pretty, restChars)
+import Minilang.Lambda.Eval (Term (Lam))
+import qualified Minilang.Lambda.Eval as Eval
+import Minilang.Lambda.Parser (AST (..), desugar, initialChars, parse, pretty, restChars)
 import Test.Hspec (Spec, parallel, shouldBe)
 import Test.Hspec.QuickCheck (prop)
-import Test.QuickCheck (Arbitrary (..), Gen, NonEmptyList (..), elements, listOf, oneof, resize, sized, (===), (==>))
+import Test.QuickCheck (Arbitrary (..), Gen, NonEmptyList (..), counterexample, elements, forAll, forAllShrink, listOf, oneof, resize, sized, (===), (==>))
 
 spec :: Spec
 spec = parallel $ do
@@ -37,6 +39,32 @@ spec = parallel $ do
   prop "parses is inverse to pretty" $ \ast ->
     parse (pretty ast) === Right ast
 
+  prop "desugars abstractions to λ-terms" $ forAll (genAbstraction 5) $ \ast ->
+    let term = desugar ast
+        ar = arity ast
+        nestedAbs (Lam _ body) = 1 + nestedAbs body
+        nestedAbs _ = 0
+     in nestedAbs term === ar
+          & counterexample ("Desugared term: " <> show term)
+
+  prop "desugars applications to app-terms" $ forAllShrink (genApplication 5) shrink $ \ast ->
+    let term = desugar ast
+        ar = spine ast
+        nestedApp (Eval.App l _) = 1 + nestedApp l
+        nestedApp _ = 0
+     in nestedApp term === ar
+          & counterexample ("Desugared term: " <> show term)
+
+spine :: AST -> Int
+spine = \case
+  App x y rest -> 1 + spine x + length rest
+  _ -> 0
+
+arity :: AST -> Int
+arity = \case
+  Abs bind body -> length bind + arity body
+  _ -> 0
+
 newtype Identifier = Identifier {unIdent :: Text}
   deriving (Eq, Show)