Fold.hs

module Spec.HTree.Fold (spec) where

import Data.Functor.Identity (Identity)
import Data.HTree (hcFoldMap)
import Data.HTree.Existential (Has (Proves), Some (MkSome), hcFoldEHList, hcFoldMapEHTree)
import Data.Semigroup (Product (Product, getProduct), Sum (Sum, getSum))
import Data.Set (Set, empty, insert, singleton)
import Data.Tree (Tree)
import Data.Typeable (Typeable, typeOf)
import GHC.Real ((%))
import Spec.HTree.Fixtures (exIntegral, exReal)
import Spec.HTree.Orphans (toEList, toETree)
import Test.Hspec (Spec, describe, it)
import Test.Hspec.QuickCheck (modifyMaxSuccess, prop)
import Test.QuickCheck (Property, (===))

spec :: Spec
spec = do
  describe "folding an HTree of numbers" do
    it "calculates the correct sum" (31649046316921651 % 281474976710656 == getSum (hcFoldMap @Real (Sum . toRational) exReal))
    it "calculates the correct product" (308407698144 == getProduct (hcFoldMap @Integral (Product . toInteger) exIntegral))
    modifyMaxSuccess (* 10) do
      prop "yields the same results as expected for many Lists" $
        foldsSameList @Identity
      prop "yields the same results as expected for many trees" $
        foldsSameTree @Identity

foldsSameList
  :: forall f
   . ( forall x. Eq x => Eq (f x)
     , forall x. Ord x => Ord (f x)
     , Typeable f
     , Applicative f
     )
  => [Some (Has Typeable (Has Ord f))]
  -> Property
foldsSameList l =
  let folded :: Set (String, Some (Has Typeable (Has Ord f)))
      folded =
        foldMap
          (\(MkSome (Proves f)) -> singleton (show (typeOf f), MkSome (Proves f)))
          l
      hfolded :: Set (String, Some (Has Typeable (Has Ord f)))
      hfolded =
        hcFoldEHList @Typeable
          (\f acc -> (show (typeOf f), MkSome (Proves f)) `insert` acc)
          empty
          (toEList l)
   in folded === hfolded

foldsSameTree
  :: forall f
   . ( forall x. Eq x => Eq (f x)
     , forall x. Ord x => Ord (f x)
     , Typeable f
     , Applicative f
     )
  => Tree (Some (Has Typeable (Has Ord f)))
  -> Property
foldsSameTree l =
  let folded :: Set (String, Some (Has Typeable (Has Ord f)))
      folded =
        foldMap
          (\(MkSome (Proves f)) -> singleton (show (typeOf f), MkSome (Proves f)))
          l
      hfolded :: Set (String, Some (Has Typeable (Has Ord f)))
      hfolded =
        hcFoldMapEHTree @Typeable
          (\f -> singleton (show (typeOf f), MkSome (Proves f)))
          (toETree l)
   in folded === hfolded