69 lines
1.6 KiB
Haskell
69 lines
1.6 KiB
Haskell
{-# 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
|
|
]
|