compactable-0.2.0.0: test/CompactableSpec.hs

{-# LANGUAGE AllowAmbiguousTypes        #-}
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TypeApplications           #-}

module CompactableSpec where


import           Control.Applicative             (Alternative (empty), Const,
                                                  WrappedMonad, ZipList)
import           Control.Arrow                   (ArrowMonad)
import           Control.Functor.Compactable     (Compactable (applyMaybe, bindMaybe, compact, mapMaybe, traverseMaybe))
import           Control.Monad                   ((<=<))
import           Data.Functor.Compose            (Compose)
import qualified Data.Functor.Product            as FP
import           Data.IntMap                     (IntMap)
import           Data.Map                        (Map)
import           Data.Monoid                     (Alt, Sum)
import           Data.Proxy                      (Proxy (..))
import           Data.Semigroup                  (Option (Option), Sum)
import           Data.Sequence                   (Seq)
import           Data.These                      ()
import qualified Data.Vector                     as Vector
import           GHC.Generics                    (Rec1)
import           Text.ParserCombinators.ReadPrec ()

import           Core                            (Case', limitSize)
import           Test.QuickCheck                 (Arbitrary (..),
                                                  Arbitrary1 (..),
                                                  Args (maxSize, maxSuccess),
                                                  Fun, Testable (property),
                                                  applyFun, arbitrary1,
                                                  quickCheckWith, shrink1,
                                                  stdArgs)
import           Test.Syd                        (SpecWith, describe, it,
                                                  modifyMaxSize, parallel)


type Case g f = Case' Compactable g f


sweetFunctor :: forall f. Case Functor f => SpecWith ()
sweetFunctor = describe "functor" $ do
  limitSize 50 . it "mapMaybe (l <=< r) a = mapMaybe l (mapMaybe r a)" . property $ \(a :: f Int) (l :: Fun Int (Maybe Int)) (r :: Fun Int (Maybe Int)) ->
    mapMaybe (applyFun l <=< applyFun r) a == mapMaybe (applyFun l) (mapMaybe (applyFun r) a)
  it "compact . map Just = id" . property $ \(a :: f Int) -> compact (Just <$> a) == a
  it "compact = mapMaybe id" . property $ \(a :: f (Maybe Int)) -> compact a == mapMaybe id a


sweetApplicative :: forall f. Case Applicative f => SpecWith ()
sweetApplicative = describe "applicative" $ do
  it "compact (pure Just <*> a) = a" . property $ \(a :: f Int) -> compact (pure Just <*> a) == a
  it "applyMaybe (pure Just) = id" . property $ \(a :: f Int) -> applyMaybe (pure Just) a == a
  it "compact = applyMaybe (pure id)" . property $ \(a :: f (Maybe Int)) -> compact a == applyMaybe (pure id) a


sweetMonad :: forall f. Case Monad f => SpecWith ()
sweetMonad = describe "monad" $ do
  it "bindMaybe (return . Just) = id" . property $ \(a :: f Int) -> bindMaybe (return . Just) a == a
  it "compact (return . Just =<< a) = a" . property $ \(a :: f Int) -> compact (return . Just =<< a) == a
  it "bindMaybe return = compact" . property $ \(a :: f (Maybe Int)) -> bindMaybe return a == compact a


sweetAlternative :: forall f. Case Alternative f => SpecWith ()
sweetAlternative = describe "alternative" $ do
  it "compact empty = empty" $ compact (empty :: f (Maybe Int)) == empty
  it "compact (Nothing <$ a) = empty" . property $ \(a :: f Int) -> compact (Nothing <$ a) == (empty :: f Int)


sweetMonoid :: forall f.
  ( Eq (f (Sum Int))
  , Arbitrary (f (Sum Int))
  , Show (f (Sum Int))
  , Compactable f
  , Functor f
  , Monoid (f (Sum Int))
  , Monoid (f (Maybe (Sum Int)))) => SpecWith ()
sweetMonoid = describe "monoid" $ do
  it "compact mempty = mempty" $ compact (mempty :: f (Maybe (Sum Int))) == mempty
  it "compact (Nothing <$ a) = mempty" . property $ \(a :: f (Sum Int)) -> compact (Nothing <$ a) == (mempty :: f (Sum Int))


pure' :: a -> [a]
pure' = pure


sweetTraversable :: forall f. (Case Traversable f) => SpecWith ()
sweetTraversable = describe  "traverse" $ do
  limitSize 50 . it "traverseMaybe (Just . Just) = Just" . property $ \(a :: f Int) -> traverseMaybe (Just . Just) a == Just a
  limitSize 4 . it "traverse f = traverseMaybe (map Just . f)" . property $ \(a :: f Int) (f' :: Fun Int [Int]) -> let f = applyFun f' in
    traverse f a == traverseMaybe (fmap Just . f) a


valuePack :: forall f.
  ( Case Functor f
  , Case Applicative f
  , Case Monad f
  , Case Alternative f
  , Case Traversable f
  ) => SpecWith ()
valuePack = describe "pack" . parallel $ do
  sweetFunctor @f
  sweetApplicative @f
  sweetMonad @f
  sweetAlternative @f
  sweetTraversable @f


spec :: SpecWith ()
spec = describe "Compactable" $ do
  describe "Maybe" $ do
    valuePack @Maybe
    sweetMonoid @Maybe

  describe "[]" $ do
     valuePack @[]
     sweetMonoid @[]

#if __GLASGOW_HASKELL__ < 900
  describe "Option" $ do
    valuePack @Option
    sweetMonoid @Option
#endif

  describe "ZipList" $ do
    sweetFunctor @ZipList
    sweetApplicative @ZipList
    sweetAlternative @ZipList
    sweetTraversable @ZipList

  describe "IntMap" $ do
    sweetFunctor @IntMap
-- THIS IS NOT LAWFUL, Due to a bug in IntMap
-- λ. traverse Just $ fromList [(-1,0),(0,0)]
-- Just (fromList [(0,0),(-1,0)])
-- λ. fromList [(0,0),(-1,0)]
-- fromList [(-1,0),(0,0)]
-- sweetTraversable @IntMap
    sweetMonoid @IntMap

  describe "Seq" $ do
    valuePack @Seq
    sweetMonoid @Seq

  describe "Vector" $ do
    valuePack @Vector.Vector
    sweetMonoid @Vector.Vector

  describe "Map" $ do
    sweetFunctor @(Map String)
    sweetTraversable @(Map Int)
    sweetMonoid @(Map String)

    sweetFunctor @(Map Int)
    sweetTraversable @(Map Int)
    sweetMonoid @(Map Int)

  describe "Proxy" $ do
    valuePack @Proxy
    sweetMonoid @Proxy

  describe "Const" $ do
    sweetFunctor @(Const ())
    sweetApplicative @(Const ())
    sweetMonoid @(Const ())

  describe "Alt" $ do
    valuePack @(Alt [])
    sweetMonoid @(Alt [])

  describe "WrappedMonad" $
    valuePack @(WrappedMonad [])

  describe "Rec1" $
    valuePack @(Rec1 [])

  describe "Product" $
    valuePack @(FP.Product [] Maybe)

  describe "Compose" $
    sweetFunctor @(Compose [] Maybe)