buuka/test/Test/Data/Functor/Foldable.hs

{-# 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"
  [ testProperty "cata and ana do reverse" $ prop_parse_render_tripping
  , testProperty "hylo do reverse" $ prop_parse_render_hylo
  ]