Tests for foldable

buuka.cabal

@@ -88,3 +88,4 @@ test-suite buuka-test
                      , tasty
                      , text
                      , aeson
+                     , deriving-compat

default.nix

@@ -1,7 +1,8 @@
-{ mkDerivation, aeson, base, bytestring, containers, exceptions
+{ mkDerivation, aeson, base, bytestring, containers
-, filepath, hashable, hashids, hedgehog, hedgehog-corpus, lens, mtl
+, deriving-compat, exceptions, filepath, hashable, hashids
-, optparse-applicative, stdenv, tasty, tasty-hedgehog, tasty-hunit
+, hedgehog, hedgehog-corpus, lens, mtl, optparse-applicative
-, text, transformers, unliftio, vector, yaml
+, stdenv, tasty, tasty-hedgehog, tasty-hunit, text, transformers
+, unliftio, vector, yaml
 }:
 mkDerivation {
   pname = "buuka";
@@ -15,8 +16,8 @@ mkDerivation {
   ];
   executableHaskellDepends = [ base optparse-applicative unliftio ];
   testHaskellDepends = [
-    aeson base hedgehog hedgehog-corpus tasty tasty-hedgehog
+    aeson base deriving-compat hedgehog hedgehog-corpus tasty
-    tasty-hunit text
+    tasty-hedgehog tasty-hunit text
   ];
   license = stdenv.lib.licenses.bsd3;
 }

src/Data/Functor/Foldable.hs

@@ -17,8 +17,16 @@ module Data.Functor.Foldable
   )
   where
 
+import Data.Functor.Classes
+
 newtype Fix f = Fix { getFix :: f (Fix f) }
 
+instance Show1 f => Show (Fix f) where
+  showsPrec d (Fix f) = showString "Fix " . showsPrec1 d f
+
+instance Eq1 f => Eq (Fix f) where
+  (Fix a) == (Fix b) = liftEq (==) a b
+
 -- | Catamorphism or the fold
 --
 -- Fold a recursive structure into a value

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
+  ]