Can parse definitions

1 files changed, 14 insertions, 3 deletions

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)