Free.hs

{-# LANGUAGE TemplateHaskell #-}
module Test.Data.Algebra.Free
    ( tests
    ) where

import           Control.Monad (join)
import           Data.List.NonEmpty (NonEmpty (..))
import           Data.Foldable (fold)
import           Data.Monoid (Sum (..))
import           Hedgehog (Property, Gen, property, (===))
import qualified Hedgehog as H
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range

import           Data.Algebra.Free
    ( AlgebraType
    , AlgebraType0
    , FreeAlgebra (..)
    , foldFree
    , unFoldMapFree
    , natFree
    , fmapFree
    , joinFree
    , bindFree
    )

natFree_property
    :: ( FreeAlgebra  f
       , AlgebraType0 f a
       , AlgebraType  f (f a)
       , Eq (f a)
       , Show (f a)
       )
    => Gen (f a) -> Property
natFree_property gen = property $ do
    fa <- H.forAll gen
    natFree fa === fa

prop_natFree_list :: Property
prop_natFree_list = natFree_property
    $ Gen.list (Range.linear 0 100) Gen.alpha

prop_nafF_nonempty :: Property
prop_nafF_nonempty = natFree_property
    $ Gen.nonEmpty (Range.linear 0 100) Gen.alpha

-- |
-- Check that @'foldFree' is @'fold'@ for @f@ which are @'Foldable'@ and @a@ which
-- are @'Monoid' a.
foldFree_property
    :: ( FreeAlgebra  f
       , AlgebraType0 f a
       , AlgebraType  f a
       , Monoid a   -- fold brings this constraint, @'foldFree'@ is free of it!
       , Foldable f
       , Eq a
       , Eq (f a)
       , Show a
       , Show (f a)
       )
    => Gen (f a)
    -> Property
foldFree_property gen = property $ do
    fa <- H.forAll gen
    foldFree fa === fold fa

prop_foldFree_list :: Property
prop_foldFree_list = foldFree_property 
    $ (Gen.list $ Range.linear 0 100)
        (Sum <$> Gen.word32 (Range.linear 0 1024))

prop_foldFree_nonempty :: Property
prop_foldFree_nonempty = foldFree_property
    $ (Gen.nonEmpty $ Range.linear 0 100)
        (Sum <$> Gen.word32 (Range.linear 0 1024))

-- |
-- @'fmapFoldFree'@ is inverse of @'unFoldMapFree'@
foldMapFree_property
    :: forall f d a .
       ( FreeAlgebra  f
       , AlgebraType0 f d
       , AlgebraType0 f a
       , AlgebraType  f d
       , Show (f a)
       , Show a
       , Show d
       , Eq d
       )
    => Gen (f a)
    -> Gen a
    -> (f a -> d)
    -> (a -> d)
    -> Property
foldMapFree_property gen_fa gen fad ad = property $ do
    fa <- H.forAll gen_fa
    a  <- H.forAll gen
    unFoldMapFree (foldMapFree @f ad) a === ad a
    foldMapFree (unFoldMapFree @f fad) fa === fad fa

prop_foldMapFree_list :: Property
prop_foldMapFree_list
    = foldMapFree_property @[] @(Sum Int) @Int
        ((Gen.list $ Range.linear 0 100)
            (Gen.integral $ Range.linear 0 1024))
        (Gen.integral $ Range.linear 0 1024)
        (Sum . sum)
        Sum

prop_foldMapFree_nonempty :: Property
    = foldMapFree_property @NonEmpty @(Sum Int) @Int
        ((Gen.nonEmpty $ Range.linear 0 100)
            (Gen.integral $ Range.linear 0 1024))
        (Gen.integral $ Range.linear 0 1024)
        (Sum . sum)
        Sum

-- |
-- @'fmapFree'@ should aggree with @'fmap'@ for types which satisfy @'Functor'@
-- constraint.
fmapFree_property
    :: forall f a b .
       ( FreeAlgebra  f
       , AlgebraType0 f a
       , AlgebraType0 f b
       , Functor f
       , Show (f a)
       , Eq (f a)
       , Show (f b)
       , Eq (f b)
       )
    => Gen (f a)
    -> (a -> b)
    -> Property
fmapFree_property gen f = property $ do
    fa <- H.forAll gen
    fmapFree f fa === fmap f fa

prop_fmapFree_list :: Property
prop_fmapFree_list = fmapFree_property @[] @Integer @Integer
    ((Gen.list $ Range.linear 0 100)
        (Gen.integral $ Range.linear 0 1024))
    (\x -> x^2 + 2 * x + 1)

prop_fmapFree_nonempty :: Property
prop_fmapFree_nonempty = fmapFree_property
    ((Gen.nonEmpty $ Range.linear 0 100)
        (Gen.integral $ Range.linear 0 1024))
    (\x -> x^2 + 2 * x + 1)

-- |
-- @'joinFree'@ should be equal to @'join'@ for monads.
joinFree_property
    :: ( FreeAlgebra  m
       , AlgebraType0 m a
       , AlgebraType0 m (m a)
       , AlgebraType  m (m a)
       , Monad m
       , Show (m (m a))
       , Eq (m (m a))
       , Show (m a)
       , Eq (m a)
       )
    => Gen (m (m a))
    -> Property
joinFree_property gen = property $ do
    mma <- H.forAll gen
    joinFree mma === join mma

prop_joinFree_list :: Property
prop_joinFree_list =
    let gen = Gen.list (Range.linear 0 100)
                (Gen.list (Range.linear 0 10) Gen.alpha)
    in joinFree_property gen

prop_joinFree_nonempty :: Property
prop_joinFree_nonempty =
    let gen = Gen.nonEmpty (Range.linear 0 100)
                (Gen.nonEmpty (Range.linear 0 10) Gen.alpha)
    in joinFree_property gen

-- |
-- @'bindFree'@ should be equal to @'>>='@ for monads.
bindFree_property
    :: ( FreeAlgebra  m
       , AlgebraType0 m a
       , AlgebraType0 m b
       , AlgebraType0 m (m b)
       , AlgebraType  m (m a)
       , AlgebraType  m (m b)
       , AlgebraType  m (m (m b))
       , Monad m
       , Show (m a)
       , Eq (m a)
       , Show (m b)
       , Eq (m b)
       )
    => Gen (m a)
    -> (a -> m b)
    -> Property
bindFree_property gen f = property $ do
    ma <- H.forAll gen
    bindFree ma f === (ma >>= f)

prop_bindFree_list :: Property
prop_bindFree_list =
    let gen = Gen.list
            (Range.linear 0 10)
            (Gen.integral $ Range.linear 0 1024)
    in bindFree_property gen (\x -> [x^2, 2 * x, 1])

prop_bindFree_nonempty :: Property
prop_bindFree_nonempty =
    let gen = Gen.nonEmpty
            (Range.linear 0 10)
            (Gen.integral $ Range.linear 0 1024)
    in bindFree_property gen (\x -> x^2 :| [2 * x, 1])

tests :: IO Bool
tests = H.checkParallel $$(H.discover)