compactable-0.2.0.0: test/ExpansiveSpec.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}


module ExpansiveSpec where


import           Control.Functor.Compactable (Compactable (..), separate)
import           Control.Functor.Dichotomous (Dichotomous (ymotohcid),
                                              These (..), TheseOrNot, swap)
import           Control.Functor.Expansive   (Expansive (..), unite,
                                              uniteDichotomy)

import           Control.Applicative         (Alternative (empty), ZipList)
import           Data.Bifunctor              (bimap)
import           Data.Functor.Product        (Product)
import           Data.IntMap                 (IntMap)
import           Data.Map                    (Map)
import           Data.Proxy                  (Proxy)
import           Data.Semigroup              (Option)
import           Data.Sequence               (Seq)
import           Data.Vector                 (Vector)

import           Core                        (Case', limitSize)
import           Test.QuickCheck             (Fun, Testable (property),
                                              applyFun)
import           Test.Syd                    (SpecWith, describe, it)


type Case g f = Case' Expansive g f


sweetAxiom :: forall f. Case Functor f => SpecWith ()
sweetAxiom = describe "Minimal" $ do

  it "expand (unite x y) = uniteDichotomy x y" . property  $ \(x :: f Int) (y :: f Int) ->
    expand (unite x y) == uniteDichotomy x y

  it "unite = emapThese id" . property $ \(x :: f Int) (y :: f Int) ->
    unite x y == emapThese id x y


sweetFunctor :: forall f. Case Functor f => SpecWith ()
sweetFunctor = describe "Functor" $ do

  it "map Just = expand" . property $ \(x :: f Int) -> fmap Just x == expand x

  it "(\\x -> unite x x) = fmap (\\x -> These x x)" . property $ \(x :: f Int) ->
    unite x x == fmap (\y -> These y y) x

  it "emapThese f a b = map f (unite a b)" . property $
    \(f :: Fun (These Int Int) Int)
     (x :: f Int)
     (y :: f Int) ->
    emapThese (applyFun f) x y == fmap (applyFun f) (unite x y)

  limitSize 20 . it "unite (f <$> x) (g <$> y) = bimap f g <$> unite x y" . property $
    \(f' :: Fun Int String)
     (g' :: Fun String Int)
     (x  :: f Int)
     (y  :: f String) -> let f = applyFun f'; g = applyFun g' in
    unite (f <$> x) (g <$> y) == (bimap f g <$> unite x y)

  it "expand (unite x y) = swap <$> unite y x" . property $ \(x :: f Int) (y :: f Int) ->
    expand (unite x y) == (swap <$> unite y x)

  it "emapThese f a b = f <$> unite a b" . property $
    \(f :: Fun (These Int Int) Int)
     (x :: f Int)
     (y :: f Int) ->
    emapThese (applyFun f) x y == fmap (applyFun f) (unite x y)


sweetAlternative :: forall f. Case Alternative f => SpecWith ()
sweetAlternative = describe "Alternative" $ do

  it "unite empty = map That" . property $ \(x :: f Int) ->
    unite (empty :: f Int) x == (That <$> x)

  it "unite x empty = map This x" . property $ \(x :: f Int) ->
    unite x (empty :: f Int) == (This <$> x)


sweetMonoid :: forall f. (Case Functor f, Monoid (f Int)) => SpecWith ()
sweetMonoid = describe "Monoid" $ do

  it "unite mempty = map That" . property $ \(x :: f Int) ->
    unite (mempty :: f Int) x == (That <$> x)

  it "unite x mempty = map This x" . property $ \(x :: f Int) ->
    unite x (mempty :: f Int) == (This <$> x)


spec :: SpecWith ()
spec = describe "Exapansive" $ do

  describe "Maybe" $ do
    sweetAxiom @Maybe
    sweetFunctor @Maybe
    sweetAlternative @Maybe

  describe "[]" $ do
    sweetAxiom @[]
    sweetFunctor @[]
    sweetAlternative @[]

  describe "ZipList" $ do
    sweetAxiom @ZipList
    sweetFunctor @ZipList
    sweetAlternative @ZipList

  describe "Proxy" $ do
    sweetAxiom @Proxy
    sweetFunctor @Proxy
    sweetAlternative @Proxy

#if __GLASGOW_HASKELL__ < 900
  describe "Option" $ do
    sweetAxiom @Option
    sweetFunctor @Option
    sweetAlternative @Option
#endif

  describe "Seq" $ do
    sweetAxiom @Seq
    sweetFunctor @Seq
    sweetAlternative @Seq

  describe "Vector" $ do
    sweetAxiom @Vector
    sweetFunctor @Vector
    sweetAlternative @Vector

  describe "IntMap" $ do
    sweetAxiom @IntMap
    sweetFunctor @IntMap
    sweetMonoid @IntMap

  describe "Map" $ do
    sweetAxiom @(Map Int)
    sweetFunctor @(Map Int)
    sweetMonoid @(Map Int)

    sweetAxiom @(Map String)
    sweetFunctor @(Map String)
    sweetMonoid @(Map String)

  describe "Product [] Maybe" $ do
    sweetAxiom @(Product [] Maybe)
    sweetFunctor @(Product [] Maybe)
    sweetAlternative @(Product [] Maybe)