Tests for foldable

test/Test/Data/Functor/Foldable.hs

@@ -1,6 +1,68 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TemplateHaskell #-}
 module Test.Data.Functor.Foldable where
 
+import Hedgehog
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
 import Test.Tasty
+import Test.Tasty.Hedgehog
+
+import Data.Eq.Deriving
+       (deriveEq1)
+import Text.Show.Deriving
+       (deriveShow1)
+
+import Data.Functor.Foldable
+
+data AST f
+  = Addition f f
+  | Value Int
+  deriving stock (Functor, Eq, Show)
+
+deriveShow1 ''AST
+deriveEq1 ''AST
+
+evaluate :: AST Int -> Int
+evaluate = \case
+  Addition a b -> a + b
+  Value x -> x
+
+render :: AST String -> String
+render = \case
+  Addition a b -> a <> " + " <> b
+  Value x -> show x
+
+parse :: [String] -> AST [String]
+parse = \case
+  a : "+" : b : xs -> Addition (a : xs) [b]
+  [a] -> Value (read a)
+  _ -> Value 0
+
+genAST :: Gen (Fix AST)
+genAST = Gen.recursive Gen.choice
+  [ Fix . Value <$> Gen.integral (Range.linear 0 100) ]
+  [ Gen.subterm2 genAST genAST (\a b -> Fix (Addition a b))
+  ]
+
+prop_parse_render_tripping :: Property
+prop_parse_render_tripping = property $ do
+  x <- forAll genAST
+  let rendered = cata render x
+      parsed = ana parse . words $ rendered
+  annotateShow rendered
+  annotateShow parsed
+  annotateShow $ cata evaluate x
+  cata evaluate parsed === cata evaluate x
+
+prop_parse_render_hylo :: Property
+prop_parse_render_hylo = property $ do
+  x <- forAll genAST
+  let rendered = cata render x
+  hylo evaluate parse (words rendered) === cata evaluate x
 
 tests :: TestTree
-tests = testGroup "Data.Functor.Foldable" []
+tests = testGroup "Data.Functor.Foldable"
+  [ testProperty "cata and ana do reverse" $ prop_parse_render_tripping
+  , testProperty "hylo do reverse" $ prop_parse_render_hylo
+  ]