barbies 2.0.5.0 → 2.1.1.0
raw patch · 25 files changed
Files
- ChangeLog.md +19/−0
- barbies.cabal +1/−55
- src/Barbies/Bi.hs +14/−0
- src/Barbies/Internal/ConstraintsB.hs +16/−0
- src/Barbies/Internal/ConstraintsT.hs +13/−0
- src/Barbies/Internal/TraversableB.hs +25/−0
- src/Barbies/Internal/TraversableT.hs +25/−0
- src/Data/Barbie.hs +0/−105
- src/Data/Barbie/Bare.hs +0/−14
- src/Data/Barbie/Constraints.hs +0/−22
- src/Data/Barbie/Internal/Product.hs +0/−166
- src/Data/Barbie/Internal/ProductC.hs +0/−133
- src/Data/Functor/Barbie.hs +3/−0
- src/Data/Functor/Prod.hs +0/−246
- src/Data/Functor/Transformer.hs +3/−0
- test-legacy/Legacy/Clothes.hs +0/−189
- test-legacy/Legacy/Spec.hs +0/−204
- test-legacy/Legacy/Spec/Bare.hs +0/−30
- test-legacy/Legacy/Spec/Constraints.hs +0/−49
- test-legacy/Legacy/Spec/Functor.hs +0/−32
- test-legacy/Legacy/Spec/Product.hs +0/−45
- test-legacy/Legacy/Spec/Traversable.hs +0/−44
- test-legacy/Legacy/Spec/Wrapper.hs +0/−37
- test-legacy/Legacy/TestBarbies.hs +0/−306
- test-legacy/Legacy/TestBarbiesW.hs +0/−324
ChangeLog.md view
@@ -1,5 +1,24 @@ # Changelog for barbies +## 2.1.1.0+ - Correctly export the following functions, which were not+ accessible in 2.1.0.0:+ - `Data.Barbie.bfor`+ - `Data.Barbie.bfor_`+ - `Data.Barbie.bforC`++## 2.1.0.0+ - Remove the deprecated interface from 1.x version+ - Add flipped-argument versions of `traverse` functions (Jack Kelly).+ By analogy to `Data.Traversable.for` in `base` these are similarly-named:+ - ~~`Data.Barbie.bfor`~~+ - ~~`Data.Barbie.bfor_`~~+ - ~~`Data.Barbie.bforC`~~+ - `Data.Functor.Transformer.tfor`+ - `Data.Functor.Transformer.tforC`+ - `Data.Functor.Transformer.tfor_`+ - `Barbies.Bi.btfor1`+ ## 2.0.5.0 - Add helper class Barbies.Constraints.(&) (#46)
barbies.cabal view
@@ -1,5 +1,5 @@ name: barbies-version: 2.0.5.0+version: 2.1.1.0 synopsis: Classes for working with types that can change clothes. description: Types that are parametric on a functor are like Barbies that have an outfit for each role. This package provides the basic abstractions to work with them comfortably. category: Data Structures@@ -33,12 +33,6 @@ Data.Functor.Barbie Data.Functor.Transformer - -- Deprecated modules- Data.Barbie- Data.Barbie.Bare- Data.Barbie.Constraints- Data.Functor.Prod- other-modules: Barbies.Generics.Applicative Barbies.Generics.Bare@@ -74,10 +68,6 @@ Data.Generics.GenericN - -- To be removed- Data.Barbie.Internal.Product- Data.Barbie.Internal.ProductC- hs-source-dirs: src @@ -139,50 +129,6 @@ barbies , base >=4.7 && <5 , distributive- , QuickCheck- , tasty- , tasty-hunit- , tasty-quickcheck-- default-language: Haskell2010- default-extensions:- DeriveDataTypeable- DeriveGeneric- KindSignatures- LambdaCase- Rank2Types- ScopedTypeVariables- StandaloneDeriving- TypeApplications- TypeOperators---- This tests that the deprecated Data.Barbie interface--- can still be used to build code writen against 1.x,--- with deprecation warnings-test-suite barbies-test-legacy- type: exitcode-stdio-1.0-- main-is: Legacy/Spec.hs-- other-modules:- Legacy.TestBarbies- Legacy.TestBarbiesW- Legacy.Clothes- Legacy.Spec.Bare- Legacy.Spec.Constraints- Legacy.Spec.Functor- Legacy.Spec.Traversable- Legacy.Spec.Product- Legacy.Spec.Wrapper-- hs-source-dirs:- test-legacy-- ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wno-deprecations -O0-- build-depends:- barbies- , base >=4.7 && <5 , QuickCheck , tasty , tasty-hunit
src/Barbies/Bi.hs view
@@ -20,6 +20,7 @@ -- and a 'TraversableB'. , bttraverse , bttraverse1+ , btfor1 , bttraverse_ , btfoldMap @@ -108,6 +109,19 @@ bttraverse1 h = bttraverse h h {-# INLINE bttraverse1 #-}++-- | 'bttraverse1' with the arguments flipped.+--+-- @since 2.1.0.0+btfor1+ :: ( TraversableB (b f)+ , TraversableT b+ , Monad t+ )+ => b f f+ -> (forall a . f a -> t (g a))+ -> t (b g g)+btfor1 b f = bttraverse1 f b -- | Map each element to an action, evaluate these actions from left to right -- and ignore the results.
src/Barbies/Internal/ConstraintsB.hs view
@@ -8,6 +8,7 @@ ( ConstraintsB(..) , bmapC , btraverseC+ , bforC , AllBF , bdicts , bpureC@@ -147,6 +148,21 @@ -> e (b g) btraverseC f b = btraverse (\(Pair (Dict :: Dict c a) x) -> f x) (baddDicts b)++-- | 'btraverseC' with the arguments flipped. Useful when the traversing function is a large lambda:+--+-- @+-- bforC someBarbie $ \fa -> ...+-- @+--+-- @since 2.1.1.0+bforC+ :: forall c b f g e+ . (TraversableB b, ConstraintsB b, AllB c b, Applicative e)+ => b f+ -> (forall a. c a => f a -> e (g a))+ -> e (b g)+bforC b f = btraverseC @c f b bfoldMapC :: forall c b m f
src/Barbies/Internal/ConstraintsT.hs view
@@ -7,6 +7,7 @@ ( ConstraintsT(..) , tmapC , ttraverseC+ , tforC , AllTF , tdicts , tpureC@@ -121,6 +122,18 @@ -> e (t g x) ttraverseC f t = ttraverse (\(Pair (Dict :: Dict c a) x) -> f x) (taddDicts t)++-- | Like 'ttraverseC' but with the arguments flipped.+--+-- @since 2.1.0.0+tforC+ :: forall c t f g e x+ . (TraversableT t, ConstraintsT t, AllT c t, Applicative e)+ => t f x+ -> (forall a. c a => f a -> e (g a))+ -> e (t g x)+tforC t f+ = ttraverseC @c f t -- | Like 'Data.Functor.Transformer.tfoldMap' but with a constraint on the function. tfoldMapC
src/Barbies/Internal/TraversableB.hs view
@@ -3,7 +3,9 @@ {-# OPTIONS_GHC -Wno-orphans #-} module Barbies.Internal.TraversableB ( TraversableB(..)+ , bfor , btraverse_+ , bfor_ , bsequence , bsequence' , bfoldMap@@ -50,6 +52,19 @@ -> e (b g) btraverse = gbtraverseDefault +-- | 'btraverse' with the arguments flipped. Useful when the traversing function is a large lambda:+--+-- @+-- bfor someBarbie $ \fa -> ...+-- @+--+-- @since 2.1.1.0+bfor+ :: (TraversableB b, Applicative e)+ => b f+ -> (forall a . f a -> e (g a))+ -> e (b g)+bfor b f = btraverse f b -- | Map each element to an action, evaluate these actions from left to right,@@ -61,6 +76,16 @@ -> e () btraverse_ f = void . btraverse (fmap (const $ Const ()) . f)++-- | 'btraverse_' with the arguments flipped.+--+-- @since 2.1.1.0+bfor_+ :: (TraversableB b, Applicative e)+ => b f+ -> (forall a. f a -> e c)+ -> e ()+bfor_ b f = btraverse_ f b -- | Evaluate each action in the structure from left to right,
src/Barbies/Internal/TraversableT.hs view
@@ -4,7 +4,9 @@ {-# OPTIONS_GHC -Wno-orphans #-} module Barbies.Internal.TraversableT ( TraversableT(..)+ , tfor , ttraverse_+ , tfor_ , tsequence , tsequence' , tfoldMap@@ -60,6 +62,19 @@ => (forall a . f a -> e (g a)) -> t f x -> e (t g x) ttraverse = ttraverseDefault +-- | 'ttraverse' with the arguments flipped. Useful when the traversing function is a large lambda:+--+-- @+-- tfor someTransformer $ \fa -> ...+-- @+--+-- @since 2.1.0.0+tfor+ :: (TraversableT t, Applicative e)+ => t f x+ -> (forall a . f a -> e (g a))+ -> e (t g x)+tfor t f = ttraverse f t -- | Map each element to an action, evaluate these actions from left to right,@@ -70,6 +85,16 @@ -> t f x -> e () ttraverse_ f = void . ttraverse (fmap (const $ Const ()) . f)++-- | 'ttraverse_' with the arguments flipped.+--+-- @since 2.1.0.0+tfor_+ :: (TraversableT t, Applicative e)+ => t f x+ -> (forall a . f a -> e c)+ -> e ()+tfor_ t f = ttraverse_ f t -- | Evaluate each action in the structure from left to right,
− src/Data/Barbie.hs
@@ -1,105 +0,0 @@-{-# OPTIONS_GHC -Wno-deprecations #-}-module Data.Barbie- {-# DEPRECATED "Use Data.Functor.Barbie or Barbies instead" #-}- (- -- * Functor- FunctorB(bmap)-- -- * Traversable- , TraversableB(btraverse)- -- ** Utility functions- , btraverse_- , bfoldMap- , bsequence, bsequence'-- -- * Product- , ProductB(buniq, bprod)- , CanDeriveProductB-- -- ** Utility functions- , App.bzip- , App.bunzip- , App.bzipWith- , App.bzipWith3- , App.bzipWith4-- -- * Constraints and instance dictionaries- , ConstraintsB(AllB, baddDicts)- , AllBF- -- ** Utility functions- , bmapC- , btraverseC-- -- * Products and constaints- , ProductBC(bdicts)- , CanDeriveProductBC- -- ** Utility functions- , buniqC- , bmempty-- -- * Wrapper- , Barbie(..)-- -- * Trivial Barbies- , Trivial.Void- , Trivial.Unit (..)-- -- * Generic derivations- , Rec(..)- , GProductB(..)- , GProductBC(..)-- -- * Deprecations- , (/*/), (/*)- )--where--import Barbies.Internal.ConstraintsB (AllBF, ConstraintsB (..), bmapC, btraverseC, bmempty)--import Barbies.Internal.FunctorB(FunctorB(..))-import Barbies.Internal.Wrappers(Barbie(..))-import qualified Barbies.Internal.ApplicativeB as App--import Data.Barbie.Internal.Product(ProductB(..), CanDeriveProductB, GProductB(..))-import Data.Barbie.Internal.ProductC(ProductBC(..), CanDeriveProductBC, GProductBC(..), buniqC)--import Barbies.Internal.TraversableB- ( TraversableB(..)- , bsequence, bsequence'- , bfoldMap, btraverse_- )-import qualified Barbies.Internal.Trivial as Trivial--import Data.Functor.Product (Product(Pair))-import Data.Functor.Prod (Prod(..), oneTuple, prod)-import Data.Generics.GenericN (Rec(..))---{-# DEPRECATED (/*/), (/*) "Use bzipWith2, bzipWith3, etc" #-}---- | Like 'bprod', but returns a binary 'Prod', instead of 'Product', which--- composes better.------ See '/*/' for usage.-(/*/)- :: ProductB b => b f -> b g -> b (Prod '[f, g])-l /*/ r- = bmap (\(Pair f g) -> Cons f (Cons g Unit)) (l `bprod` r)-infixr 4 /*/---- | Similar to '/*/' but one of the sides is already a @'Prod' fs@.------ Note that '/*', '/*/' and 'Data.Functor.Prod.uncurryn' are meant to be used together:--- '/*' and '/*/' combine @b f1, b f2...b fn@ into a single product that--- can then be consumed by using `Data.Functor.Prod.uncurryn` on an n-ary function. E.g.------ @--- f :: f a -> g a -> h a -> i a------ 'bmap' ('Data.Functor.Prod.uncurryn' f) (bf '/*' bg '/*/' bh)--- @-(/*) :: ProductB b => b f -> b (Prod fs) -> b (Prod (f ': fs))-l /* r =- bmap (\(Pair f fs) -> oneTuple f `prod` fs) (l `bprod` r)-infixr 4 /*
− src/Data/Barbie/Bare.hs
@@ -1,14 +0,0 @@-module Data.Barbie.Bare- {-# DEPRECATED "Use Barbies.Bare" #-}- ( -- * Bare values- Barbies.Bare.Wear- , Barbies.Bare.Bare- , Barbies.Bare.Covered-- -- * Covering and stripping- , Barbies.Bare.BareB(bstrip, bcover)- , Barbies.Bare.bstripFrom- , Barbies.Bare.bcoverWith- ) where--import qualified Barbies.Bare
− src/Data/Barbie/Constraints.hs
@@ -1,22 +0,0 @@-module Data.Barbie.Constraints- {-# DEPRECATED "Use Data.Functor.Barbie or Barbie.Constraints" #-}- ( -- * Instance dictionaries- Dict(..)- , requiringDict-- -- * Retrieving dictionaries- , ConstraintsB(..)- , ProductBC(..)- , bmapC- , btraverseC-- , AllBF- , ClassF- , ClassFG- )--where--import Barbies.Internal.ConstraintsB-import Barbies.Internal.Dicts-import Data.Barbie.Internal.ProductC
− src/Data/Barbie/Internal/Product.hs
@@ -1,166 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -Wno-orphans -Wno-deprecations #-}-module Data.Barbie.Internal.Product- ( ProductB(buniq, bprod)- , CanDeriveProductB- , gbprodDefault, gbuniqDefault- , GProductB(..)- )--where--import Barbies.Internal.FunctorB (FunctorB)-import Barbies.Internal.Trivial (Unit)-import Barbies.Internal.Wrappers (Barbie(..))-import qualified Barbies.Internal.ApplicativeB as App--import Data.Functor.Product (Product (..))-import Data.Kind (Type)-import Data.Proxy (Proxy (..))--import Data.Generics.GenericN---{-# DEPRECATED ProductB "Use ApplicativeB" #-}-{-# DEPRECATED buniq "Use bpure" #-}-class App.ApplicativeB b => ProductB (b :: (k -> Type) -> Type) where- bprod :: b f -> b g -> b (f `Product` g)-- buniq :: (forall a . f a) -> b f-- default bprod :: CanDeriveProductB b f g => b f -> b g -> b (f `Product` g)- bprod = gbprodDefault-- default buniq :: CanDeriveProductB b f f => (forall a . f a) -> b f- buniq = gbuniqDefault----type CanDeriveProductB b f g- = ( GenericN (b f)- , GenericN (b g)- , GenericN (b (f `Product` g))- , GProductB f g (RepN (b f)) (RepN (b g)) (RepN (b (f `Product` g)))- )--instance {-# OVERLAPPABLE #-} (ProductB b, FunctorB b) => App.ApplicativeB b where- bpure = Data.Barbie.Internal.Product.buniq- bprod = Data.Barbie.Internal.Product.bprod--instance ProductB Unit where--instance ProductB b => ProductB (Barbie b) where- buniq x = Barbie (buniq x)- bprod (Barbie l) (Barbie r) = Barbie (bprod l r)---- ======================================--- Generic derivation of instances--- ======================================---- | Default implementation of 'bprod' based on 'Generic'.-gbprodDefault- :: forall b f g- . CanDeriveProductB b f g- => b f -> b g -> b (f `Product` g)-gbprodDefault l r- = toN $ gbprod (Proxy @f) (Proxy @g) (fromN l) (fromN r)-{-# INLINE gbprodDefault #-}--gbuniqDefault:: forall b f . CanDeriveProductB b f f => (forall a . f a) -> b f-gbuniqDefault x- = toN $ gbuniq (Proxy @f) (Proxy @(RepN (b f))) (Proxy @(RepN (b (f `Product` f)))) x-{-# INLINE gbuniqDefault #-}--class GProductB (f :: k -> Type) (g :: k -> Type) repbf repbg repbfg where- gbprod :: Proxy f -> Proxy g -> repbf x -> repbg x -> repbfg x-- gbuniq :: (f ~ g, repbf ~ repbg) => Proxy f -> Proxy repbf -> Proxy repbfg -> (forall a . f a) -> repbf x---- ------------------------------------- Trivial cases--- ------------------------------------instance GProductB f g repf repg repfg => GProductB f g (M1 i c repf)- (M1 i c repg)- (M1 i c repfg) where- gbprod pf pg (M1 l) (M1 r) = M1 (gbprod pf pg l r)- {-# INLINE gbprod #-}-- gbuniq pf _ _ x = M1 (gbuniq pf (Proxy @repf) (Proxy @repfg) x)- {-# INLINE gbuniq #-}---instance GProductB f g U1 U1 U1 where- gbprod _ _ U1 U1 = U1- {-# INLINE gbprod #-}-- gbuniq _ _ _ _ = U1- {-# INLINE gbuniq #-}--instance- ( GProductB f g lf lg lfg- , GProductB f g rf rg rfg- ) => GProductB f g (lf :*: rf)- (lg :*: rg)- (lfg :*: rfg) where- gbprod pf pg (l1 :*: l2) (r1 :*: r2)- = (l1 `lprod` r1) :*: (l2 `rprod` r2)- where- lprod = gbprod pf pg- rprod = gbprod pf pg- {-# INLINE gbprod #-}-- gbuniq pf _ _ x = (gbuniq pf (Proxy @lf) (Proxy @lfg) x :*: gbuniq pf (Proxy @rf) (Proxy @rfg) x)- {-# INLINE gbuniq #-}---- ----------------------------------- The interesting cases--- ----------------------------------type P0 = Param 0--instance GProductB f g (Rec (P0 f a_or_pma) (f a))- (Rec (P0 g a_or_pma) (g a))- (Rec (P0 (f `Product` g) a_or_pma) ((f `Product` g) a)) where- gbprod _ _ (Rec (K1 fa)) (Rec (K1 ga))- = Rec (K1 (Pair fa ga))- {-# INLINE gbprod #-}-- gbuniq _ _ _ x = Rec (K1 x)- {-# INLINE gbuniq #-}----- b' is b, maybe with 'Param' annotations-instance- ( ProductB b- ) => GProductB f g (Rec (b' (P0 f)) (b f))- (Rec (b' (P0 g)) (b g))- (Rec (b' (P0 (f `Product` g))) (b (f `Product` g))) where- gbprod _ _ (Rec (K1 bf)) (Rec (K1 bg))- = Rec (K1 (bf `bprod` bg))- {-# INLINE gbprod #-}-- gbuniq _ _ _ x = Rec (K1 (buniq x))- {-# INLINE gbuniq #-}----- ----------------------------------- Instances for base types--- ----------------------------------instance ProductB Proxy where- bprod _ _ = Proxy- {-# INLINE bprod #-}-- buniq _ = Proxy- {-# INLINE buniq #-}--instance (ProductB a, ProductB b) => ProductB (Product a b) where- bprod (Pair ll lr) (Pair rl rr) = Pair (bprod ll rl) (bprod lr rr)- {-# INLINE bprod #-}-- buniq x = Pair (buniq x) (buniq x)- {-# INLINE buniq #-}
− src/Data/Barbie/Internal/ProductC.hs
@@ -1,133 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -Wno-deprecations #-}-module Data.Barbie.Internal.ProductC- ( ProductBC(..)- , buniqC-- , CanDeriveProductBC- , GAll- , GProductBC(..)- , gbdictsDefault- )--where--import Barbies.Generics.Constraints(GAll, Self, Other, X)-import Barbies.Internal.ConstraintsB(ConstraintsB(..), GAllRepB)-import Barbies.Internal.Dicts(Dict (..), requiringDict)-import Barbies.Internal.FunctorB(FunctorB(bmap))-import Barbies.Internal.Trivial(Unit(..))-import Barbies.Internal.Wrappers(Barbie(..))--import Data.Barbie.Internal.Product(ProductB(..))-import Data.Generics.GenericN--import Data.Functor.Product (Product (..))-import Data.Kind(Type)-import Data.Proxy(Proxy (..))--class (ConstraintsB b, ProductB b) => ProductBC (b :: (k -> Type) -> Type) where- bdicts :: AllB c b => b (Dict c)-- default bdicts :: (CanDeriveProductBC c b, AllB c b) => b (Dict c)- bdicts = gbdictsDefault---type CanDeriveProductBC c b- = ( GenericN (b (Dict c))- , AllB c b ~ GAll 0 c (GAllRepB b)- , GProductBC c (GAllRepB b) (RepN (b (Dict c)))- )--{-# DEPRECATED buniqC "Use bpureC instead" #-}-buniqC :: forall c f b . (AllB c b, ProductBC b) => (forall a . c a => f a) -> b f-buniqC x- = bmap (requiringDict @c x) bdicts--instance ProductBC b => ProductBC (Barbie b) where- bdicts = Barbie bdicts--instance ProductBC Unit where- bdicts = Unit----- ===============================================================--- Generic derivations--- ===============================================================---- | Default implementation of 'bdicts' based on 'Generic'.-gbdictsDefault- :: forall b c- . ( CanDeriveProductBC c b- , AllB c b- )- => b (Dict c)-gbdictsDefault- = toN $ gbdicts @c @(GAllRepB b)-{-# INLINE gbdictsDefault #-}---class GProductBC c repbx repbd where- gbdicts :: GAll 0 c repbx => repbd x---- ------------------------------------- Trivial cases--- ------------------------------------instance GProductBC c repbx repbd => GProductBC c (M1 i k repbx) (M1 i k repbd) where- gbdicts = M1 (gbdicts @c @repbx)- {-# INLINE gbdicts #-}--instance GProductBC c U1 U1 where- gbdicts = U1- {-# INLINE gbdicts #-}--instance- ( GProductBC c lx ld- , GProductBC c rx rd- ) => GProductBC c (lx :*: rx)- (ld :*: rd) where- gbdicts = gbdicts @c @lx @ld :*: gbdicts @c @rx @rd- {-# INLINE gbdicts #-}----- ----------------------------------- The interesting cases--- ----------------------------------type P0 = Param 0--instance c a => GProductBC c (Rec (P0 X a_or_pma) (X a))- (Rec (P0 (Dict c) a_or_pma) (Dict c a)) where- gbdicts = Rec (K1 Dict)- {-# INLINE gbdicts #-}--instance- ( ProductBC b- , AllB c b- ) => GProductBC c (Self (b' (P0 X)) (b X))- (Rec (b' (P0 (Dict c))) (b (Dict c))) where- gbdicts = Rec $ K1 $ bdicts @_ @b--instance- ( ProductBC b- , AllB c b- ) => GProductBC c (Other (b' (P0 X)) (b X))- (Rec (b' (P0 (Dict c))) (b (Dict c))) where- gbdicts = Rec $ K1 $ bdicts @_ @b----- ----------------------------------- Instances for base types--- ----------------------------------instance ProductBC Proxy where- bdicts = Proxy- {-# INLINE bdicts #-}--instance (ProductBC a, ProductBC b) => ProductBC (Product a b) where- bdicts = Pair bdicts bdicts- {-# INLINE bdicts #-}
src/Data/Functor/Barbie.hs view
@@ -11,7 +11,9 @@ -- * Traversable , Trav.TraversableB(btraverse) -- ** Utility functions+ , Trav.bfor , Trav.btraverse_+ , Trav.bfor_ , Trav.bfoldMap , Trav.bsequence , Trav.bsequence'@@ -59,6 +61,7 @@ , Cons.bmapC , Cons.bfoldMapC , Cons.btraverseC+ , Cons.bforC , Cons.bpureC , Cons.bzipWithC , Cons.bzipWith3C
− src/Data/Functor/Prod.hs
@@ -1,246 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Functor.Prod------ Generalize the standard two-functor 'Product' to the product of--- @n@-functors. Intuitively, this means:------ @--- 'Product' f g a ~~ (f a, g a)------ 'Prod' '[] a ~~ Const () a--- 'Prod' '[f] a ~~ (f a)--- 'Prod' '[f, g] a ~~ (f a, g a)--- 'Prod' '[f, g, h] a ~~ (f a, g a, h a)--- ⋮--- @------------------------------------------------------------------------------{-# LANGUAGE GADTs #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeFamilies #-}-module Data.Functor.Prod- {-# DEPRECATED "The module is no longer part of the main api and will be removed " #-}- ( -- * n-tuples of functors.- Prod(Unit, Cons)- , zeroTuple- , oneTuple- , fromProduct- , toProduct-- -- * Flat product of functor products- , prod-- -- * Lifting functions- , uncurryn-- -- * Type-level helpers- , type (++)- , Curried- )--where--import Control.Applicative(Alternative(..))-import Data.Functor.Product(Product(..))-import Data.Functor.Classes(Eq1(..), Ord1(..), Show1(..))-import Data.Kind (Type)--import qualified Data.Functor.Classes as FC---- | Product of n functors.-data Prod :: [k -> Type] -> k -> Type where- Unit :: Prod '[] a- Cons :: (f a) -> Prod fs a -> Prod (f ': fs) a---- | The unit of the product.-zeroTuple :: Prod '[] a-zeroTuple- = Unit---- | Lift a functor to a 1-tuple.-oneTuple :: f a -> Prod '[f] a-oneTuple fa- = Cons fa Unit---- | Conversion from a standard 'Product'-fromProduct :: Product f g a -> Prod '[f, g] a-fromProduct (Pair fa ga)- = Cons fa $ Cons ga Unit---- | Conversion to a standard 'Product'-toProduct :: Prod '[f, g] a -> Product f g a-toProduct (Cons fa (Cons ga Unit))- = Pair fa ga----- | Flat product of products.-prod :: Prod ls a -> Prod rs a -> Prod (ls ++ rs) a-l `prod` r =- case l of- Unit -> r- Cons la l' -> Cons la (l' `prod` r)---- | Type-level, poly-kinded, list-concatenation.-type family (++) l r :: [k] where- '[] ++ ys = ys- (x ': xs) ++ ys = x ': (xs ++ ys)---- ----------------------------------------------------------------- Uncurrying of functions--- ------------------------------------------------------------------ | @'Prod' '[f, g, h] a -> r@ is the type of the uncurried form--- of a function @f a -> g a -> h a -> r@. 'Curried' moves from--- the former to the later. E.g.------ @--- 'Curried' ('Prod' '[] a -> r) = r a--- 'Curried' ('Prod' '[f] a -> r) = f a -> r a--- 'Curried' ('Prod' '[f, g] a -> r) = f a -> g a -> r a--- @-type family Curried t where- Curried (Prod '[] a -> r a) = r a- Curried (Prod (f ': fs) a -> r a) = f a -> Curried (Prod fs a -> r a)---- | Like 'uncurry' but using 'Prod' instead of pairs. Can--- be thought of as a family of functions:------ @--- 'uncurryn' :: r a -> 'Prod' '[] a--- 'uncurryn' :: (f a -> r a) -> 'Prod' '[f] a--- 'uncurryn' :: (f a -> g a -> r a) -> 'Prod' '[f, g] a--- 'uncurryn' :: (f a -> g a -> h a -> r a) -> 'Prod' '[f, g, h] a--- ⋮--- @-uncurryn :: Curried (Prod fs a -> r a) -> Prod fs a -> r a-uncurryn fun = \case- Unit -> fun- Cons fa fs' ->- let fun' = fun fa- in uncurryn fun' fs'---- ----------------------------------------------------------------- Instances--- ------------------------------------------------------------------ | Inductively defined instance: @'Functor' ('Prod' '[])@.-instance Functor (Prod '[]) where- fmap _ Unit = Unit---- | Inductively defined instance: @'Functor' ('Prod' (f ': fs))@.-instance (Functor f, Functor (Prod fs)) => Functor (Prod (f ': fs)) where- fmap f (Cons fa fas)- = Cons (fmap f fa) (fmap f fas)---- | Inductively defined instance: @'Applicative' ('Prod' '[])@.-instance Applicative (Prod '[]) where- pure _- = Unit-- Unit <*> Unit- = Unit---- | Inductively defined instance: @'Applicative' ('Prod' (f ': fs))@.-instance (Applicative f, Applicative (Prod fs)) => Applicative (Prod (f ': fs)) where- pure a- = Cons (pure a) (pure a)-- Cons f fs <*> Cons a as- = Cons (f <*> a) (fs <*> as)---- | Inductively defined instance: @'Alternative' ('Prod' '[])@.-instance Alternative (Prod '[]) where- empty- = Unit-- Unit <|> Unit- = Unit---- | Inductively defined instance: @'Alternative' ('Prod' (f ': fs))@.-instance (Alternative f, Alternative (Prod fs)) => Alternative (Prod (f ': fs)) where- empty- = Cons empty empty-- Cons f fs <|> Cons g gs- = Cons (f <|> g) (fs <|> gs)----- NB. There are Monad instances for `Data.Functor.Product`, but I'm not convinced they--- make much sense. In particular, we seem to get a O(n^2) bind.---- | Inductively defined instance: @'Foldable' ('Prod' '[])@.-instance Foldable (Prod '[]) where- foldMap _ = mempty---- | Inductively defined instance: @'Foldable' ('Prod' (f ': fs))@.-instance (Foldable f, Foldable (Prod fs)) => Foldable (Prod (f ': fs)) where- foldMap f (Cons fa fas)- = foldMap f fa `mappend` foldMap f fas---- | Inductively defined instance: @'Traversable' ('Prod' '[])@.-instance Traversable (Prod '[]) where- traverse _ Unit = pure Unit---- | Inductively defined instance: @'Traversable' ('Prod' (f ': fs))@.-instance (Traversable f, Traversable (Prod fs)) => Traversable (Prod (f ': fs)) where- traverse f (Cons fa fas)- = Cons <$> (traverse f fa) <*> (traverse f fas)---- | Inductively defined instance: @'Eq1' ('Prod' '[])@.-instance Eq1 (Prod '[]) where- liftEq _ Unit Unit = True---- | Inductively defined instance: @'Eq1' ('Prod' (f ': fs))@.-instance (Eq1 f, Eq1 (Prod fs)) => Eq1 (Prod (f ': fs)) where- liftEq eq (Cons l ls) (Cons r rs)- = liftEq eq l r && liftEq eq ls rs---- | Inductively defined instance: @'Eq' ('Prod' '[])@.-instance Eq a => Eq (Prod '[] a) where- (==) = FC.eq1---- | Inductively defined instance: @'Eq' ('Prod' (f ': fs))@.-instance (Eq1 f, Eq a, Eq1 (Prod fs)) => Eq (Prod (f ': fs) a) where- (==) = FC.eq1---- | Inductively defined instance: @'Ord1' ('Prod' '[])@.-instance Ord1 (Prod '[]) where- liftCompare _ Unit Unit = EQ---- | Inductively defined instance: @'Ord1' ('Prod' (f ': fs))@.-instance (Ord1 f, Ord1 (Prod fs)) => Ord1 (Prod (f ': fs)) where- liftCompare cmp (Cons l ls) (Cons r rs)- = liftCompare cmp l r `mappend` liftCompare cmp ls rs---- | Inductively defined instance: @'Ord' ('Prod' '[])@.-instance Ord a => Ord (Prod '[] a) where- compare = FC.compare1---- | Inductively defined instance: @'Ord' ('Prod' (f ': fs))@.-instance (Ord1 f, Ord a, Ord1 (Prod fs)) => Ord (Prod (f ': fs) a) where- compare = FC.compare1---- | Inductively defined instance: @'Show1' ('Prod' '[])@.-instance Show1 (Prod '[]) where- liftShowsPrec _ _ _ Unit = showString "zeroTuple"---- | Inductively defined instance: @'Show1' ('Prod' (f ': fs))@.-instance (Show1 f, Show1 (Prod fs)) => Show1 (Prod (f ': fs)) where- liftShowsPrec sp sl d = \case- (Cons fa Unit) ->- showParen (d > 10) $- showString "oneTuple " . liftShowsPrec sp sl 11 fa- (Cons fa fas) ->- showParen (d > 10) $- showString "oneTuple " . liftShowsPrec sp sl 11 fa- . showString " `prod` "- . liftShowsPrec sp sl 0 fas---- | Inductively defined instance: @'Show' ('Prod' '[])@.-instance Show a => Show (Prod '[] a) where- showsPrec = FC.showsPrec1---- | Inductively defined instance: @'Show' ('Prod' (f ': fs))@.-instance (Show1 f, Show a, Show1 (Prod fs)) => Show (Prod (f ': fs) a) where- showsPrec = FC.showsPrec1-
src/Data/Functor/Transformer.hs view
@@ -12,7 +12,9 @@ -- * Traversable , Trav.TraversableT(ttraverse) -- ** Utility functions+ , Trav.tfor , Trav.ttraverse_+ , Trav.tfor_ , Trav.tfoldMap , Trav.tsequence , Trav.tsequence'@@ -43,6 +45,7 @@ -- ** Utility functions , Cons.tmapC , Cons.ttraverseC+ , Cons.tforC -- * Support for generic derivations , GenericsN.Rec(..)
− test-legacy/Legacy/Clothes.hs
@@ -1,189 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-module Legacy.Clothes--where--import Prelude hiding ((.), id)--import Control.Category-import Data.Functor.Identity-import qualified Data.List.NonEmpty as NE-import Data.Typeable--import Test.Tasty.QuickCheck--data UnitF a = UnitF deriving(Eq, Show, Typeable)--data F a = F [a]- deriving(Eq, Show, Typeable)--data G a = NoG | G1 a | Gn [a]- deriving(Eq, Show, Typeable)--data H a = NoH1 | NoH2 | H1 [a] | H2 [a] | H3 [a]- deriving(Eq, Show, Typeable)--data I a = NoI1 | NoI2 | NoI3 | I1 a | I2 (a,a)- deriving(Eq, Show, Typeable)---instance Arbitrary a => Arbitrary (F a) where- arbitrary = F <$> arbitrary--instance Arbitrary a => Arbitrary (G a) where- arbitrary = oneof- [ pure NoG- , G1 <$> arbitrary- , Gn <$> arbitrary- ]--instance Arbitrary a => Arbitrary (H a) where- arbitrary = oneof- [ pure NoH1- , pure NoH2- , H1 <$> arbitrary- , H2 <$> arbitrary- , H3 <$> arbitrary- ]--instance Arbitrary a => Arbitrary (I a) where- arbitrary = oneof- [ pure NoI1- , pure NoI2- , pure NoI3- , I1 <$> arbitrary- , I2 <$> arbitrary- ]--newtype NatTransf f g- = NatTransf {applyNat :: (forall a . f a -> g a)}---instance Category NatTransf where- id = NatTransf id- f . g = NatTransf (applyNat f . applyNat g)--point :: (forall a . a -> f a) -> NatTransf Identity f-point mkPoint- = NatTransf (\(Identity a) -> mkPoint a)--unit :: (forall a . f a) -> NatTransf UnitF f-unit u- = NatTransf (\UnitF -> u)--headF :: NatTransf NE.NonEmpty Identity-headF- = NatTransf (\(a NE.:| _) -> Identity a)--terminal :: NatTransf f UnitF-terminal- = NatTransf (const UnitF)---instance (ArbitraryF f, ArbitraryF g) => Arbitrary (NatTransf f g) where- arbitrary- = do fromList <- arbitraryf- pure (fromList . flattenf)---class ArbitraryF f where- arbitraryf :: Gen (NatTransf [] f)- flattenf :: NatTransf f []---instance ArbitraryF F where- arbitraryf- = pure $ NatTransf F-- flattenf- = NatTransf (\(F as) -> as)---instance ArbitraryF G where- arbitraryf- = mkArbitraryf- [unit NoG]- [point G1 , point (Gn . pure)]- [NatTransf (Gn . NE.toList)]-- flattenf- = NatTransf $ \case- NoG -> []- G1 a -> [a]- Gn as -> as---instance ArbitraryF H where- arbitraryf- = mkArbitraryf- [unit NoH1, unit NoH2]- [point (H1 . pure), point (H2 . pure)]- [ NatTransf (H1 . NE.toList)- , NatTransf (H2 . NE.toList)- , NatTransf (H2 . NE.toList)- ]-- flattenf- = NatTransf $ \case- NoH1 -> []- NoH2 -> []- H1 as -> as- H2 as -> as- H3 as -> as--instance ArbitraryF I where- arbitraryf- = mkArbitraryf- [unit NoI1, unit NoI2, unit NoI3]- [point I1, NatTransf (\(Identity a) -> I2 (a, a))]- [ NatTransf mkI2 ]- where- mkI2 = \case- a NE.:| [] -> I2 (a, a)- a NE.:| (b:_) -> I2 (a, b)-- flattenf- = NatTransf $ \case- NoI1 -> []- NoI2 -> []- NoI3 -> []- I1 a -> [a]- I2 (a,b) -> [a,b]--mkArbitraryf- :: [NatTransf UnitF f]- -> [NatTransf Identity f]- -> [NatTransf NE.NonEmpty f]- -> Gen (NatTransf [] f)-mkArbitraryf us is ls- = do let nullary = us- unary = is ++ map (. terminal) nullary- nary = ls ++ map (. headF) unary- build <$> elements nullary <*> elements unary <*> elements nary- where- build u i l- = NatTransf $ \case- [] -> applyNat u UnitF- [a] -> applyNat i (Identity a)- a:as -> applyNat l (a NE.:| as)--newtype FG- = FG (NatTransf F G)- deriving (Arbitrary)--newtype GH- = GH (NatTransf G H)- deriving (Arbitrary)--newtype HI- = HI (NatTransf H I)- deriving (Arbitrary)--instance Show FG- where show _ = "<natural-transformation :: F -> G>"--instance Show GH- where show _ = "<natural-transformation :: G -> H>"--instance Show HI- where show _ = "<natural-transformation :: H -> I>"
− test-legacy/Legacy/Spec.hs
@@ -1,204 +0,0 @@-import Test.Tasty (defaultMain, testGroup)-import Test.Tasty.HUnit (testCase, (@?=))--import qualified Legacy.Spec.Bare as Bare-import qualified Legacy.Spec.Constraints as Constraints-import qualified Legacy.Spec.Functor as Functor-import qualified Legacy.Spec.Product as Product-import qualified Legacy.Spec.Traversable as Traversable-import qualified Legacy.Spec.Wrapper as Wrapper--import Legacy.TestBarbies-import Legacy.TestBarbiesW--import Data.Barbie (bfoldMap, bmapC, btraverseC, buniqC)-import Data.Barbie.Bare (Covered)-import Data.Functor.Const (Const (..))-import Data.Functor.Identity (Identity (..))-import Data.Monoid (Sum (..))--main :: IO ()-main- = defaultMain $- testGroup "Tests"- [ testGroup "Functor Laws"- [ Functor.laws @Record0- , Functor.laws @Record1- , Functor.laws @Record3-- , Functor.laws @Record1S- , Functor.laws @Record3S-- , Functor.laws @(Record1W Covered)- , Functor.laws @(Record3W Covered)-- , Functor.laws @(Record1WS Covered)- , Functor.laws @(Record3WS Covered)-- , Functor.laws @Ignore1-- , Functor.laws @Sum3- , Functor.laws @SumRec-- , Functor.laws @(Sum3W Covered)- , Functor.laws @(SumRecW Covered)-- , Functor.laws @CompositeRecord- , Functor.laws @NestedF-- , Functor.laws @(CompositeRecordW Covered)- ]-- , testGroup "Traversable Laws"- [ Traversable.laws @Record0- , Traversable.laws @Record1- , Traversable.laws @Record3-- , Traversable.laws @Record1S- , Traversable.laws @Record3S-- , Traversable.laws @(Record1W Covered)- , Traversable.laws @(Record3W Covered)-- , Traversable.laws @(Record1WS Covered)- , Traversable.laws @(Record3WS Covered)-- , Traversable.laws @Ignore1-- , Traversable.laws @Sum3- , Traversable.laws @SumRec-- , Traversable.laws @(Sum3W Covered)- , Traversable.laws @(SumRecW Covered)-- , Traversable.laws @CompositeRecord- , Traversable.laws @NestedF-- , Traversable.laws @(CompositeRecordW Covered)- ]-- , testGroup "Product Laws"- [ Product.laws @Record0- , Product.laws @Record1- , Product.laws @Record3- , Product.laws @CompositeRecord-- , Product.laws @Record1S- , Product.laws @Record3S-- , Product.laws @(Record1W Covered)- , Product.laws @(Record3W Covered)- , Product.laws @(CompositeRecordW Covered)-- , Product.laws @(Record1WS Covered)- , Product.laws @(Record3WS Covered)- ]-- , testGroup "Uniq Laws"- [ Product.uniqLaws @Record0- , Product.uniqLaws @Record1- , Product.uniqLaws @Record3- , Product.uniqLaws @CompositeRecord-- , Product.uniqLaws @Record1S- , Product.uniqLaws @Record3S-- , Product.uniqLaws @(Record1W Covered)- , Product.uniqLaws @(Record3W Covered)- , Product.uniqLaws @(CompositeRecordW Covered)-- , Product.uniqLaws @(Record1WS Covered)- , Product.uniqLaws @(Record3WS Covered)- ]-- , testGroup "adDict projection"- [ Constraints.lawAddDictPrj @Record0- , Constraints.lawAddDictPrj @Record1- , Constraints.lawAddDictPrj @Record3-- , Constraints.lawAddDictPrj @Record1S- , Constraints.lawAddDictPrj @Record3S-- , Constraints.lawAddDictPrj @(Record1W Covered)- , Constraints.lawAddDictPrj @(Record3W Covered)-- , Constraints.lawAddDictPrj @(Record1WS Covered)- , Constraints.lawAddDictPrj @(Record3WS Covered)-- , Constraints.lawAddDictPrj @Ignore1-- , Constraints.lawAddDictPrj @Sum3- , Constraints.lawAddDictPrj @SumRec-- , Constraints.lawAddDictPrj @(Sum3W Covered)- , Constraints.lawAddDictPrj @(SumRecW Covered)-- , Constraints.lawAddDictPrj @CompositeRecord- , Constraints.lawAddDictPrj @(CompositeRecordW Covered)- ]-- , testGroup "bdicts projection"- [ Constraints.lawDictsEquivPrj @Record0- , Constraints.lawDictsEquivPrj @Record1- , Constraints.lawDictsEquivPrj @Record3- , Constraints.lawDictsEquivPrj @CompositeRecord-- , Constraints.lawDictsEquivPrj @Record1S- , Constraints.lawDictsEquivPrj @Record3S-- , Constraints.lawDictsEquivPrj @(Record1W Covered)- , Constraints.lawDictsEquivPrj @(Record3W Covered)- , Constraints.lawDictsEquivPrj @(CompositeRecordW Covered)-- , Constraints.lawDictsEquivPrj @(Record1WS Covered)- , Constraints.lawDictsEquivPrj @(Record3WS Covered)- ]-- , testGroup "Bare laws"- [ Bare.laws @Record1W- , Bare.laws @Record3W- , Bare.laws @Record1WS- , Bare.laws @Record3WS- , Bare.laws @Sum3W- , Bare.laws @SumRecW- , Bare.laws @NestedFW- ]-- , testGroup "Generic wrapper"- [ Wrapper.lawsMonoid @Record1- , Wrapper.lawsMonoid @(Record1W Covered)-- , Wrapper.lawsMonoid @Record1S- , Wrapper.lawsMonoid @(Record1WS Covered)-- , Wrapper.lawsMonoid @Record3- , Wrapper.lawsMonoid @(Record3W Covered)-- , Wrapper.lawsMonoid @Record3S- , Wrapper.lawsMonoid @(Record3WS Covered)- ]-- , testGroup "bfoldMap"- [ testCase "Record3" $ do- let b = Record3 (Const "tic") (Const "tac") (Const "toe")- bfoldMap getConst b @?= "tictactoe"- ]- , testGroup- "bmapC"- [ testCase "Record1" $- bmapC @Num (fmap (+1)) (Record1 (Identity 0))- @?= Record1 (Identity 1)- ]- , testGroup- "btraverseC"- [ testCase "Record1" $- btraverseC @Num (\inner -> (Sum @Int 1, fmap (+ 1) inner)) (Record1 (Identity 0))- @?= (Sum 1, Record1 (Identity 1))- ]- , testGroup- "buniqC"- [ testCase "Record1" $- buniqC @Num (Identity (fromIntegral (42 :: Int)))- @?= Record1 (Identity 42)- ]- ]
− test-legacy/Legacy/Spec/Bare.hs
@@ -1,30 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-module Legacy.Spec.Bare ( laws )--where--import Data.Barbie.Bare (BareB(..), Covered)-import Data.Functor.Identity--import Data.Typeable (Typeable, typeRep, Proxy(..))--import Test.Tasty(testGroup, TestTree)-import Test.Tasty.QuickCheck(Arbitrary(..), testProperty, (===))--laws- :: forall b- . ( BareB b- , Eq (b Covered Identity) , Show (b Covered Identity) , Arbitrary (b Covered Identity)- -- , Show (b Bare Identity), Eq (b Bare Identity), Arbitrary (b Bare Identity)- , Typeable b- )- => TestTree-laws- = testGroup (show (typeRep (Proxy :: Proxy b)))- [ testProperty "bcover . bstrip = id" $ \b ->- bcover (bstrip b) === (b :: b Covered Identity)-- -- TODO: FIXME- -- , testProperty "bstrip . bcover = id" $ \b ->- -- bstrip (bcover b) === (b :: b Bare)- ]
− test-legacy/Legacy/Spec/Constraints.hs
@@ -1,49 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-module Legacy.Spec.Constraints- ( lawAddDictPrj- , lawDictsEquivPrj- )--where--import Legacy.Clothes(F)-import Data.Barbie(bmap, ConstraintsB(..), AllBF, ProductBC(..))-import Data.Barbie.Constraints(ClassF, Dict)--import Data.Functor.Product (Product(Pair))-import Data.Typeable(Typeable, Proxy(..), typeRep)--import Test.Tasty(TestTree)-import Test.Tasty.QuickCheck(Arbitrary(..), testProperty, (===))---lawAddDictPrj- :: forall b- . ( ConstraintsB b, AllBF Show F b- , Eq (b F)- , Show (b F)- , Arbitrary (b F)- , Typeable b- )- => TestTree-lawAddDictPrj- = testProperty (show (typeRep (Proxy :: Proxy b))) $ \b ->- bmap second (baddDicts b :: b (Dict (ClassF Show F) `Product` F)) === b- where- second (Pair _ b) = b---lawDictsEquivPrj- :: forall b- . ( ProductBC b, AllBF Show F b- , Eq (b (Dict (ClassF Show F)))- , Show (b F), Show (b (Dict (ClassF Show F)))- , Arbitrary (b F)- , Typeable b- )- => TestTree-lawDictsEquivPrj- = testProperty (show (typeRep (Proxy :: Proxy b))) $ \b ->- bmap first (baddDicts b :: b (Dict (ClassF Show F) `Product` F)) === bdicts- where- first (Pair a _) = a
− test-legacy/Legacy/Spec/Functor.hs
@@ -1,32 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-module Legacy.Spec.Functor ( laws )--where--import Legacy.Clothes (F, H, FG(..), GH(..), NatTransf(..))--import Data.Barbie (FunctorB(..))--import Data.Typeable (Typeable, typeRep, Proxy(..))--import Test.Tasty(testGroup, TestTree)-import Test.Tasty.QuickCheck(Arbitrary(..), testProperty, (===))--laws- :: forall b- . ( FunctorB b- , Eq (b F), Eq (b H)- , Show (b F), Show (b H)- , Arbitrary (b F)- , Typeable b- )- => TestTree-laws- = testGroup (show (typeRep (Proxy :: Proxy b)))- [ testProperty "bmap id = id" $ \b ->- bmap id b === (b :: b F)-- , testProperty "bmap (f . g) = bmap f . bmap g)" $- \b (GH (NatTransf f)) (FG (NatTransf g)) ->- bmap (f . g) b === (bmap f . bmap g) (b :: b F)- ]
− test-legacy/Legacy/Spec/Product.hs
@@ -1,45 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-module Legacy.Spec.Product ( laws, uniqLaws )--where--import Legacy.Clothes(F, G)--import Data.Barbie(FunctorB(..), ProductB(..))--import Data.Functor.Product(Product(Pair))-import Data.Typeable(Typeable, Proxy(..), typeRep)--import Test.Tasty(TestTree)-import Test.Tasty.QuickCheck(Arbitrary(..), testProperty, (===))---laws- :: forall b- . ( ProductB b- , Eq (b F), Eq (b G)- , Show (b F), Show (b G)- , Arbitrary (b F), Arbitrary (b G)- , Typeable b- )- => TestTree-laws- = testProperty (show (typeRep (Proxy :: Proxy b))) $ \l r ->- bmap first (bprod l r) == (l :: b F) &&- bmap second (bprod l r) == (r :: b G)- where- first (Pair a _) = a- second (Pair _ b) = b--uniqLaws- :: forall b- . ( ProductB b- , Eq (b Maybe)- , Show (b F), Show (b Maybe)- , Arbitrary (b F)- , Typeable b- )- => TestTree-uniqLaws- = testProperty (show (typeRep (Proxy :: Proxy b))) $ \b ->- bmap (const Nothing) (b :: b F) === buniq Nothing
− test-legacy/Legacy/Spec/Traversable.hs
@@ -1,44 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-module Legacy.Spec.Traversable ( laws )--where--import Legacy.Clothes (F, G, H, FG(..), GH(..), NatTransf(..))--import Data.Barbie (TraversableB(..))--import Data.Functor.Compose (Compose(..))-import Data.Functor.Identity (Identity(..))-import Data.Maybe (maybeToList)-import Data.Typeable (Typeable, typeRep, Proxy(..))--import Test.Tasty(testGroup, TestTree)-import Test.Tasty.QuickCheck(Arbitrary(..), testProperty, (===))--laws- :: forall b- . ( TraversableB b- , Eq (b F), Eq (b G), Eq (b H)- , Show (b F), Show (b G), Show (b H)- , Arbitrary (b F)- , Typeable b- )- => TestTree-laws- = testGroup (show (typeRep (Proxy :: Proxy b)))- [testProperty "naturality" $- \b (FG (NatTransf fg)) ->- let f = Just . fg- t = maybeToList- in (t . btraverse f) (b :: b F) === btraverse (t . f) (b :: b F)-- , testProperty "identity" $ \b ->- btraverse Identity b === Identity (b :: b F)-- , testProperty "composition" $- \b (FG (NatTransf fg)) (GH (NatTransf gh)) ->- let f x = Just (fg x)- g x = [gh x]- in btraverse (Compose . fmap g . f) b ===- (Compose . fmap (btraverse g) . btraverse f) (b :: b F)- ]
− test-legacy/Legacy/Spec/Wrapper.hs
@@ -1,37 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE AllowAmbiguousTypes #-}-module Legacy.Spec.Wrapper (- lawsMonoid- )--where--import Data.Barbie (AllBF, Barbie(..), ProductBC)--import Test.Tasty(testGroup, TestTree)-import Test.Tasty.QuickCheck(Arbitrary(..), testProperty)--lawsMonoid- :: forall b- . ( Arbitrary (b []), Eq (b []), Show (b [])- , ProductBC b- , AllBF Semigroup [] b- , AllBF Monoid [] b- )- => TestTree-lawsMonoid- = testGroup "Monoid laws"- [ testProperty "neutral element" $ \b ->- unwrap (Barbie b <> mempty) == b &&- unwrap (mempty <> Barbie b) == b-- , testProperty "associativity" $ \b1 b2 b3 ->- unwrap ((Barbie b1 <> Barbie b2) <> Barbie b3) ==- unwrap ( Barbie b1 <> (Barbie b2 <> Barbie b3))- ]- where- unwrap = getBarbie :: Barbie b [] -> b []---instance Arbitrary (b f) => Arbitrary (Barbie b f) where- arbitrary = Barbie <$> arbitrary
− test-legacy/Legacy/TestBarbies.hs
@@ -1,306 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-module Legacy.TestBarbies- ( Void-- , Record0(..)- , Record1(..)- , Record3(..)-- , Record1S(..)- , Record3S(..)-- , Ignore1(..)-- , Sum3(..)-- , CompositeRecord(..)- , SumRec(..)- , InfRec(..)-- , NestedF(..)-- , HKB(..)- )--where--import Data.Barbie--import Data.Kind(Type)-import Data.Typeable-import GHC.Generics-import Test.Tasty.QuickCheck--------------------------------------------------------- Product Barbies-------------------------------------------------------data Record0 (f :: Type -> Type)- = Record0- deriving- ( Generic, Typeable- , Eq, Show- )--instance FunctorB Record0-instance TraversableB Record0-instance ProductB Record0-instance ConstraintsB Record0-instance ProductBC Record0--instance Arbitrary (Record0 f) where arbitrary = pure Record0---data Record1 f- = Record1 { rec1_f1 :: f Int }- deriving (Generic, Typeable)---instance FunctorB Record1-instance TraversableB Record1-instance ProductB Record1-instance ConstraintsB Record1-instance ProductBC Record1--deriving instance AllBF Show f Record1 => Show (Record1 f)-deriving instance AllBF Eq f Record1 => Eq (Record1 f)--instance AllBF Arbitrary f Record1 => Arbitrary (Record1 f) where- arbitrary = Record1 <$> arbitrary---data Record1S f- = Record1S { rec1s_f1 :: !(f Int) }- deriving (Generic, Typeable)---instance FunctorB Record1S-instance TraversableB Record1S-instance ProductB Record1S-instance ConstraintsB Record1S-instance ProductBC Record1S--deriving instance AllBF Show f Record1S => Show (Record1S f)-deriving instance AllBF Eq f Record1S => Eq (Record1S f)--instance AllBF Arbitrary f Record1S => Arbitrary (Record1S f) where- arbitrary = Record1S <$> arbitrary---data Record3 f- = Record3- { rec3_f1 :: f Int- , rec3_f2 :: f Bool- , rec3_f3 :: f Char- }- deriving (Generic, Typeable)---instance FunctorB Record3-instance TraversableB Record3-instance ProductB Record3-instance ConstraintsB Record3-instance ProductBC Record3--deriving instance AllBF Show f Record3 => Show (Record3 f)-deriving instance AllBF Eq f Record3 => Eq (Record3 f)--instance AllBF Arbitrary f Record3 => Arbitrary (Record3 f) where- arbitrary = Record3 <$> arbitrary <*> arbitrary <*> arbitrary--data Record3S f- = Record3S- { rec3s_f1 :: !(f Int)- , rec3s_f2 :: !(f Bool)- , rec3s_f3 :: !(f Char)- }- deriving (Generic, Typeable)---instance FunctorB Record3S-instance TraversableB Record3S-instance ProductB Record3S-instance ConstraintsB Record3S-instance ProductBC Record3S--deriving instance AllBF Show f Record3S => Show (Record3S f)-deriving instance AllBF Eq f Record3S => Eq (Record3S f)--instance AllBF Arbitrary f Record3S => Arbitrary (Record3S f) where- arbitrary = Record3S <$> arbitrary <*> arbitrary <*> arbitrary---------------------------------------------------------- Bad products--------------------------------------------------------data Ignore1 (f :: Type -> Type)- = Ignore1 { ign1_f1 :: Int }- deriving (Generic, Typeable, Eq, Show)--instance FunctorB Ignore1-instance TraversableB Ignore1-instance ConstraintsB Ignore1--instance Arbitrary (Ignore1 f) where arbitrary = Ignore1 <$> arbitrary----------------------------------------------------------- Sums--------------------------------------------------------data Sum3 f- = Sum3_0- | Sum3_1 (f Int)- | Sum3_2 (f Int) (f Bool)- deriving (Generic, Typeable)--instance FunctorB Sum3-instance TraversableB Sum3-instance ConstraintsB Sum3--deriving instance AllBF Show f Sum3 => Show (Sum3 f)-deriving instance AllBF Eq f Sum3 => Eq (Sum3 f)--instance AllBF Arbitrary f Sum3 => Arbitrary (Sum3 f) where- arbitrary- = oneof- [ pure Sum3_0- , Sum3_1 <$> arbitrary- , Sum3_2 <$> arbitrary <*> arbitrary- ]---------------------------------------------------------- Composite and recursive--------------------------------------------------------data CompositeRecord f- = CompositeRecord- { crec_f1 :: f Int- , crec_F2 :: f Bool- , crec_f3 :: Record3 f- , crec_f4 :: Record1 f- }- deriving (Generic, Typeable)--instance FunctorB CompositeRecord-instance TraversableB CompositeRecord-instance ProductB CompositeRecord-instance ConstraintsB CompositeRecord-instance ProductBC CompositeRecord--deriving instance AllBF Show f CompositeRecord => Show (CompositeRecord f)-deriving instance AllBF Eq f CompositeRecord => Eq (CompositeRecord f)--instance AllBF Arbitrary f CompositeRecord => Arbitrary (CompositeRecord f) where- arbitrary- = CompositeRecord <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary--data SumRec f- = SumRec_0- | SumRec_1 (f Int)- | SumRec_2 (f Int) (SumRec f)- deriving (Generic, Typeable)--instance FunctorB SumRec-instance TraversableB SumRec-instance ConstraintsB SumRec--deriving instance AllBF Show f SumRec => Show (SumRec f)-deriving instance AllBF Eq f SumRec => Eq (SumRec f)--instance AllBF Arbitrary f SumRec => Arbitrary (SumRec f) where- arbitrary- = oneof- [ pure SumRec_0- , SumRec_1 <$> arbitrary- , SumRec_2 <$> arbitrary <*> arbitrary- ]--data InfRec f- = InfRec { ir_1 :: f Int, ir_2 :: InfRec f }- deriving (Generic, Typeable)--instance FunctorB InfRec-instance TraversableB InfRec-instance ProductB InfRec-instance ConstraintsB InfRec-instance ProductBC InfRec--deriving instance AllBF Show f InfRec => Show (InfRec f)-deriving instance AllBF Eq f InfRec => Eq (InfRec f)---------------------------------------------------------- Nested under functors--------------------------------------------------------data NestedF f- = NestedF- { npf_1 :: f Int- , npf_2 :: [Record3 f]- , npf_3 :: Maybe (Sum3 f)- , npf_4 :: Maybe (NestedF f)- }- deriving (Generic, Typeable)--instance FunctorB NestedF-instance TraversableB NestedF--deriving instance (Show (f Int), Show (Record3 f), Show (Sum3 f)) => Show (NestedF f)-deriving instance (Eq (f Int), Eq (Record3 f), Eq (Sum3 f)) => Eq (NestedF f)--instance (Arbitrary (f Int), AllBF Arbitrary f Record3, AllBF Arbitrary f Sum3) => Arbitrary (NestedF f) where- arbitrary = NestedF <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary------------------------------------------------------------ Parametric barbies--------------------------------------------------------data ParB b (f :: Type -> Type)- = ParB (b f)- deriving (Generic, Typeable)--instance FunctorB b => FunctorB (ParB b)-instance TraversableB b => TraversableB (ParB b)-instance ProductB b => ProductB (ParB b)-instance ConstraintsB b => ConstraintsB (ParB b)-instance ProductBC b => ProductBC (ParB b)--data ParBH h b (f :: Type -> Type)- = ParBH (h (b f))- deriving (Generic, Typeable)--instance (Functor h, FunctorB b) => FunctorB (ParBH h b)-instance (Traversable h, TraversableB b) => TraversableB (ParBH h b)--data ParX a f- = ParX (f a)- deriving (Generic, Typeable)--instance FunctorB (ParX a)-instance TraversableB (ParX a)-instance ProductB (ParX a)-instance ConstraintsB (ParX a)-instance ProductBC (ParX a)----------------------------------------------------------- Higher-kinded barbies--------------------------------------------------------data HKB b- = HKB- { hkb1 :: b Maybe- , khb2 :: b ([])- }- deriving (Generic, Typeable)--instance FunctorB HKB-instance TraversableB HKB-instance ProductB HKB-instance ConstraintsB HKB-instance ProductBC HKB
− test-legacy/Legacy/TestBarbiesW.hs
@@ -1,324 +0,0 @@-{-# OPTIONS_GHC -O0 #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-module Legacy.TestBarbiesW- ( Record1W(..)- , Record3W(..)-- , Record1WS(..)- , Record3WS(..)-- , Sum3W(..)-- , CompositeRecordW(..)- , SumRecW(..)- , InfRecW(..)-- , NestedFW(..)- )--where--import Data.Barbie-import Data.Barbie.Bare--import Data.Kind(Type)-import Data.Typeable-import GHC.Generics-import Test.Tasty.QuickCheck--------------------------------------------------------- Product Barbies-------------------------------------------------------data Record1W t f- = Record1W { rec1w_f1 :: Wear t f Int }- deriving (Generic, Typeable)---instance FunctorB (Record1W Bare)-instance FunctorB (Record1W Covered)-instance TraversableB (Record1W Covered)-instance ProductB (Record1W Covered)-instance ConstraintsB (Record1W Bare)-instance ConstraintsB (Record1W Covered)-instance ProductBC (Record1W Covered)-instance BareB Record1W---deriving instance AllB Show (Record1W Bare) => Show (Record1W Bare f)-deriving instance AllB Eq (Record1W Bare) => Eq (Record1W Bare f)-deriving instance AllBF Show f (Record1W Covered) => Show (Record1W Covered f)-deriving instance AllBF Eq f (Record1W Covered) => Eq (Record1W Covered f)--instance AllBF Arbitrary f (Record1W Covered) => Arbitrary (Record1W Covered f) where- arbitrary = Record1W <$> arbitrary---data Record1WS t f- = Record1WS { rec1ws_f1 :: !(Wear t f Int) }- deriving (Generic, Typeable)---instance FunctorB (Record1WS Bare)-instance FunctorB (Record1WS Covered)-instance TraversableB (Record1WS Covered)-instance ProductB (Record1WS Covered)-instance ConstraintsB (Record1WS Bare)-instance ConstraintsB (Record1WS Covered)-instance ProductBC (Record1WS Covered)-instance BareB Record1WS---deriving instance AllB Show (Record1WS Bare) => Show (Record1WS Bare f)-deriving instance AllB Eq (Record1WS Bare) => Eq (Record1WS Bare f)-deriving instance AllBF Show f (Record1WS Covered) => Show (Record1WS Covered f)-deriving instance AllBF Eq f (Record1WS Covered) => Eq (Record1WS Covered f)--instance AllBF Arbitrary f (Record1WS Covered) => Arbitrary (Record1WS Covered f) where- arbitrary = Record1WS <$> arbitrary--data Record3W t f- = Record3W- { rec3w_f1 :: Wear t f Int- , rec3w_f2 :: Wear t f Bool- , rec3w_f3 :: Wear t f Char- }- deriving (Generic, Typeable)---instance FunctorB (Record3W Bare)-instance FunctorB (Record3W Covered)-instance TraversableB (Record3W Covered)-instance ProductB (Record3W Covered)-instance ConstraintsB (Record3W Bare)-instance ConstraintsB (Record3W Covered)-instance ProductBC (Record3W Covered)--instance BareB Record3W--deriving instance AllB Show (Record3W Bare) => Show (Record3W Bare f)-deriving instance AllB Eq (Record3W Bare) => Eq (Record3W Bare f)-deriving instance AllBF Show f (Record3W Covered) => Show (Record3W Covered f)-deriving instance AllBF Eq f (Record3W Covered) => Eq (Record3W Covered f)--instance AllBF Arbitrary f (Record3W Covered) => Arbitrary (Record3W Covered f) where- arbitrary = Record3W <$> arbitrary <*> arbitrary <*> arbitrary---data Record3WS t f- = Record3WS- { rec3ws_f1 :: !(Wear t f Int)- , rec3ws_f2 :: !(Wear t f Bool)- , rec3ws_f3 :: !(Wear t f Char)- }- deriving (Generic, Typeable)---instance FunctorB (Record3WS Bare)-instance FunctorB (Record3WS Covered)-instance TraversableB (Record3WS Covered)-instance ProductB (Record3WS Covered)-instance ConstraintsB (Record3WS Bare)-instance ConstraintsB (Record3WS Covered)-instance ProductBC (Record3WS Covered)-instance BareB Record3WS--deriving instance AllB Show (Record3WS Bare) => Show (Record3WS Bare f)-deriving instance AllB Eq (Record3WS Bare) => Eq (Record3WS Bare f)-deriving instance AllBF Show f (Record3WS Covered) => Show (Record3WS Covered f)-deriving instance AllBF Eq f (Record3WS Covered) => Eq (Record3WS Covered f)--instance AllBF Arbitrary f (Record3WS Covered) => Arbitrary (Record3WS Covered f) where- arbitrary = Record3WS <$> arbitrary <*> arbitrary <*> arbitrary---------------------------------------------------------- Sum Barbies-------------------------------------------------------data Sum3W t f- = Sum3W_0- | Sum3W_1 (Wear t f Int)- | Sum3W_2 (Wear t f Int) (Wear t f Bool)- deriving (Generic, Typeable)--instance FunctorB (Sum3W Bare)-instance FunctorB (Sum3W Covered)-instance TraversableB (Sum3W Covered)-instance ConstraintsB (Sum3W Bare)-instance ConstraintsB (Sum3W Covered)-instance BareB Sum3W--deriving instance AllB Show (Sum3W Bare) => Show (Sum3W Bare f)-deriving instance AllB Eq (Sum3W Bare) => Eq (Sum3W Bare f)-deriving instance AllBF Show f (Sum3W Covered) => Show (Sum3W Covered f)-deriving instance AllBF Eq f (Sum3W Covered) => Eq (Sum3W Covered f)--instance AllBF Arbitrary f (Sum3W Covered) => Arbitrary (Sum3W Covered f) where- arbitrary- = oneof- [ pure Sum3W_0- , Sum3W_1 <$> arbitrary- , Sum3W_2 <$> arbitrary <*> arbitrary- ]----------------------------------------------------------- Composite and recursive---------------------------------------------------------data CompositeRecordW t f- = CompositeRecordW- { crecw_f1 :: Wear t f Int- , crecw_F2 :: Wear t f Bool- , crecw_f3 :: Record3W t f- , crecw_f4 :: Record1W t f- }- deriving (Generic, Typeable)--instance FunctorB (CompositeRecordW Bare)-instance FunctorB (CompositeRecordW Covered)-instance TraversableB (CompositeRecordW Covered)-instance ProductB (CompositeRecordW Covered)-instance ConstraintsB (CompositeRecordW Bare)-instance ConstraintsB (CompositeRecordW Covered)-instance ProductBC (CompositeRecordW Covered)-instance BareB CompositeRecordW--deriving instance AllB Show (CompositeRecordW Bare) => Show (CompositeRecordW Bare f)-deriving instance AllB Eq (CompositeRecordW Bare) => Eq (CompositeRecordW Bare f)-deriving instance AllBF Show f (CompositeRecordW Covered) => Show (CompositeRecordW Covered f)-deriving instance AllBF Eq f (CompositeRecordW Covered) => Eq (CompositeRecordW Covered f)--instance AllBF Arbitrary f (CompositeRecordW Covered) => Arbitrary (CompositeRecordW Covered f) where- arbitrary- = CompositeRecordW <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary---data SumRecW t f- = SumRecW_0- | SumRecW_1 (Wear t f Int)- | SumRecW_2 (Wear t f Int) (SumRecW t f)- deriving (Generic, Typeable)--instance FunctorB (SumRecW Bare)-instance FunctorB (SumRecW Covered)-instance TraversableB (SumRecW Covered)-instance ConstraintsB (SumRecW Bare)-instance ConstraintsB (SumRecW Covered)-instance BareB SumRecW--deriving instance AllB Show (SumRecW Bare) => Show (SumRecW Bare f)-deriving instance AllB Eq (SumRecW Bare) => Eq (SumRecW Bare f)-deriving instance AllBF Show f (SumRecW Covered) => Show (SumRecW Covered f)-deriving instance AllBF Eq f (SumRecW Covered) => Eq (SumRecW Covered f)--instance AllBF Arbitrary f (SumRecW Covered) => Arbitrary (SumRecW Covered f) where- arbitrary- = oneof- [ pure SumRecW_0- , SumRecW_1 <$> arbitrary- , SumRecW_2 <$> arbitrary <*> arbitrary- ]--data InfRecW t f- = InfRecW { irw_1 :: Wear t f Int, irw_2 :: InfRecW t f }- deriving (Generic, Typeable)---instance FunctorB (InfRecW Bare)-instance FunctorB (InfRecW Covered)-instance TraversableB (InfRecW Covered)-instance ProductB (InfRecW Covered)-instance ConstraintsB (InfRecW Bare)-instance ConstraintsB (InfRecW Covered)-instance ProductBC (InfRecW Covered)-instance BareB InfRecW--deriving instance AllB Show (InfRecW Bare) => Show (InfRecW Bare f)-deriving instance AllB Eq (InfRecW Bare) => Eq (InfRecW Bare f)-deriving instance AllBF Show f (InfRecW Covered) => Show (InfRecW Covered f)-deriving instance AllBF Eq f (InfRecW Covered) => Eq (InfRecW Covered f)---------------------------------------------------------- Nested under functors--------------------------------------------------------data NestedFW t f- = NestedFW- { npfw_1 :: Wear t f Int- , npfw_2 :: [Record3W t f]- , npfw_3 :: Maybe (Sum3W t f)- , npfw_4 :: Maybe (NestedFW t f)- }- deriving (Generic, Typeable)----instance FunctorB (NestedFW Bare)-instance FunctorB (NestedFW Covered)-instance TraversableB (NestedFW Covered)-instance BareB NestedFW--- instance ConstraintsB (NestedFW Bare)--- instance ConstraintsB (NestedFW Covered)--deriving instance Show (NestedFW Bare f)-deriving instance Eq (NestedFW Bare f)-deriving instance (Show (f Int), Show (Record3W Covered f), Show (Sum3W Covered f)) => Show (NestedFW Covered f)-deriving instance (Eq (f Int), Eq (Record3W Covered f), Eq (Sum3W Covered f)) => Eq (NestedFW Covered f)--instance (Arbitrary (f Int), Arbitrary (f Bool), Arbitrary (f Char)) => Arbitrary (NestedFW Covered f) where- arbitrary = NestedFW <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary----------------------------------------------------------- Parametric barbies--------------------------------------------------------data ParBW b t (f :: Type -> Type)- = ParBW (b t f)- deriving (Generic, Typeable)--instance FunctorB (b t) => FunctorB (ParBW b t)-instance TraversableB (b t) => TraversableB (ParBW b t)-instance ProductB (b t) => ProductB (ParBW b t)-instance BareB b => BareB (ParBW b)---- XXX GHC currently rejects deriving this one since it--- gets stuck on the TagSelf type family and can't see this--- is an "Other" case. It looks like a bug to me, since it--- seems to have enough information to decide that it is the--- `Other` case that should be picked (or in any case, I don't--- quite see why this is not an issue when `b` doesn't have the--- extra type parameter.-instance ConstraintsB (b t) => ConstraintsB (ParBW b t) where- type AllB c (ParBW b t) = AllB c (b t)- baddDicts (ParBW btf) = ParBW (baddDicts btf)---- XXX SEE NOTE ON ConstraintsB-instance ProductBC (b t) => ProductBC (ParBW b t) where- bdicts = ParBW bdicts--data ParBHW h b t (f :: Type -> Type)- = ParBHW (h (b t f))- deriving (Generic, Typeable)--instance (Functor h, FunctorB (b t)) => FunctorB (ParBHW h b t)-instance (Traversable h, TraversableB (b t)) => TraversableB (ParBHW h b t)-instance (Functor h, BareB b) => BareB (ParBHW h b)--data ParXW a t f- = ParXW (Wear t f a)- deriving (Generic, Typeable)--instance FunctorB (ParXW a Bare)-instance FunctorB (ParXW a Covered)-instance TraversableB (ParXW a Covered)-instance ProductB (ParXW a Covered)-instance ConstraintsB (ParXW a Covered)-instance ProductBC (ParXW a Covered)