barbies 2.0.0.0 → 2.0.1.0

raw patch · 16 files changed

+605/−17 lines, 16 filesdep +distributivePVP ok

version bump matches the API change (PVP)

Dependencies added: distributive

API changes (from Hackage documentation)

Files

• ChangeLog.md +3/−0
• barbies.cabal +8/−1
• src/Barbies/Bi.hs +7/−0
• src/Barbies/Generics/Distributive.hs +78/−0
• src/Barbies/Internal.hs +8/−4
• src/Barbies/Internal/DistributiveB.hs +166/−0
• src/Barbies/Internal/DistributiveT.hs +218/−0
• src/Barbies/Internal/Trivial.hs +2/−0
• src/Data/Functor/Barbie.hs +8/−0
• src/Data/Functor/Transformer.hs +8/−0
• test/Clothes.hs +4/−4
• test/Spec.hs +24/−0
• test/Spec/Distributive.hs +40/−0
• test/TestBarbies.hs +10/−2
• test/TestBarbiesW.hs +7/−0
• test/TestBiBarbies.hs +14/−6

@@ -1,5 +1,8 @@ # Changelog for barbies +## 2.0.1.0+  - Add the `DistributiveB` class (Gergő Érdi).+ ## 2.0.0.0   - Builds with ghc 8.8, but drops support for ghc 8.0 and 8.2   - Fix failure to derive `TraversableB` and `ConstraintsB` when using a type

@@ -1,5 +1,5 @@ name:           barbies-version:        2.0.0.0+version:        2.0.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@@ -43,6 +43,7 @@       Barbies.Generics.Applicative       Barbies.Generics.Bare       Barbies.Generics.Constraints+      Barbies.Generics.Distributive       Barbies.Generics.Functor       Barbies.Generics.Traversable @@ -55,6 +56,9 @@       Barbies.Internal.Containers       Barbies.Internal.Dicts +      Barbies.Internal.DistributiveB+      Barbies.Internal.DistributiveT+       Barbies.Internal.FunctorB       Barbies.Internal.FunctorT @@ -79,6 +83,7 @@    build-depends:       base >=4.11 && <5,+      distributive,       transformers    ghc-options: -Wall@@ -120,6 +125,7 @@       Spec.Applicative       Spec.Bare       Spec.Constraints+      Spec.Distributive       Spec.Functor       Spec.Traversable       Spec.Wrapper@@ -132,6 +138,7 @@   build-depends:       barbies     , base >=4.7 && <5+    , distributive     , QuickCheck     , tasty     , tasty-hunit

