From 4112ed2aeb866aa96fc8091c3d5d255dd05ac3fd Mon Sep 17 00:00:00 2001
From: Mats Rauhala <mats.rauhala@iki.fi>
Date: Sun, 3 Jan 2021 00:05:16 +0200
Subject: [PATCH] Tests for foldable

---
 buuka.cabal                        |  1 +
 default.nix                        | 13 +++---
 src/Data/Functor/Foldable.hs       |  8 ++++
 test/Test/Data/Functor/Foldable.hs | 64 +++++++++++++++++++++++++++++-
 4 files changed, 79 insertions(+), 7 deletions(-)

diff --git a/buuka.cabal b/buuka.cabal
index 546a572..bd50b4a 100644
--- a/buuka.cabal
+++ b/buuka.cabal
@@ -88,3 +88,4 @@ test-suite buuka-test
                      , tasty
                      , text
                      , aeson
+                     , deriving-compat
diff --git a/default.nix b/default.nix
index 51a4e9b..089e275 100644
--- a/default.nix
+++ b/default.nix
@@ -1,7 +1,8 @@
-{ mkDerivation, aeson, base, bytestring, containers, exceptions
-, filepath, hashable, hashids, hedgehog, hedgehog-corpus, lens, mtl
-, optparse-applicative, stdenv, tasty, tasty-hedgehog, tasty-hunit
-, text, transformers, unliftio, vector, yaml
+{ mkDerivation, aeson, base, bytestring, containers
+, deriving-compat, exceptions, filepath, hashable, hashids
+, hedgehog, hedgehog-corpus, lens, mtl, optparse-applicative
+, 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
-    tasty-hunit text
+    aeson base deriving-compat hedgehog hedgehog-corpus tasty
+    tasty-hedgehog tasty-hunit text
   ];
   license = stdenv.lib.licenses.bsd3;
 }
diff --git a/src/Data/Functor/Foldable.hs b/src/Data/Functor/Foldable.hs
index 86fb7f1..9651d8b 100644
--- a/src/Data/Functor/Foldable.hs
+++ b/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
diff --git a/test/Test/Data/Functor/Foldable.hs b/test/Test/Data/Functor/Foldable.hs
index 56f3c41..2e5aee8 100644
--- a/test/Test/Data/Functor/Foldable.hs
+++ b/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
+  ]