1 files changed, 52 insertions, 2 deletions
diff --git a/lambda-calcul/haskell/test/Minilang/Lambda/ParserSpec.hs b/lambda-calcul/haskell/test/Minilang/Lambda/ParserSpec.hs
index 13279e9..a1b47c2 100644
--- a/lambda-calcul/haskell/test/Minilang/Lambda/ParserSpec.hs
+++ b/lambda-calcul/haskell/test/Minilang/Lambda/ParserSpec.hs
@@ -1,11 +1,15 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeApplications #-}
+
 module Minilang.Lambda.ParserSpec where
 
 import Data.Text (Text, pack)
 import qualified Data.Text as Text
-import Minilang.Lambda.Parser (AST (..), initialChars, parse, restChars)
+import Minilang.Lambda.Parser (AST (..), initialChars, parse, pretty, restChars)
 import Test.Hspec (Spec, parallel, shouldBe)
 import Test.Hspec.QuickCheck (prop)
-import Test.QuickCheck (Arbitrary (..), NonEmptyList (..), elements, listOf, (==>))
+import Test.QuickCheck (Arbitrary (..), Gen, NonEmptyList (..), elements, listOf, oneof, resize, sized, (===), (==>))
 
 spec :: Spec
 spec = parallel $ do
@@ -30,6 +34,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
+
 newtype Identifier = Identifier {unIdent :: Text}
   deriving (Eq, Show)
 
@@ -37,3 +44,46 @@ instance Arbitrary Identifier where
   arbitrary =
     Identifier . pack
       <$> ((:) <$> elements initialChars <*> listOf (elements restChars))
+
+instance Arbitrary AST where
+  arbitrary = genAst 10
+
+  shrink = \case
+    Sym _ -> []
+    Abs bind body -> case shrink (Identifier <$> bind) of
+      [] -> shrink body
+      bind' ->
+        [ shrunkAbs (unIdent <$> bound) body'
+          | bound <- bind',
+            body' <- shrink body
+        ]
+        where
+          shrunkAbs [] b = b
+          shrunkAbs bound b = Abs bound b
+    App x y [] -> [x, y]
+    App x y rest -> (App x y <$> shrink rest) <> [x, y]
+
+genAst :: Int -> Gen AST
+genAst 0 = Sym . unIdent <$> arbitrary
+genAst depth =
+  oneof
+    [ Sym . unIdent <$> arbitrary,
+      genAbstraction depth,
+      genApplication depth
+    ]
+
+genApplication :: Int -> Gen AST
+genApplication depth = do
+  App <$> genAst d <*> genAst d <*> reasonablySized (listOf $ genAst d)
+  where
+    d = depth - 1
+
+genAbstraction :: Int -> Gen AST
+genAbstraction depth = do
+  x <- unIdent <$> arbitrary
+  xs <- fmap unIdent <$> reasonablySized arbitrary
+  Abs (x : xs) <$> reasonablySized (genAst $ depth - 1)
+
+reasonablySized :: Gen a -> Gen a
+reasonablySized gen = sized $ \size ->
+  resize (floor $ sqrt $ fromIntegral @_ @Double size) gen