feat: pretty-print expressions

2 files changed, 63 insertions, 3 deletions

diff --git a/lambda-calcul/haskell/src/Minilang/Lambda/Parser.hs b/lambda-calcul/haskell/src/Minilang/Lambda/Parser.hs
index f18ac74..28da47f 100644
--- a/lambda-calcul/haskell/src/Minilang/Lambda/Parser.hs
+++ b/lambda-calcul/haskell/src/Minilang/Lambda/Parser.hs
@@ -1,8 +1,12 @@
+{-# LANGUAGE LambdaCase #-}
+
 module Minilang.Lambda.Parser where
 
 import Control.Applicative (Alternative (many), (<|>))
 import Data.Bifunctor (first)
-import Data.Text (Text, pack)
+import qualified Data.List as List
+import Data.Text (Text, intersperse, pack)
+import qualified Data.Text as Text
 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)
@@ -16,6 +20,12 @@ data ParseError = ParseError Text
 data AST = Sym Text | Abs [Text] AST | App AST AST [AST]
   deriving (Eq, Show)
 
+pretty :: AST -> Text
+pretty = \case
+  Sym sym -> sym
+  Abs bound body -> "(lam (" <> Text.unwords bound <> ") " <> pretty body <> ")"
+  App x y rest -> "(" <> mconcat (List.intersperse " " (pretty <$> (x : y : rest))) <> ")"
+
 parse :: Text -> Either ParseError AST
 parse =
   first (ParseError . pack . errorBundlePretty) . Text.Megaparsec.parse ast ""
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