From 94214ce9a82643a4fa2776ee972636a3d0539a54 Mon Sep 17 00:00:00 2001
From: Arnaud Bailly <arnaud@pankzsoft.com>
Date: Mon, 3 Nov 2025 22:32:26 +0100
Subject: Can parse definitions

---
 .../haskell/src/Minilang/Lambda/Parser.hs          | 26 +++++++++++++++++-----
 .../haskell/test/Minilang/Lambda/ParserSpec.hs     | 17 +++++++++++---
 2 files changed, 35 insertions(+), 8 deletions(-)

diff --git a/lambda-calcul/haskell/src/Minilang/Lambda/Parser.hs b/lambda-calcul/haskell/src/Minilang/Lambda/Parser.hs
index e15dc00..b0f4b8f 100644
--- a/lambda-calcul/haskell/src/Minilang/Lambda/Parser.hs
+++ b/lambda-calcul/haskell/src/Minilang/Lambda/Parser.hs
@@ -1,29 +1,33 @@
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE LambdaCase #-}
 
 module Minilang.Lambda.Parser where
 
 import Control.Applicative (Alternative (many), (<|>))
+import Data.Aeson (FromJSON, ToJSON)
 import Data.Bifunctor (first)
 import Data.Functor (void)
 import qualified Data.List as List
 import Data.Text (Text, pack)
 import qualified Data.Text as Text
 import Data.Void (Void)
+import GHC.Generics (Generic)
 import Minilang.Lambda.Eval (Term)
 import qualified Minilang.Lambda.Eval as Eval
 import Text.Megaparsec (Parsec, between, empty, errorBundlePretty, parse, some, try)
 import Text.Megaparsec.Char (alphaNumChar, char, letterChar, space1, symbolChar)
 import qualified Text.Megaparsec.Char.Lexer as L
-import GHC.Generics (Generic)
-import Data.Aeson (ToJSON, FromJSON)
 
 type Parser = Parsec Void Text
 
 data ParseError = ParseError Text
   deriving (Eq, Show)
 
-data AST = Sym Text | Abs [Text] AST | App AST AST [AST]
+data AST
+  = Sym Text
+  | Abs [Text] AST
+  | App AST AST [AST]
+  | Def Text AST
   deriving (Eq, Show, Generic, ToJSON, FromJSON)
 
 desugar :: AST -> Term
@@ -39,6 +43,8 @@ desugar = \case
       (\acc a -> Eval.App acc (desugar a))
       (Eval.App (desugar x) (desugar y))
       rest
+  Def _name _body ->
+    undefined
 
 resugar :: Term -> AST
 resugar = \case
@@ -59,13 +65,14 @@ pretty = \case
   Sym symb -> symb
   Abs bound body -> "(lam (" <> Text.unwords bound <> ") " <> pretty body <> ")"
   App x y rest -> "(" <> mconcat (List.intersperse " " (pretty <$> (x : y : rest))) <> ")"
+  Def name body -> "(def " <> name <> " " <> pretty body <> ")"
 
 parse :: Text -> Either ParseError AST
 parse =
   first (ParseError . pack . errorBundlePretty) . Text.Megaparsec.parse ast ""
 
 ast :: Parser AST
-ast = try letExpr <|> try lambda <|> try sym <|> try app
+ast = try defExpr <|> try letExpr <|> try lambda <|> try sym <|> try app
 
 app :: Parser AST
 app =
@@ -85,6 +92,15 @@ lambda =
            )
     )
 
+defExpr :: Parser AST
+defExpr =
+  between
+    lpar
+    rpar
+    ( lexeme "def"
+        *> ((Def . pack <$> identifier) <*> ast)
+    )
+
 letExpr :: Parser AST
 letExpr =
   between
diff --git a/lambda-calcul/haskell/test/Minilang/Lambda/ParserSpec.hs b/lambda-calcul/haskell/test/Minilang/Lambda/ParserSpec.hs
index f79053c..2988b56 100644
--- a/lambda-calcul/haskell/test/Minilang/Lambda/ParserSpec.hs
+++ b/lambda-calcul/haskell/test/Minilang/Lambda/ParserSpec.hs
@@ -4,6 +4,7 @@
 
 module Minilang.Lambda.ParserSpec where
 
+import Control.Applicative ((<|>))
 import Data.Either (isRight)
 import Data.Function ((&))
 import Data.Text (Text, pack)
@@ -11,7 +12,7 @@ import qualified Data.Text as Text
 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, shouldSatisfy)
+import Test.Hspec (Spec, it, parallel, shouldBe, shouldSatisfy)
 import Test.Hspec.QuickCheck (prop)
 import Test.QuickCheck
   ( Arbitrary (..),
@@ -56,8 +57,9 @@ spec = parallel $ do
           app = App (Sym a) (Sym b) (Sym <$> rest)
        in parse ("(" <> Text.unwords vars <> ")") `shouldBe` Right app
 
-  prop "parses is inverse to pretty" $ \ast ->
-    parse (pretty ast) === Right ast
+  prop "parses is inverse to pretty" $
+    forAllShrink (oneof [genAst 5, genDef 5]) shrink $ \ast ->
+      parse (pretty ast) === Right ast
 
   prop "desugars abstractions to λ-terms" $ forAll (genAbstraction 5) $ \ast ->
     let term = desugar ast
@@ -97,6 +99,11 @@ spec = parallel $ do
                 )
                 `shouldSatisfy` isRight
 
+  it "parses a definition" $ do
+    let defStr = "(def id (lam (x) x))"
+        expectedAST = Def "id" (Abs ["x"] (Sym "x"))
+    parse defStr `shouldBe` Right expectedAST
+
 spine :: AST -> Int
 spine = \case
   App x y rest -> 1 + spine x + length rest
@@ -132,6 +139,7 @@ instance Arbitrary AST where
           shrunkAbs bound b = Abs bound b
     App x y [] -> [x, y]
     App x y rest -> (App x y <$> shrink rest) <> [x, y]
+    Def _name body -> shrink body -- never generated
 
 genAst :: Int -> Gen AST
 genAst 0 = Sym . unIdent <$> arbitrary
@@ -142,6 +150,9 @@ genAst depth =
       genApplication depth
     ]
 
+genDef :: Int -> Gen AST
+genDef n = Def . unIdent <$> arbitrary <*> genAst n
+
 genApplication :: Int -> Gen AST
 genApplication depth = do
   App <$> genAst d <*> genAst d <*> reasonablySized (listOf $ genAst d)
-- 
cgit v1.3.1