@@ -161,6 +161,9 @@     = Flip (tmap h bfx)   {-# INLINE bmap #-} +instance DistributiveT b => DistributiveB (Flip b f) where+  bdistribute = Flip . tdistribute . fmap runFlip+  {-# INLINE bdistribute #-}  instance TraversableT b => TraversableB (Flip b f) where   btraverse h (Flip bfx)@@ -185,6 +188,10 @@   tmap h (Flip bxf)     = Flip (bmap h bxf)   {-# INLINE tmap #-}++instance (forall f. DistributiveB (b f)) => DistributiveT (Flip b) where+  tdistribute = Flip . bdistribute . fmap runFlip+  {-# INLINE tdistribute #-}  instance (forall f. TraversableB (b f)) => TraversableT (Flip b) where   ttraverse h (Flip bxf)

@@ -0,0 +1,78 @@+{-# LANGUAGE PolyKinds    #-}+{-# LANGUAGE TypeFamilies #-}+module Barbies.Generics.Distributive+  ( GDistributive(..)+  )++where++import Data.Generics.GenericN+import Data.Proxy (Proxy (..))++import Data.Functor.Compose   (Compose (..))+import Data.Distributive      (Distributive(..))++import GHC.TypeLits (Nat)++class (Functor f) => GDistributive (n :: Nat) f repbg repbfg where+  gdistribute :: Proxy n -> f (repbg x) -> repbfg x++-- ----------------------------------+-- Trivial cases+-- ----------------------------------++instance+  ( GDistributive n f bg bfg+  ) => GDistributive n f (M1 i c bg) (M1 i c bfg)+  where+  gdistribute pn = M1 . gdistribute pn . fmap unM1+  {-# INLINE gdistribute #-}+++instance+  ( Functor f+  ) => GDistributive n f U1 U1+  where+  gdistribute _ = const U1+  {-# INLINE gdistribute #-}+++fstF :: (l :*: r) a -> l a+fstF (x :*: _y) = x++sndF :: (l :*: r) a -> r a+sndF (_x :*: y) = y++instance+  ( GDistributive n f l l'+  , GDistributive n f r r'+  )+  => GDistributive n f (l :*: r) (l' :*: r')+  where+  gdistribute pn lr = gdistribute pn (fstF <$> lr) :*: gdistribute pn (sndF <$> lr)+  {-# INLINE gdistribute #-}+++-- ---------------------------------------------------------+-- The interesting cases.+-- There are more interesting cases for specific values of n+-- ---------------------------------------------------------++type P = Param++instance+  ( Functor f+  ) =>+  GDistributive n f (Rec (P n g a) (g a)) (Rec (P n (Compose f g) a) (Compose f g a))+  where+  gdistribute _ = Rec . K1 . Compose . id . fmap (unK1 . unRec)+  {-# INLINE gdistribute #-}++instance+  ( Functor f+  , Distributive h+  ) =>+  GDistributive n f (Rec (h (P n g a)) (h (g a))) (Rec (h (P n (Compose f g) a)) (h (Compose f g a)))+  where+  gdistribute _ = Rec . K1 . fmap Compose . distribute . fmap (unK1 . unRec)+  {-# INLINE gdistribute #-}

@@ -5,15 +5,17 @@   , Internal.CanDeriveFunctorB   , Internal.CanDeriveFunctorT --     -- * Traversable   , Internal.gbtraverseDefault   , Generics.GTraversable(..)   , Internal.CanDeriveTraversableB   , Internal.CanDeriveTraversableT -+    -- * Distributive+  , Internal.gbdistributeDefault+  , Generics.GDistributive(..)+  , Internal.CanDeriveDistributiveB+  , Internal.CanDeriveDistributiveT      -- * Applicative   , Internal.gbpureDefault@@ -23,7 +25,6 @@   , Internal.CanDeriveApplicativeT  -     -- * Constraints   , Internal.gbaddDictsDefault   , Generics.GConstraints(..)@@ -54,6 +55,7 @@ import qualified Barbies.Generics.Applicative as Generics import qualified Barbies.Generics.Bare as Generics import qualified Barbies.Generics.Constraints as Generics+import qualified Barbies.Generics.Distributive as Generics import qualified Barbies.Generics.Functor as Generics import qualified Barbies.Generics.Traversable as Generics @@ -62,6 +64,8 @@ import qualified Barbies.Internal.BareB as Internal import qualified Barbies.Internal.ConstraintsB as Internal import qualified Barbies.Internal.ConstraintsT as Internal+import qualified Barbies.Internal.DistributiveB as Internal+import qualified Barbies.Internal.DistributiveT as Internal import qualified Barbies.Internal.FunctorB as Internal import qualified Barbies.Internal.FunctorT as Internal import qualified Barbies.Internal.TraversableB as Internal

@@ -0,0 +1,166 @@+{-# LANGUAGE PolyKinds    #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-orphans #-}+module Barbies.Internal.DistributiveB+  ( DistributiveB(..)+  , bdistribute'+  , bcotraverse+  , bdecompose+  , brecompose+  , gbdistributeDefault+  , CanDeriveDistributiveB+  )++where++import Barbies.Internal.FunctorB (FunctorB(..))+import Barbies.Generics.Distributive (GDistributive(..))++import Data.Functor.Compose   (Compose (..))+import Data.Functor.Identity  (Identity (..))+import Data.Functor.Product   (Product (..))+import Data.Generics.GenericN+import Data.Proxy             (Proxy (..))+import Data.Distributive+import Data.Kind              (Type)++-- | A 'FunctorB' where the effects can be distributed to the fields:+--  `bdistribute` turns an effectful way of building a Barbie-type+--  into a pure Barbie-type with effectful ways of computing the+--  values of its fields.+--+--  This class is the categorical dual of `Barbies.Internal.TraversableB.TraversableB`,+--  with `bdistribute` the dual of `Barbies.Internal.TraversableB.bsequence`+--  and `bcotraverse` the dual of `Barbies.Internal.TraversableB.btraverse`. As such,+--  instances need to satisfy these laws:+--+-- @+-- 'bdistribute' . h = 'bmap' ('Compose' . h . 'getCompose') . 'bdistribute'    -- naturality+-- 'bdistribute' . 'Data.Functor.Identity' = 'bmap' ('Compose' . 'Data.Functor.Identity')                 -- identity+-- 'bdistribute' . 'Compose' = 'bmap' ('Compose' . 'Compose' . 'fmap' 'getCompose' . 'getCompose') . 'bdistribute' . 'fmap' 'bdistribute' -- composition+-- @+--+-- By specializing @f@ to @((->) a)@ and @g@ to 'Identity', we can define a function that+-- decomposes a function on distributive barbies into a collection of simpler functions:+--+-- @+-- 'bdecompose' :: 'DistributiveB' b => (a -> b 'Identity') -> b ((->) a)+-- 'bdecompose' = 'bmap' ('fmap' 'runIdentity' . 'getCompose') . 'bdistribute'+-- @+--+-- Lawful instances of the class can then be characterized as those that satisfy:+--+-- @+-- 'brecompose' . 'bdecompose' = 'id'+-- 'bdecompose' . 'brecompose' = 'id'+-- @+--+-- This means intuitively that instances need to have a fixed shape (i.e. no sum-types can be involved).+-- Typically, this means record types, as long as they don't contain fields where the functor argument is not applied.+--+--+-- There is a default implementation of 'bdistribute' based on+-- 'Generic'.  Intuitively, it works on product types where the shape+-- of a pure value is uniquely defined and every field is covered by+-- the argument @f@.+class (FunctorB b) => DistributiveB (b :: (k -> Type) -> Type) where+  bdistribute :: Functor f => f (b g) -> b (Compose f g)++  default bdistribute+    :: forall f g+    .  CanDeriveDistributiveB b f g+    => Functor f => f (b g) -> b (Compose f g)+  bdistribute = gbdistributeDefault+++-- | A version of `bdistribute` with @g@ specialized to `Identity`.+bdistribute' :: (DistributiveB b, Functor f) => f (b Identity) -> b f+bdistribute' = bmap (fmap runIdentity . getCompose) . bdistribute++-- | Dual of `Barbies.Internal.TraversableB.btraverse`+bcotraverse :: (DistributiveB b, Functor f) => (forall a . f (g a) -> f a) -> f (b g) -> b f+bcotraverse h = bmap (h . getCompose) . bdistribute++-- | Decompose a function returning a distributive barbie, into+--   a collection of simpler functions.+bdecompose :: DistributiveB b => (a -> b Identity) -> b ((->) a)+bdecompose = bdistribute'++-- | Recompose a decomposed function.+brecompose :: FunctorB b => b ((->) a) -> a -> b Identity+brecompose bfs = \a -> bmap (Identity . ($ a)) bfs++-- | @'CanDeriveDistributiveB' B f g@ is in practice a predicate about @B@ only.+--   Intuitively, it says the the following holds  for any arbitrary @f@:+--+--     * There is an instance of @'Generic' (B f)@.+--+--     * @(B f)@ has only one constructor, and doesn't contain "naked" fields+--       (that is, not covered by `f`).+--+--     * @B f@ can contain fields of type @b f@ as long as there exists a+--       @'DistributiveB' b@ instance. In particular, recursive usages of @B f@+--       are allowed.+--+--     * @B f@ can also contain usages of @b f@ under a @'Distributive' h@.+--       For example, one could use @a -> (B f)@ as a field of @B f@.+type CanDeriveDistributiveB b f g+  = ( GenericP 0 (b g)+    , GenericP 0 (b (Compose f g))+    , GDistributive 0 f (RepP 0 (b g)) (RepP 0 (b (Compose f g)))+    )++-- | Default implementation of 'bdistribute' based on 'Generic'.+gbdistributeDefault+  :: CanDeriveDistributiveB b f g+  => Functor f => f (b g) -> b (Compose f g)+gbdistributeDefault+  = toP (Proxy @0) . gdistribute (Proxy @0) . fmap (fromP (Proxy @0))+{-# INLINE gbdistributeDefault #-}++-- ------------------------------------------------------------+-- Generic derivation: Special cases for DistributiveB+-- -----------------------------------------------------------++type P = Param++instance+  ( Functor f+  , DistributiveB b+  ) => GDistributive 0 f (Rec (b' (P 0 g)) (b g)) (Rec (b' (P 0 (Compose f g))) (b (Compose f g)))+  where+  gdistribute _ = Rec . K1 . bdistribute . fmap (unK1 . unRec)+  {-# INLINE gdistribute #-}+++instance+  ( Functor f+  , Distributive h+  , DistributiveB b+  ) =>+  GDistributive n f (Rec (h (b (P n g))) (h (b g))) (Rec (h (b (P n (Compose f g)))) (h (b (Compose f g))))+  where+  gdistribute _ = Rec . K1 . fmap bdistribute . distribute . fmap (unK1 . unRec)+  {-# INLINE gdistribute #-}++-- --------------------------------+-- Instances for base types+-- --------------------------------++instance DistributiveB Proxy where+  bdistribute _ = Proxy+  {-# INLINE bdistribute #-}++fstF :: Product f g a -> f a+fstF (Pair x _y) = x++sndF :: Product f g a -> g a+sndF (Pair _x y) = y++instance (DistributiveB a, DistributiveB b) => DistributiveB (Product a b) where+  bdistribute xy = Pair (bdistribute $ fstF <$> xy) (bdistribute $ sndF <$> xy)+  {-# INLINE bdistribute #-}++instance (Distributive h, DistributiveB b) => DistributiveB (h `Compose` b) where+  bdistribute = Compose . fmap bdistribute . distribute . fmap getCompose+  {-# INLINE bdistribute #-}

@@ -0,0 +1,218 @@+{-# LANGUAGE PolyKinds    #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}+module Barbies.Internal.DistributiveT+  ( DistributiveT(..)+  , tdistribute'+  , tcotraverse+  , tdecompose+  , trecompose+  , gtdistributeDefault+  , CanDeriveDistributiveT+  )++where++import Barbies.Generics.Distributive (GDistributive(..))+import Barbies.Internal.FunctorT (FunctorT (..))++import Control.Applicative.Backwards(Backwards (..))++import Control.Monad.Trans.Except(ExceptT(..), runExceptT)+import Control.Monad.Trans.Identity(IdentityT(..))+import Control.Monad.Trans.Maybe(MaybeT(..))+import Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..))+import Control.Monad.Trans.RWS.Strict as Strict (RWST(..))+import Control.Monad.Trans.Reader(ReaderT(..))+import Control.Monad.Trans.State.Lazy as Lazy (StateT(..))+import Control.Monad.Trans.State.Strict as Strict (StateT(..))+import Control.Monad.Trans.Writer.Lazy as Lazy (WriterT(..))+import Control.Monad.Trans.Writer.Strict as Strict (WriterT(..))++import Data.Functor.Compose   (Compose (..))+import Data.Functor.Identity  (Identity (..))+import Data.Functor.Reverse   (Reverse (..))+import Data.Generics.GenericN+import Data.Proxy             (Proxy (..))+import Data.Distributive+import Data.Kind              (Type)++-- | A 'FunctorT' where the effects can be distributed to the fields:+--  `tdistribute` turns an effectful way of building a transformer-type+--  into a pure transformer-type with effectful ways of computing the+--  values of its fields.+--+--  This class is the categorical dual of `Barbies.Internal.TraversableT.TraversableT`,+--  with `tdistribute` the dual of `Barbies.Internal.TraversableT.tsequence`+--  and `tcotraverse` the dual of `Barbies.Internal.TraversableT.ttraverse`. As such,+--  instances need to satisfy these laws:+--+-- @+-- 'tdistribute' . h = 'tmap' ('Compose' . h . 'getCompose') . 'tdistribute'    -- naturality+-- 'tdistribute' . 'Data.Functor.Identity' = 'tmap' ('Compose' . 'Data.Functor.Identity')                 -- identity+-- 'tdistribute' . 'Compose' = 'fmap' ('Compose' . 'Compose' . 'fmap' 'getCompose' . 'getCompose') . 'tdistribute' . 'fmap' 'distribute' -- composition+-- @+--+-- By specializing @f@ to @((->) a)@ and @g@ to 'Identity', we can define a function that+-- decomposes a function on distributive transformers into a collection of simpler functions:+--+-- @+-- 'tdecompose' :: 'DistributiveT' b => (a -> b 'Identity') -> b ((->) a)+-- 'tdecompose' = 'tmap' ('fmap' 'runIdentity' . 'getCompose') . 'tdistribute'+-- @+--+-- Lawful instances of the class can then be characterized as those that satisfy:+--+-- @+-- 'trecompose' . 'tdecompose' = 'id'+-- 'tdecompose' . 'trecompose' = 'id'+-- @+--+-- This means intuitively that instances need to have a fixed shape (i.e. no sum-types can be involved).+-- Typically, this means record types, as long as they don't contain fields where the functor argument is not applied.+--+--+-- There is a default implementation of 'tdistribute' based on+-- 'Generic'.  Intuitively, it works on product types where the shape+-- of a pure value is uniquely defined and every field is covered by+-- the argument @f@.+class FunctorT t => DistributiveT (t :: (Type -> Type) -> i -> Type) where+  tdistribute :: Functor f => f (t g x) -> t (Compose f g) x++  default tdistribute+    :: forall f g x+    .  CanDeriveDistributiveT t f g x+    => f (t g x)+    -> t (Compose f g) x+  tdistribute = gtdistributeDefault++-- | A version of `tdistribute` with @g@ specialized to `Identity`.+tdistribute' :: (DistributiveT t, Functor f) => f (t Identity x) -> t f x+tdistribute' = tmap (fmap runIdentity . getCompose) . tdistribute++-- | Dual of `Barbies.Internal.TraversableT.ttraverse`+tcotraverse :: (DistributiveT t, Functor f) => (forall a . f (g a) -> f a) -> f (t g x) -> t f x+tcotraverse h = tmap (h . getCompose) . tdistribute++-- | Decompose a function returning a distributive transformer, into+--   a collection of simpler functions.+tdecompose :: DistributiveT t => (a -> t Identity x) -> t ((->) a) x+tdecompose = tdistribute'++-- | Recompose a decomposed function.+trecompose :: FunctorT t => t ((->) a) x -> a -> t Identity x+trecompose bfs = \a -> tmap (Identity . ($ a)) bfs++-- | @'CanDeriveDistributiveT' T f g x@ is in practice a predicate about @T@ only.+--   Intuitively, it says the the following holds  for any arbitrary @f@:+--+--     * There is an instance of @'Generic' (B f x)@.+--+--     * @(B f x)@ has only one constructor, and doesn't contain "naked" fields+--       (that is, not covered by `f`). In particular, @x@ needs to occur under @f@.+--+--     * @B f x@ can contain fields of type @b f y@ as long as there exists a+--       @'DistributiveT' b@ instance. In particular, recursive usages of @B f x@+--       are allowed.+--+--     * @B f x@ can also contain usages of @b f y@ under a @'Distributive' h@.+--       For example, one could use @a -> (B f x)@ as a field of @B f x@.+type CanDeriveDistributiveT (t :: (Type -> Type) -> i -> Type) f g x+  = ( GenericP 1 (t g x)+    , GenericP 1 (t (Compose f g) x)+    , GDistributive 1 f (RepP 1 (t g x)) (RepP 1 (t (Compose f g) x))+    )++-- | Default implementation of 'tdistribute' based on 'Generic'.+gtdistributeDefault+  :: CanDeriveDistributiveT t f g x+  => f (t g x)+  -> t (Compose f g) x+gtdistributeDefault = toP (Proxy @1) . gdistribute (Proxy @1) . fmap (fromP (Proxy @1))+{-# INLINE gtdistributeDefault #-}++------------------------------------------------------------+-- Generic derivation: Special cases for FunctorT+-- -----------------------------------------------------------++type P = Param++instance+  ( Functor f+  , DistributiveT t+  ) => GDistributive 1 f (Rec (t (P 1 g) x) (t g x)) (Rec (t (P 1 (Compose f g)) x) (t (Compose f g) x))+  where+  gdistribute _ = Rec . K1 . tdistribute . fmap (unK1 . unRec)+  {-# INLINE gdistribute #-}+++instance+  ( Functor f+  , Distributive h+  , DistributiveT t+  ) =>+  GDistributive 1 f (Rec (h (t (P 1 g) x)) (h (t g x))) (Rec (h (t (P 1 (Compose f g)) x)) (h (t (Compose f g) x)))+  where+  gdistribute _ = Rec . K1 . fmap tdistribute . distribute . fmap (unK1 . unRec)+  {-# INLINE gdistribute #-}++-- --------------------------------+-- Instances for base types+-- --------------------------------++instance Distributive f => DistributiveT (Compose f) where+  tdistribute = Compose . fmap Compose . distribute . fmap getCompose+  {-# INLINE tdistribute #-}++-- -- --------------------------------+-- -- Instances for transformers types+-- -- --------------------------------++instance DistributiveT Backwards where+  tdistribute = Backwards . Compose . fmap forwards+  {-# INLINE tdistribute #-}++instance DistributiveT Reverse where+  tdistribute = Reverse . Compose . fmap getReverse+  {-# INLINE tdistribute #-}++instance DistributiveT (ExceptT e) where+  tdistribute = ExceptT . Compose . fmap runExceptT+  {-# INLINE tdistribute #-}++instance DistributiveT IdentityT where+  tdistribute = IdentityT . Compose . fmap runIdentityT+  {-# INLINE tdistribute #-}++instance DistributiveT MaybeT where+  tdistribute = MaybeT . Compose . fmap runMaybeT+  {-# INLINE tdistribute #-}++instance DistributiveT (Lazy.RWST r w s) where+  tdistribute fh = Lazy.RWST $ \r s -> Compose $ fmap (\h -> Lazy.runRWST h r s) fh+  {-# INLINE tdistribute #-}++instance DistributiveT (Strict.RWST r w s) where+  tdistribute fh = Strict.RWST $ \r s -> Compose $ fmap (\h -> Strict.runRWST h r s) fh+  {-# INLINE tdistribute #-}++instance DistributiveT (ReaderT r) where+  tdistribute fh = ReaderT $ \r -> Compose $ fmap (\h -> runReaderT h r) fh+  {-# INLINE tdistribute #-}++instance DistributiveT (Lazy.StateT s) where+  tdistribute fh = Lazy.StateT $ \s -> Compose $ fmap (\h -> Lazy.runStateT h s) fh+  {-# INLINE tdistribute #-}++instance DistributiveT (Strict.StateT s) where+  tdistribute fh = Strict.StateT $ \s -> Compose $ fmap (\h -> Strict.runStateT h s) fh+  {-# INLINE tdistribute #-}++instance DistributiveT (Lazy.WriterT w) where+  tdistribute = Lazy.WriterT . Compose . fmap Lazy.runWriterT+  {-# INLINE tdistribute #-}++instance DistributiveT (Strict.WriterT w) where+  tdistribute = Strict.WriterT . Compose . fmap Strict.runWriterT+  {-# INLINE tdistribute #-}

@@ -9,6 +9,7 @@ import Barbies.Internal.ApplicativeB(ApplicativeB(..)) import Barbies.Internal.ConstraintsB(ConstraintsB(..)) import Barbies.Internal.FunctorB(FunctorB(..))+import Barbies.Internal.DistributiveB(DistributiveB(..)) import Barbies.Internal.TraversableB(TraversableB(..))  import Data.Data (Data(..))@@ -58,6 +59,7 @@   mappend = (<>)  instance FunctorB Unit+instance DistributiveB Unit instance TraversableB Unit instance ApplicativeB Unit instance ConstraintsB Unit

@@ -16,6 +16,13 @@   , Trav.bsequence   , Trav.bsequence' +    -- * Distributive+  , Distr.DistributiveB(bdistribute)+  , Distr.bdistribute'+  , Distr.bcotraverse+  , Distr.bdecompose+  , Distr.brecompose+     -- * Applicative   , Appl.ApplicativeB(bpure, bprod)     -- ** Utility functions@@ -67,6 +74,7 @@ import qualified Barbies.Internal.ApplicativeB as Appl import qualified Barbies.Internal.ConstraintsB as Cons import qualified Barbies.Internal.FunctorB as Func+import qualified Barbies.Internal.DistributiveB as Distr import qualified Barbies.Internal.TraversableB as Trav  import qualified Data.Generics.GenericN as GenericN

@@ -17,6 +17,13 @@   , Trav.tsequence   , Trav.tsequence' +    -- * Distributive+  , Dist.DistributiveT(tdistribute)+  , Dist.tdistribute'+  , Dist.tcotraverse+  , Dist.tdecompose+  , Dist.trecompose+     -- * Applicative   , Appl.ApplicativeT(tpure, tprod)     -- ** Utility functions@@ -45,6 +52,7 @@  import qualified Barbies.Internal.ApplicativeT as Appl import qualified Barbies.Internal.ConstraintsT as Cons+import qualified Barbies.Internal.DistributiveT as Dist import qualified Barbies.Internal.FunctorT as Func import qualified Barbies.Internal.MonadT as Mon import qualified Barbies.Internal.TraversableT as Trav

@@ -1,4 +1,4 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-} module Clothes  where@@ -16,7 +16,7 @@ data UnitF a = UnitF deriving(Eq, Show, Typeable)  data F a = F [a]-  deriving(Eq, Show, Typeable)+  deriving(Eq, Show, Typeable, Functor)  instance Eq1 F where   liftEq eq (F as) (F bs) = liftEq eq as bs@@ -26,7 +26,7 @@     = showsUnaryWith (liftShowsPrec sp sl) "F" d as  data G a = NoG | G1 a | Gn [a]-  deriving(Eq, Show, Typeable)+  deriving(Eq, Show, Typeable, Functor)  instance Eq1 G where   liftEq _  NoG     NoG     = True@@ -43,7 +43,7 @@     Gn as -> showsUnaryWith (liftShowsPrec sp sl) "Gn" d as  data H a = NoH1 | NoH2 | H1 [a] | H2 [a] | H3 [a]-  deriving(Eq, Show, Typeable)+  deriving(Eq, Show, Typeable, Functor)  instance Show1 H where   liftShowsPrec sp sl d = \case

@@ -6,6 +6,7 @@ import qualified Spec.Functor as Functor import qualified Spec.Applicative as Applicative import qualified Spec.Traversable as Traversable+import qualified Spec.Distributive as Distributive import qualified Spec.Wrapper as Wrapper  import TestBarbies@@ -69,6 +70,29 @@             , Functor.laws @(Flip Bi.NestedF ())             , Functor.laws @(Flip Bi.Nested2F ())             , Functor.laws @(Flip Bi.NestedB Maybe)+            ]++        , testGroup "Distributive Laws"+            [ Distributive.laws @Record0+            , Distributive.laws @Record1++            , Distributive.laws @Record1S+            , Distributive.laws @Record3S++            , Distributive.laws @(Record1W Covered)+            , Distributive.laws @(Record3W Covered)++            , Distributive.laws @CompositeRecord++            , Distributive.laws @(Record1WS Covered)+            , Distributive.laws @(Record3WS Covered)++            , Distributive.laws @(CompositeRecordW Covered)++            , Distributive.laws @(Flip Bi.Record0 ())+            , Distributive.laws @(Flip Bi.Record1 ())+            , Distributive.laws @(Flip Bi.Record1S ())+            , Distributive.laws @(Flip Bi.Record3S ())             ]          , testGroup "Traversable Laws"

@@ -0,0 +1,40 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+module Spec.Distributive ( laws )++where++import Clothes (F, G, H, GH(..), NatTransf(..))++import Data.Functor.Identity (Identity(..))+import Data.Functor.Compose (Compose (..))++import Data.Functor.Barbie (FunctorB(..), DistributiveB(..))++import Data.Typeable (Typeable, typeRep, Proxy(..))++import Test.Tasty(testGroup, TestTree)+import Test.Tasty.QuickCheck(Arbitrary(..), testProperty, (===))++type IsDomain a = (Arbitrary a, Show a)+type IsRange a = (Eq a, Show a)++laws+  :: forall b+  . ( DistributiveB b+    , IsDomain (b F)+    , IsRange (b (Compose H F))+    , IsRange (b (Compose Identity F))+    , IsRange (b (Compose (Compose H G) F))+    , Typeable b+    )+  => TestTree+laws+  = testGroup (show (typeRep (Proxy :: Proxy b)))+      [ testProperty "naturality" $ \(GH (NatTransf h)) (fb :: G (b F)) ->+           bdistribute (h fb) === bmap (Compose . h . getCompose) (bdistribute fb)+      , testProperty "identity" $ \(b :: b F) ->+           bdistribute (Identity b) === bmap (Compose . Identity) b+      , testProperty "composition" $ \(fb :: H (G (b F))) ->+           bdistribute (Compose fb) === bmap (Compose . Compose . fmap getCompose . getCompose) (bdistribute . fmap bdistribute $ fb)+      ]

@@ -31,6 +31,7 @@  import qualified Barbies import Data.Functor.Barbie+import Data.Distributive  import Data.Typeable import GHC.Generics@@ -48,6 +49,7 @@     )  instance FunctorB Record0+instance DistributiveB Record0 instance TraversableB Record0 instance ApplicativeB Record0 instance ConstraintsB Record0@@ -61,6 +63,7 @@   instance FunctorB Record1+instance DistributiveB Record1 instance TraversableB Record1 instance ApplicativeB Record1 instance ConstraintsB Record1@@ -78,6 +81,7 @@   instance FunctorB Record1S+instance DistributiveB Record1S instance TraversableB Record1S instance ApplicativeB Record1S instance ConstraintsB Record1S@@ -121,6 +125,7 @@   instance FunctorB Record3S+instance DistributiveB Record3S instance TraversableB Record3S instance ApplicativeB Record3S instance ConstraintsB Record3S@@ -179,12 +184,12 @@   = CompositeRecord       { crec_f1 :: f Int       , crec_F2 :: f Bool-      , crec_f3 :: Record3 f       , crec_f4 :: Record1 f       }   deriving (Generic, Typeable)  instance FunctorB CompositeRecord+instance DistributiveB CompositeRecord instance TraversableB CompositeRecord instance ApplicativeB CompositeRecord instance ConstraintsB CompositeRecord@@ -194,7 +199,7 @@  instance AllBF Arbitrary f CompositeRecord => Arbitrary (CompositeRecord f) where   arbitrary-    = CompositeRecord <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+    = CompositeRecord <$> arbitrary <*> arbitrary <*> arbitrary  data SumRec f   = SumRec_0@@ -222,6 +227,7 @@   deriving (Generic, Typeable)  instance FunctorB InfRec+instance DistributiveB InfRec instance TraversableB InfRec instance ApplicativeB InfRec instance ConstraintsB InfRec@@ -281,6 +287,7 @@   deriving (Generic, Typeable)  instance FunctorB b => FunctorB (ParB b)+instance DistributiveB b => DistributiveB (ParB b) instance TraversableB b => TraversableB (ParB b) instance ApplicativeB b => ApplicativeB (ParB b) instance ConstraintsB b => ConstraintsB (ParB b)@@ -290,6 +297,7 @@   deriving (Generic, Typeable)  instance (Functor h, FunctorB b) => FunctorB (ParBH h b)+instance (Distributive h, DistributiveB b) => DistributiveB (ParBH h b) instance (Traversable h, TraversableB b) => TraversableB (ParBH h b) instance (Applicative h, ApplicativeB b) => ApplicativeB (ParBH h b) 

@@ -40,6 +40,7 @@  instance FunctorB (Record1W Bare) instance FunctorB (Record1W Covered)+instance DistributiveB (Record1W Covered) instance TraversableB (Record1W Covered) instance ApplicativeB (Record1W Covered) instance ConstraintsB (Record1W Bare)@@ -63,6 +64,7 @@  instance FunctorB (Record1WS Bare) instance FunctorB (Record1WS Covered)+instance DistributiveB (Record1WS Covered) instance TraversableB (Record1WS Covered) instance ApplicativeB (Record1WS Covered) instance ConstraintsB (Record1WS Bare)@@ -89,6 +91,7 @@  instance FunctorB (Record3W Bare) instance FunctorB (Record3W Covered)+instance DistributiveB (Record3W Covered) instance TraversableB (Record3W Bare) instance TraversableB (Record3W Covered) instance ApplicativeB (Record3W Covered)@@ -117,6 +120,7 @@  instance FunctorB (Record3WS Bare) instance FunctorB (Record3WS Covered)+instance DistributiveB (Record3WS Covered) instance TraversableB (Record3WS Covered) instance ApplicativeB (Record3WS Covered) instance ConstraintsB (Record3WS Bare)@@ -179,6 +183,7 @@  instance FunctorB (CompositeRecordW Bare) instance FunctorB (CompositeRecordW Covered)+instance DistributiveB (CompositeRecordW Covered) instance TraversableB (CompositeRecordW Covered) instance ApplicativeB (CompositeRecordW Covered) instance ConstraintsB (CompositeRecordW Bare)@@ -228,6 +233,7 @@  instance FunctorB (InfRecW Bare) instance FunctorB (InfRecW Covered)+instance DistributiveB (InfRecW Covered) instance TraversableB (InfRecW Covered) instance ApplicativeB (InfRecW Covered) instance ConstraintsB (InfRecW Bare)@@ -333,6 +339,7 @@  instance FunctorB (ParXW a Bare) instance FunctorB (ParXW a Covered)+instance DistributiveB (ParXW a Covered) instance TraversableB (ParXW a Covered) instance ApplicativeB (ParXW a Covered) instance ConstraintsB (ParXW a Covered)

@@ -33,6 +33,7 @@ where  import Barbies+import Data.Distributive import qualified TestBarbies  import Data.Typeable@@ -54,6 +55,7 @@     )  instance FunctorT Record0+instance DistributiveT Record0 instance ApplicativeT Record0 instance TraversableT Record0 instance ConstraintsT Record0@@ -67,6 +69,7 @@   instance FunctorT Record1+instance DistributiveT Record1 instance ApplicativeT Record1 instance TraversableT Record1 instance ConstraintsT Record1@@ -84,6 +87,7 @@   instance FunctorT Record1S+instance DistributiveT Record1S instance ApplicativeT Record1S instance TraversableT Record1S instance ConstraintsT Record1S@@ -126,6 +130,7 @@   instance FunctorT Record3S+instance DistributiveT Record3S instance ApplicativeT Record3S instance TraversableT Record3S instance ConstraintsT Record3S@@ -287,6 +292,7 @@   deriving (Generic, Typeable)  instance FunctorT b => FunctorT (ParB b)+instance DistributiveT b => DistributiveT (ParB b) instance ApplicativeT b => ApplicativeT (ParB b) instance TraversableT b => TraversableT (ParB b) instance ConstraintsT b => ConstraintsT (ParB b)@@ -296,6 +302,7 @@   deriving (Generic, Typeable)  instance (Functor h, FunctorT b) => FunctorT (ParBH h b)+instance (Distributive h, DistributiveT b) => DistributiveT (ParBH h b) instance (Applicative h, ApplicativeT b) => ApplicativeT (ParBH h b) instance (Traversable h, TraversableT b) => TraversableT (ParBH h b) @@ -337,28 +344,29 @@ -- Actual bi-barbies ----------------------------------------------------- -type Record3' = TestBarbies.Record3+type Record1' = TestBarbies.Record1  data NestedB f g   = NestedB       { nb_1 :: g Int       , nb_2 :: f (g Bool)-      , nb_3 :: f (Record3' g)-      , nb_4 :: Record3' g+      , nb_3 :: f (Record1' g)+      , nb_4 :: Record1' g       }   deriving (Generic, Typeable)  instance FunctorT NestedB instance TraversableT NestedB instance Functor f => FunctorB (NestedB f)+instance Distributive f => DistributiveB (NestedB f) instance Applicative f => ApplicativeB (NestedB f) instance Traversable f => TraversableB (NestedB f)  -deriving instance (Show (f (g Bool)), AllBF Show g Record3', Show (f (Record3' g))) => Show (NestedB f g)-deriving instance (Eq (f (g Bool)), AllBF Eq g Record3', Eq (f (Record3' g))) => Eq (NestedB f g)+deriving instance (Show (f (g Bool)), AllBF Show g Record1', Show (f (Record1' g))) => Show (NestedB f g)+deriving instance (Eq (f (g Bool)), AllBF Eq g Record1', Eq (f (Record1' g))) => Eq (NestedB f g)  -instance (Arbitrary (f (g Bool)), AllBF Arbitrary g Record3', Arbitrary (f (Record3' g))) => Arbitrary (NestedB f g) where+instance (Arbitrary (f (g Bool)), AllBF Arbitrary g Record1', Arbitrary (f (Record1' g))) => Arbitrary (NestedB f g) where   arbitrary     = NestedB <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary