From 83f4d4195eb6768551c3eeef99d9f07f4c78d41c Mon Sep 17 00:00:00 2001 From: Daniel Gorin Date: Sun, 29 Sep 2019 13:08:03 +0000 Subject: [PATCH] Replace ProductB with ApplicativeB In terms of operations, they are isomorphic, but the applicative laws are more lax, so we can define more lawful instances. We also remove `ProductBC`, since `bdicts` can just be expressed in terms of `baddDict` and `bpure`. --- ChangeLog.md | 5 +- barbies.cabal | 9 +- src/Barbies.hs | 107 ++++++--- src/Barbies/Internal.hs | 16 +- src/Barbies/Internal/Applicative.hs | 227 ++++++++++++++++++ src/Barbies/Internal/Constraints.hs | 30 +++ src/Barbies/Internal/Containers.hs | 8 +- src/Barbies/Internal/Trivial.hs | 6 +- src/Barbies/Internal/Wrappers.hs | 9 +- src/Data/Barbie.hs | 19 +- src/Data/Barbie/Constraints.hs | 2 +- .../Barbie}/Internal/Product.hs | 103 ++------ .../Barbie}/Internal/ProductC.hs | 58 ++--- src/Data/Functor/Barbie.hs | 43 ++-- test/Spec.hs | 54 ++--- test/Spec/{Product.hs => Applicative.hs} | 18 +- test/Spec/Constraints.hs | 4 +- test/Spec/Wrapper.hs | 6 +- test/TestBarbies.hs | 30 +-- test/TestBarbiesW.hs | 26 +- 20 files changed, 487 insertions(+), 293 deletions(-) create mode 100644 src/Barbies/Internal/Applicative.hs rename src/{Barbies => Data/Barbie}/Internal/Product.hs (59%) rename src/{Barbies => Data/Barbie}/Internal/ProductC.hs (65%) rename test/Spec/{Product.hs => Applicative.hs} (67%) diff --git a/ChangeLog.md b/ChangeLog.md index bd59a87..7c47abd 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,6 @@ # Changelog for barbies -## ... +## 2.0.0.0 - Builds with ghc 8.8. - Remove functions deprecated on release 1.0 - Deprecate `Data.Functor.Prod`, `(/*)` and `(/*/)`. @@ -10,6 +10,9 @@ - Create a `Barbies` module, to contain wrappers, basic docs, etc. `Data.Functor.Barbie` contains only functor-related stuff. - Add a `ErrorContainer` wrapper, similar to `Container` but for `Either e`. + - Replace `ProductB` by `ApplicativeB`, with more lax laws + - Remove `ProductBC`, since `bdicts` can now be defined in terms of `ApplicativeB` + and `ConstraintsB`. ## 1.1.3.0 - `Wear` will raise a `TypeError` instead of getting diff --git a/barbies.cabal b/barbies.cabal index 0b01bbb..1a81945 100644 --- a/barbies.cabal +++ b/barbies.cabal @@ -38,13 +38,12 @@ library Data.Functor.Prod other-modules: + Barbies.Internal.Applicative Barbies.Internal.Bare Barbies.Internal.Constraints Barbies.Internal.Containers Barbies.Internal.Dicts Barbies.Internal.Functor - Barbies.Internal.Product - Barbies.Internal.ProductC Barbies.Internal.Traversable Barbies.Internal.Trivial Barbies.Internal.Wear @@ -52,6 +51,10 @@ library Data.Generics.GenericN + -- To be removed + Data.Barbie.Internal.Product + Data.Barbie.Internal.ProductC + hs-source-dirs: src @@ -90,11 +93,11 @@ test-suite barbies-test TestBarbies TestBarbiesW Clothes + Spec.Applicative Spec.Bare Spec.Constraints Spec.Functor Spec.Traversable - Spec.Product Spec.Wrapper hs-source-dirs: diff --git a/src/Barbies.hs b/src/Barbies.hs index 5f9cf7c..d246b46 100644 --- a/src/Barbies.hs +++ b/src/Barbies.hs @@ -7,63 +7,106 @@ -- that turn her into a different doll. E.g. -- -- @ --- data Barbie f --- = Barbie +-- data Person f +-- = Person -- { name :: f 'String' -- , age :: f 'Int' -- } -- --- b1 :: Barbie 'Data.Monoid.Last' -- Barbie with a monoid structure --- b2 :: Barbie ('Data.Functor.Const.Const' a) -- 'Barbies.Container' Barbie --- b3 :: Barbie 'Data.Functor.Identity.Identity' -- Barbie's new clothes +-- b1 :: Person 'Data.Monoid.Last' -- Barbie with a monoid structure +-- b2 :: Person ('Data.Functor.Const.Const' a) -- 'Barbies.Container' Barbie +-- b3 :: Person 'Data.Functor.Identity.Identity' -- Barbie's new clothes -- @ -- --- This module define the classes to work with these types and easily +-- This package define the classes to work with these types and easily -- transform them. They all come with default instances based on -- `GHC.Generics.Generic`, so using them is as easy as: -- -- @ --- data Barbie f --- = Barbie +-- data Person f +-- = Person -- { name :: f 'String' -- , age :: f 'Int' -- } -- deriving -- ( 'GHC.Generics.Generic' --- , 'FunctorB', 'TraversableB', 'ProductB', 'ConstraintsB', 'ProductBC' +-- , 'FunctorB', 'TraversableB', 'ApplicativeB', 'ConstraintsB' -- ) -- --- deriving instance 'AllBF' 'Show' f Barbie => 'Show' (Barbie f) --- deriving instance 'AllBF' 'Eq' f Barbie => 'Eq' (Barbie f) +-- deriving instance 'AllBF' 'Show' f Person => 'Show' (Person f) +-- deriving instance 'AllBF' 'Eq' f Person => 'Eq' (Person f) -- @ -- --- Sometimes one wants to use @Barbie 'Data.Functor.Identity.Identity'@ --- and it may feel like a second-class record type, where one needs to --- unpack values in each field. "Barbies.Bare" offers a way to have --- bare versions of a barbie-type. --- --- Notice that all classes in this package are poly-kinded. Intuitively, --- a barbie is a type parameterised by a functor, and because a barbies is --- a type of functor, a type parameterised by a barbie is a (higher-kinded) --- barbie too: --- --- @ --- data Catalog b --- = Catalog (b 'Identity') (b 'Maybe') --- deriving --- ('GHC.Generics.Generic' --- , 'FunctorB', 'TraversableB', 'ProductB', 'ConstraintsB', 'ProductBC' --- ) --- @ + ----------------------------------------------------------------------------- module Barbies - ( -- * Functor interfaces + ( -- * Functor interface + + -- | Barbie-types are functors. That means that if one is familiar + -- with standard classes like 'Functor', 'Applicative' or 'Traversable', + -- one already knows how to work with barbie-types too. For instance, just + -- like one would use: + -- + -- @ + -- 'fmap' f (xs :: [a])@ + -- @ + -- + -- to apply @f@ uniformly on every @a@ occurring + -- in @xs@, one could use the following to turn a 'Either'-outfit + -- into 'Maybe'-outfit: + -- + -- @ + -- 'bmap' ('either' (\\_ -> 'Nothing') 'Just') (p :: Person ('Either' e))@ + -- @ + -- + -- In this case, the argument of 'bmap' will have to be applied on all + -- fields of @p@: + -- + -- @ + -- name p :: 'Either' e 'String' + -- age p :: 'Either' e 'Int' + -- @ + -- + -- So 'bmap' here demands a polymorphic function of type: + -- + -- @ + -- forall a . 'Either' e a -> 'Maybe' a@ + -- @ + -- + -- Polymorphic functions with 'Applicative' effects can be applied + -- using 'btraverse' and the effects will be accumulated. Finally, + -- 'bzipWith' gives us an analogous of 'Control.Applicative.liftA2': + -- + -- @ + -- addDefaults :: Person 'Maybe' -> Person 'Data.Functor.Identity' -> Person 'Data.Functor.Identity' + -- addDefaults = 'bzipWith' (\\m d -> 'maybe' d 'pure' m) + -- @ + -- + -- Notice that here 'bzipWith' has lifted a function of type: + -- + -- @ + -- forall a. 'Maybe' a -> 'Data.Functor.Identity' a -> 'Data.Functor.Identity' a + -- @ + -- + -- The 'Functor' class captures endo-functors on 'Data.Kind.Type'. 'FunctorB' is + -- for functors from indexed-types to 'Data.Kind.Type'. In particular, barbie-types + -- are indexed-types too, so a type parameterized by a barbie is a + -- (higher-kinded) barbie as well. + -- + -- @ + -- data Catalog b + -- = Catalog (b 'Data.Functor.Identity') (b 'Maybe') + -- deriving + -- ('GHC.Generics.Generic' + -- , 'FunctorB', 'TraversableB', 'ApplicativeB', 'ConstraintsB' + -- ) + -- @ module Data.Functor.Barbie -- * Container-barbies - -- | Wrappers for Barbies that look like containers, providing the - -- expected instances for container types. + -- | Some clothes make barbies look like containers, and we can make those + -- behave like normal 'Functor's. , Containers.Container(..) , Containers.ErrorContainer(..) diff --git a/src/Barbies/Internal.hs b/src/Barbies/Internal.hs index 218a28e..26753ea 100644 --- a/src/Barbies/Internal.hs +++ b/src/Barbies/Internal.hs @@ -9,11 +9,11 @@ module Barbies.Internal , Internal.GTraversableB(..) , Internal.CanDeriveTraversableB - -- * Product - , Internal.gbuniqDefault + -- * Applicative + , Internal.gbpureDefault , Internal.gbprodDefault - , Internal.GProductB(..) - , Internal.CanDeriveProductB + , Internal.GApplicativeB(..) + , Internal.CanDeriveApplicativeB -- * Constraints , Internal.gbaddDictsDefault @@ -24,11 +24,6 @@ module Barbies.Internal , Internal.X , Internal.TagSelf, Internal.Self, Internal.Other - -- * Proof - , Internal.gbdictsDefault - , Internal.GProductBC(..) - , Internal.CanDeriveProductBC - -- * Bare values , Internal.gbcoverDefault , Internal.gbstripDefault @@ -41,11 +36,10 @@ module Barbies.Internal where +import qualified Barbies.Internal.Applicative as Internal import qualified Barbies.Internal.Bare as Internal import qualified Barbies.Internal.Constraints as Internal import qualified Barbies.Internal.Functor as Internal -import qualified Barbies.Internal.Product as Internal -import qualified Barbies.Internal.ProductC as Internal import qualified Barbies.Internal.Traversable as Internal import Data.Generics.GenericN (GenericN, Rec(..), RepN) diff --git a/src/Barbies/Internal/Applicative.hs b/src/Barbies/Internal/Applicative.hs new file mode 100644 index 0000000..b2cd1c5 --- /dev/null +++ b/src/Barbies/Internal/Applicative.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module Barbies.Internal.Applicative + ( ApplicativeB(bpure, bprod) + , bzip, bunzip, bzipWith, bzipWith3, bzipWith4 + + , CanDeriveApplicativeB + , GApplicativeB(..) + , gbprodDefault, gbpureDefault + ) + +where + +import Barbies.Internal.Functor (FunctorB (..)) + +import Data.Functor.Product (Product (..)) +import Data.Kind (Type) +import Data.Proxy (Proxy (..)) + +import Data.Generics.GenericN + + +-- | A 'FunctorB' with application, providing operations to: +-- * embed an "empty" value ('bpure') +-- * align and combine values ('bprod') +-- +-- It should satisfy the following laws: +-- +-- [Naturality of 'bprod'] +-- +-- @ +-- 'bmap' (\('Pair' a b) -> 'Pair' (f a) (g b)) (u `'bprod'` v) = 'bmap' f u `'bprod'` 'bmap' g v +-- @ +-- +-- [Left and right identity] +-- +-- @ +-- 'bmap' (\('Pair' _ b) -> b) ('bpure' e ``bprod'` v) = v +-- 'bmap' (\('Pair' a _) -> a) (u ``bprod' `'bpure' e) = u +-- @ +-- +-- [Associativity] +-- +-- @ +-- 'bmap' (\('Pair' a ('Pair' b c)) -> 'Pair' ('Pair' a b) c) (u `'bprod'` (v `'bprod'` w)) = (u `'bprod'` v) `'bprod'` w +-- @ +-- +-- It is to 'FunctorB' in is that 'Applicative' +-- relates to 'Functor'. For a presentation of 'Applicative' as +-- a monoidal functor, see Section 7 of +-- . +-- +-- There is a default implementation of 'bprod' and 'bpure' based on 'Generic'. +-- Intuitively, it works on types where the value of `bpure` is uniquely defined. +-- This corresponds rougly to record types (in the presence of sums, there would +-- be several candidates for `bpure`), where the argument @f@ covers every field. +class FunctorB b => ApplicativeB (b :: (k -> Type) -> Type) where + bpure :: (forall a . f a) -> b f + bprod :: b f -> b g -> b (f `Product` g) + + default bpure :: CanDeriveApplicativeB b f f => (forall a . f a) -> b f + bpure = gbpureDefault + + default bprod :: CanDeriveApplicativeB b f g => b f -> b g -> b (f `Product` g) + bprod = gbprodDefault + + +-- | An alias of 'bprod', since this is like a 'zip' for Barbie-types. +bzip :: ApplicativeB b => b f -> b g -> b (f `Product` g) +bzip = bprod + +-- | An equivalent of 'unzip' for Barbie-types. +bunzip :: ApplicativeB b => b (f `Product` g) -> (b f, b g) +bunzip bfg = (bmap (\(Pair a _) -> a) bfg, bmap (\(Pair _ b) -> b) bfg) + +-- | An equivalent of 'Data.List.zipWith' for Barbie-types. +bzipWith :: ApplicativeB b => (forall a. f a -> g a -> h a) -> b f -> b g -> b h +bzipWith f bf bg + = bmap (\(Pair fa ga) -> f fa ga) (bf `bprod` bg) + +-- | An equivalent of 'Data.List.zipWith3' for Barbie-types. +bzipWith3 + :: ApplicativeB b + => (forall a. f a -> g a -> h a -> i a) + -> b f -> b g -> b h -> b i +bzipWith3 f bf bg bh + = bmap (\(Pair (Pair fa ga) ha) -> f fa ga ha) + (bf `bprod` bg `bprod` bh) + + +-- | An equivalent of 'Data.List.zipWith4' for Barbie-types. +bzipWith4 + :: ApplicativeB b + => (forall a. f a -> g a -> h a -> i a -> j a) + -> b f -> b g -> b h -> b i -> b j +bzipWith4 f bf bg bh bi + = bmap (\(Pair (Pair (Pair fa ga) ha) ia) -> f fa ga ha ia) + (bf `bprod` bg `bprod` bh `bprod` bi) + + +-- | @'CanDeriveApplicativeB' B f g@ is in practice a predicate about @B@ only. +-- Intuitively, it says that the following holds, for any arbitrary @f@: +-- +-- * There is an instance of @'Generic' (B f)@. +-- +-- * @B@ has only one constructor (that is, it is not a sum-type). +-- +-- * Every field of @B f@ is of the form @f a@, for some type @a@. +-- In other words, @B@ has no "hidden" structure. +type CanDeriveApplicativeB b f g + = ( GenericN (b f) + , GenericN (b g) + , GenericN (b (f `Product` g)) + , GApplicativeB f g (RepN (b f)) (RepN (b g)) (RepN (b (f `Product` g))) + ) + + +-- ====================================== +-- Generic derivation of instances +-- ====================================== + +-- | Default implementation of 'bprod' based on 'Generic'. +gbprodDefault + :: forall b f g + . CanDeriveApplicativeB 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 #-} + +gbpureDefault:: forall b f . CanDeriveApplicativeB b f f => (forall a . f a) -> b f +gbpureDefault x + = toN $ gbpure (Proxy @f) (Proxy @(RepN (b f))) (Proxy @(RepN (b (f `Product` f)))) x +{-# INLINE gbpureDefault #-} + +class GApplicativeB (f :: k -> *) (g :: k -> *) repbf repbg repbfg where + gbprod :: Proxy f -> Proxy g -> repbf x -> repbg x -> repbfg x + + gbpure :: (f ~ g, repbf ~ repbg) => Proxy f -> Proxy repbf -> Proxy repbfg -> (forall a . f a) -> repbf x + +-- ---------------------------------- +-- Trivial cases +-- ---------------------------------- + +instance GApplicativeB f g repf repg repfg => GApplicativeB 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 #-} + + gbpure pf _ _ x = M1 (gbpure pf (Proxy @repf) (Proxy @repfg) x) + {-# INLINE gbpure #-} + + +instance GApplicativeB f g U1 U1 U1 where + gbprod _ _ U1 U1 = U1 + {-# INLINE gbprod #-} + + gbpure _ _ _ _ = U1 + {-# INLINE gbpure #-} + +instance + ( GApplicativeB f g lf lg lfg + , GApplicativeB f g rf rg rfg + ) => GApplicativeB 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 #-} + + gbpure pf _ _ x = (gbpure pf (Proxy @lf) (Proxy @lfg) x :*: gbpure pf (Proxy @rf) (Proxy @rfg) x) + {-# INLINE gbpure #-} + +-- -------------------------------- +-- The interesting cases +-- -------------------------------- + +type P0 = Param 0 + +instance GApplicativeB f g (Rec (P0 f a) (f a)) + (Rec (P0 g a) (g a)) + (Rec (P0 (f `Product` g) a) ((f `Product` g) a)) where + gbprod _ _ (Rec (K1 fa)) (Rec (K1 ga)) + = Rec (K1 (Pair fa ga)) + {-# INLINE gbprod #-} + + gbpure _ _ _ x = Rec (K1 x) + {-# INLINE gbpure #-} + + +instance + ( SameOrParam b b' + , ApplicativeB b' + ) => GApplicativeB 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 #-} + + gbpure _ _ _ x = Rec (K1 (bpure x)) + {-# INLINE gbpure #-} + + +-- -------------------------------- +-- Instances for base types +-- -------------------------------- + +instance ApplicativeB Proxy where + bprod _ _ = Proxy + {-# INLINE bprod #-} + + bpure _ = Proxy + {-# INLINE bpure #-} + +instance (ApplicativeB a, ApplicativeB b) => ApplicativeB (Product a b) where + bprod (Pair ll lr) (Pair rl rr) = Pair (bprod ll rl) (bprod lr rr) + {-# INLINE bprod #-} + + bpure x = Pair (bpure x) (bpure x) + {-# INLINE bpure #-} diff --git a/src/Barbies/Internal/Constraints.hs b/src/Barbies/Internal/Constraints.hs index 0e2fe9e..3b9fd3a 100644 --- a/src/Barbies/Internal/Constraints.hs +++ b/src/Barbies/Internal/Constraints.hs @@ -7,6 +7,10 @@ module Barbies.Internal.Constraints , bmapC , btraverseC , AllBF + , bdicts + , bpureC + , bmempty + , CanDeriveConstraintsB , GAllBC(..) @@ -18,6 +22,7 @@ module Barbies.Internal.Constraints where +import Barbies.Internal.Applicative(ApplicativeB(..)) import Barbies.Internal.Dicts(ClassF, Dict (..), requiringDict) import Barbies.Internal.Functor(FunctorB (..)) import Barbies.Internal.Traversable(TraversableB (..)) @@ -126,6 +131,31 @@ btraverseC f b = btraverse (\(Pair (Dict :: Dict c a) x) -> f x) (baddDicts b) type AllBF c f b = AllB (ClassF c f) b +-- | Similar to 'baddDicts' but can produce the instance dictionaries +-- "out of the blue". +bdicts :: forall c b . (ConstraintsB b, ApplicativeB b, AllB c b) => b (Dict c) +bdicts = bmap (\(Pair c _) -> c) $ baddDicts $ bpure Proxy + + +-- | Like 'bpure' but a constraint is allowed to be required on +-- each element of @b@. +bpureC + :: forall c f b . + ( AllB c b + , ConstraintsB b + , ApplicativeB b + ) + => (forall a . c a => f a) + -> b f +bpureC x + = bmap (requiringDict @c x) bdicts + +-- | Builds a @b f@, by applying 'mempty' on every field of @b@. +bmempty :: forall f b . (AllBF Monoid f b, ConstraintsB b, ApplicativeB b) => b f +bmempty + = bpureC @(ClassF Monoid f) mempty + + -- | The representation used for the generic computation of the @'AllB' c b@ -- constraints. Here 'X' is an arbitrary constant since the actual -- argument to @b@ is irrelevant. diff --git a/src/Barbies/Internal/Containers.hs b/src/Barbies/Internal/Containers.hs index a739dd4..e6af38b 100644 --- a/src/Barbies/Internal/Containers.hs +++ b/src/Barbies/Internal/Containers.hs @@ -16,7 +16,7 @@ import GHC.Generics (Generic) -- {{ Container --------------------------------------------------------------- --- | Wrapper for Barbies that act as containers of @a@ +-- | Wrapper for barbies that act as containers of @a@ -- by wearing @('Const' a)@. newtype Container b a = Container { getContainer :: b (Const a) } @@ -40,9 +40,9 @@ instance TraversableB b => Traversable (Container b) where traverse f = fmap Container . btraverse (bitraverse f pure) . getContainer -instance ProductB b => Applicative (Container b) where +instance ApplicativeB b => Applicative (Container b) where pure a - = Container $ buniq (Const a) + = Container $ bpure (Const a) l <*> r = Container $ bzipWith appConst (getContainer l) (getContainer r) @@ -56,7 +56,7 @@ instance ProductB b => Applicative (Container b) where -- {{ ErrorContainer ---------------------------------------------------------- --- | Wrapper for Barbies that act as containers of @e@ +-- | Wrapper for barbies that act as containers of @e@ -- by wearing @'Either' e@. newtype ErrorContainer b e = ErrorContainer { getErrorContainer :: b (Either e) } diff --git a/src/Barbies/Internal/Trivial.hs b/src/Barbies/Internal/Trivial.hs index 8625967..d62f6f5 100644 --- a/src/Barbies/Internal/Trivial.hs +++ b/src/Barbies/Internal/Trivial.hs @@ -6,10 +6,9 @@ module Barbies.Internal.Trivial where +import Barbies.Internal.Applicative(ApplicativeB(..)) import Barbies.Internal.Constraints(ConstraintsB(..)) import Barbies.Internal.Functor(FunctorB(..)) -import Barbies.Internal.Product(ProductB(..)) -import Barbies.Internal.ProductC(ProductBC(..)) import Barbies.Internal.Traversable(TraversableB(..)) import Data.Data (Data(..)) @@ -63,6 +62,5 @@ instance Monoid (Unit f) where instance FunctorB Unit instance TraversableB Unit -instance ProductB Unit +instance ApplicativeB Unit instance ConstraintsB Unit -instance ProductBC Unit diff --git a/src/Barbies/Internal/Wrappers.hs b/src/Barbies/Internal/Wrappers.hs index 096c1ed..f23e861 100644 --- a/src/Barbies/Internal/Wrappers.hs +++ b/src/Barbies/Internal/Wrappers.hs @@ -6,12 +6,11 @@ module Barbies.Internal.Wrappers ( Barbie(..) ) where +import Barbies.Internal.Applicative import Barbies.Internal.Constraints import Barbies.Internal.Dicts import Barbies.Internal.Functor import Barbies.Internal.Traversable -import Barbies.Internal.Product -import Barbies.Internal.ProductC import Data.Kind (Type) import Data.Semigroup (Semigroup, (<>)) @@ -21,7 +20,7 @@ import Prelude hiding (Semigroup, (<>)) -- ghc < 8.2 -- | A wrapper for Barbie-types, providing useful instances. newtype Barbie (b :: (k -> Type) -> Type) f = Barbie { getBarbie :: b f } - deriving (FunctorB, ProductB, ProductBC) + deriving (FunctorB, ApplicativeB) -- Need to derive it manually to make GHC 8.0.2 happy instance ConstraintsB b => ConstraintsB (Barbie b) where @@ -32,12 +31,12 @@ instance TraversableB b => TraversableB (Barbie b) where btraverse f = fmap Barbie . btraverse f . getBarbie -instance (ProductBC b, AllBF Semigroup f b) => Semigroup (Barbie b f) where +instance (ConstraintsB b, ApplicativeB b, AllBF Semigroup f b) => Semigroup (Barbie b f) where (<>) = bzipWith3 mk bdicts where mk :: Dict (ClassF Semigroup f) a -> f a -> f a -> f a mk = requiringDict (<>) -instance (ProductBC b, AllBF Semigroup f b, AllBF Monoid f b) => Monoid (Barbie b f) where +instance (ConstraintsB b, ApplicativeB b, AllBF Semigroup f b, AllBF Monoid f b) => Monoid (Barbie b f) where mempty = bmempty mappend = (<>) diff --git a/src/Data/Barbie.hs b/src/Data/Barbie.hs index 5fea330..7d653e1 100644 --- a/src/Data/Barbie.hs +++ b/src/Data/Barbie.hs @@ -14,8 +14,13 @@ module Data.Barbie -- * Product , ProductB(buniq, bprod) + -- ** Utility functions - , bzip, bunzip, bzipWith, bzipWith3, bzipWith4 + , App.bzip + , App.bunzip + , App.bzipWith + , App.bzipWith3 + , App.bzipWith4 -- * Constraints and instance dictionaries , ConstraintsB(AllB, baddDicts) @@ -46,15 +51,15 @@ module Data.Barbie where -import Barbies.Internal.Constraints (AllBF, ConstraintsB (..), bmapC, btraverseC) +import Barbies.Internal.Constraints (AllBF, ConstraintsB (..), bmapC, btraverseC, bmempty) import Barbies.Internal.Functor(FunctorB(..)) import Barbies.Internal.Wrappers(Barbie(..)) -import Barbies.Internal.Product - ( ProductB(..) - , bzip, bunzip, bzipWith, bzipWith3, bzipWith4 - ) -import Barbies.Internal.ProductC(ProductBC(..), buniqC, bmempty) +import qualified Barbies.Internal.Applicative as App + +import Data.Barbie.Internal.Product(ProductB(..)) +import Data.Barbie.Internal.ProductC(ProductBC(..), buniqC) + import Barbies.Internal.Traversable ( TraversableB(..) , bsequence, bsequence' diff --git a/src/Data/Barbie/Constraints.hs b/src/Data/Barbie/Constraints.hs index 66b3fb5..6fb03cb 100644 --- a/src/Data/Barbie/Constraints.hs +++ b/src/Data/Barbie/Constraints.hs @@ -19,4 +19,4 @@ where import Barbies.Internal.Constraints import Barbies.Internal.Dicts -import Barbies.Internal.ProductC +import Data.Barbie.Internal.ProductC diff --git a/src/Barbies/Internal/Product.hs b/src/Data/Barbie/Internal/Product.hs similarity index 59% rename from src/Barbies/Internal/Product.hs rename to src/Data/Barbie/Internal/Product.hs index 7260855..6885dce 100644 --- a/src/Barbies/Internal/Product.hs +++ b/src/Data/Barbie/Internal/Product.hs @@ -2,18 +2,19 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -module Barbies.Internal.Product +{-# OPTIONS_GHC -Wno-orphans -Wno-deprecations #-} +module Data.Barbie.Internal.Product ( ProductB(buniq, bprod) - , bzip, bunzip, bzipWith, bzipWith3, bzipWith4 - , CanDeriveProductB - , GProductB(..) , gbprodDefault, gbuniqDefault ) where -import Barbies.Internal.Functor (FunctorB (..)) +import Barbies.Internal.Functor (FunctorB) +import Barbies.Internal.Trivial (Unit) +import Barbies.Internal.Wrappers (Barbie(..)) +import qualified Barbies.Internal.Applicative as App import Data.Functor.Product (Product (..)) import Data.Kind (Type) @@ -22,45 +23,9 @@ import Data.Proxy (Proxy (..)) import Data.Generics.GenericN --- | Barbie-types that can form products, subject to the laws: --- --- @ --- 'bmap' (\\('Pair' a _) -> a) . 'uncurry' 'bprod' = 'fst' --- 'bmap' (\\('Pair' _ b) -> b) . 'uncurry' 'bprod' = 'snd' --- @ --- --- Notice that because of the laws, having an internal product structure is not --- enough to have a lawful instance. E.g. --- --- @ --- data Ok f = Ok {o1 :: f 'String', o2 :: f 'Int'} --- data Bad f = Bad{b1 :: f 'String', hiddenFromArg: 'Int'} -- no lawful instance --- @ --- --- Intuitively, the laws for this class require that `b` hides no structure --- from its argument @f@. Because of this, if we are given any: --- --- @ --- x :: forall a . f a --- @ --- --- then this determines a unique value of type @b f@, witnessed by the 'buniq' --- method. --- For example: --- --- @ --- 'buniq' x = Ok {o1 = x, o2 = x} --- @ --- --- Formally, 'buniq' should satisfy: --- --- @ --- 'const' ('buniq' x) = 'bmap' ('const' x) --- @ --- --- There is a default implementation of 'bprod' and 'buniq' for 'Generic' types, --- so instances can derived automatically. -class FunctorB b => ProductB (b :: (k -> Type) -> Type) where +{-# 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 @@ -72,48 +37,7 @@ class FunctorB b => ProductB (b :: (k -> Type) -> Type) where buniq = gbuniqDefault --- | An alias of 'bprod', since this is like a 'zip' for Barbie-types. -bzip :: ProductB b => b f -> b g -> b (f `Product` g) -bzip = bprod --- | An equivalent of 'unzip' for Barbie-types. -bunzip :: ProductB b => b (f `Product` g) -> (b f, b g) -bunzip bfg = (bmap (\(Pair a _) -> a) bfg, bmap (\(Pair _ b) -> b) bfg) - --- | An equivalent of 'Data.List.zipWith' for Barbie-types. -bzipWith :: ProductB b => (forall a. f a -> g a -> h a) -> b f -> b g -> b h -bzipWith f bf bg - = bmap (\(Pair fa ga) -> f fa ga) (bf `bprod` bg) - --- | An equivalent of 'Data.List.zipWith3' for Barbie-types. -bzipWith3 - :: ProductB b - => (forall a. f a -> g a -> h a -> i a) - -> b f -> b g -> b h -> b i -bzipWith3 f bf bg bh - = bmap (\(Pair (Pair fa ga) ha) -> f fa ga ha) - (bf `bprod` bg `bprod` bh) - - --- | An equivalent of 'Data.List.zipWith4' for Barbie-types. -bzipWith4 - :: ProductB b - => (forall a. f a -> g a -> h a -> i a -> j a) - -> b f -> b g -> b h -> b i -> b j -bzipWith4 f bf bg bh bi - = bmap (\(Pair (Pair (Pair fa ga) ha) ia) -> f fa ga ha ia) - (bf `bprod` bg `bprod` bh `bprod` bi) - - --- | @'CanDeriveProductB' B f g@ is in practice a predicate about @B@ only. --- Intuitively, it says that the following holds, for any arbitrary @f@: --- --- * There is an instance of @'Generic' (B f)@. --- --- * @B@ has only one constructor (that is, it is not a sum-type). --- --- * Every field of @B f@ is of the form @f a@, for some type @a@. --- In other words, @B@ has no "hidden" structure. type CanDeriveProductB b f g = ( GenericN (b f) , GenericN (b g) @@ -121,6 +45,15 @@ type CanDeriveProductB b f 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 diff --git a/src/Barbies/Internal/ProductC.hs b/src/Data/Barbie/Internal/ProductC.hs similarity index 65% rename from src/Barbies/Internal/ProductC.hs rename to src/Data/Barbie/Internal/ProductC.hs index ae4c65d..4ba8741 100644 --- a/src/Barbies/Internal/ProductC.hs +++ b/src/Data/Barbie/Internal/ProductC.hs @@ -2,10 +2,10 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -module Barbies.Internal.ProductC +{-# OPTIONS_GHC -Wno-deprecations #-} +module Data.Barbie.Internal.ProductC ( ProductBC(..) , buniqC - , bmempty , CanDeriveProductBC , GAllB @@ -15,67 +15,43 @@ module Barbies.Internal.ProductC where -import Barbies.Internal.Constraints -import Barbies.Internal.Dicts(ClassF, Dict (..), requiringDict) -import Barbies.Internal.Functor(bmap) -import Barbies.Internal.Product(ProductB (..)) -import Data.Kind(Type) +import Barbies.Internal.Constraints(ConstraintsB(..), GAllB, GAllBRep, Self, Other, X) +import Barbies.Internal.Dicts(Dict (..), requiringDict) +import Barbies.Internal.Functor(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 (..)) --- | Every type @b@ that is an instance of both 'ProductB' and --- 'ConstraintsB' can be made an instance of 'ProductBC' --- as well. --- --- Intuitively, in addition to 'buniq' from 'ProductB', one --- can define 'buniqC' that takes into account constraints: --- --- @ --- 'buniq' :: (forall a . f a) -> b f --- 'buniqC' :: 'AllB' c b => (forall a . c a => f a) -> b f --- @ --- --- For technical reasons, 'buniqC' is not currently provided --- as a method of this class and is instead defined in terms --- 'bdicts', which is similar to 'baddDicts' but can produce the --- instance dictionaries out-of-the-blue. 'bdicts' could also be --- defined in terms of 'buniqC', so they are essentially equivalent. --- --- @ --- 'bdicts' :: forall c b . 'AllB' c b => b ('Dict' c) --- 'bdicts' = 'buniqC' ('Dict' @c) --- @ --- --- --- There is a default implementation for 'Generic' types, so --- instances can derived automatically. 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 --- | Every type that admits a generic instance of 'ProductB' and --- 'ConstraintsB', has a generic instance of 'ProductBC' as well. + type CanDeriveProductBC c b = ( GenericN (b (Dict c)) , AllB c b ~ GAllB c (GAllBRep b) , GProductBC c (GAllBRep b) (RepN (b (Dict c))) ) --- | Like 'buniq' but a constraint is allowed to be required on --- each element of @b@. +{-# 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 --- | Builds a @b f@, by applying 'mempty' on every field of @b@. -bmempty :: forall f b . (AllBF Monoid f b, ProductBC b) => b f -bmempty - = buniqC @(ClassF Monoid f) mempty +instance ProductBC b => ProductBC (Barbie b) where + bdicts = Barbie bdicts + +instance ProductBC Unit where + bdicts = Unit + -- =============================================================== -- Generic derivations diff --git a/src/Data/Functor/Barbie.hs b/src/Data/Functor/Barbie.hs index 2824388..c95b695 100644 --- a/src/Data/Functor/Barbie.hs +++ b/src/Data/Functor/Barbie.hs @@ -1,8 +1,8 @@ ----------------------------------------------------------------------------- -- | --- Module : Data.Functor.Barbie +-- Module: Data.Functor.Barbie -- --- TBP +-- Functors from indexed-types to types. ---------------------------------------------------------------------------- module Data.Functor.Barbie ( @@ -16,10 +16,14 @@ module Data.Functor.Barbie , bfoldMap , bsequence, bsequence' - -- * Product - , ProductB(buniq, bprod) + -- * Applicative + , Appl.ApplicativeB(bpure, bprod) -- ** Utility functions - , bzip, bunzip, bzipWith, bzipWith3, bzipWith4 + , Appl.bzip + , Appl.bunzip + , Appl.bzipWith + , Appl.bzipWith3 + , Appl.bzipWith4 -- * Constraints and instance dictionaries -- | Consider the following function: @@ -32,25 +36,23 @@ module Data.Functor.Barbie -- We would then like to be able to do: -- -- @ - -- 'Data.Barbie.bmap' 'showIt' :: 'Data.Functor.Barbie.FunctorB' b => b 'Maybe' -> b ('Data.Functor.Const' 'String') + -- 'Data.Functor.Barbie.bmap' 'showIt' :: 'Data.Functor.Barbie.FunctorB' b => b 'Maybe' -> b ('Data.Functor.Const' 'String') -- @ -- -- This however doesn't work because of the @('Show' a)@ constraint in the -- the type of @showIt@. -- - -- The 'ConstraintsB' class let us overcome this problem. + -- The 'Cons.ConstraintsB' class let us overcome this problem. - , ConstraintsB(..) - , AllBF - - -- ** Products and constaints - , ProductBC(bdicts) + , Cons.ConstraintsB(..) + , Cons.AllBF -- ** Utility functions - , bmapC - , btraverseC - , buniqC - , bmempty + , Cons.bdicts + , Cons.bmapC + , Cons.btraverseC + , Cons.bpureC + , Cons.bmempty -- * Support for generic derivations , Rec(..) @@ -58,14 +60,11 @@ module Data.Functor.Barbie where -import Barbies.Internal.Constraints(AllBF, ConstraintsB (..), bmapC, btraverseC) +import qualified Barbies.Internal.Constraints as Cons import Barbies.Internal.Functor(FunctorB(..)) -import Barbies.Internal.Product - ( ProductB(..) - , bzip, bunzip, bzipWith, bzipWith3, bzipWith4 - ) -import Barbies.Internal.ProductC(ProductBC(..), buniqC, bmempty) +import qualified Barbies.Internal.Applicative as Appl + import Barbies.Internal.Traversable ( TraversableB(..) , bsequence, bsequence' diff --git a/test/Spec.hs b/test/Spec.hs index 3802ee2..8eef3c0 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -4,7 +4,7 @@ import Test.Tasty.HUnit (testCase, (@?=)) import qualified Spec.Bare as Bare import qualified Spec.Constraints as Constraints import qualified Spec.Functor as Functor -import qualified Spec.Product as Product +import qualified Spec.Applicative as Applicative import qualified Spec.Traversable as Traversable import qualified Spec.Wrapper as Wrapper @@ -12,7 +12,7 @@ import TestBarbies import TestBarbiesW import Barbies.Bare(Covered) -import Data.Functor.Barbie(bfoldMap, bmapC, btraverseC, buniqC) +import Data.Functor.Barbie(bfoldMap, bmapC, btraverseC, bpureC) import Data.Functor.Const (Const (..)) import Data.Functor.Identity (Identity (..)) import Data.Monoid (Sum (..)) @@ -77,38 +77,38 @@ main , Traversable.laws @(CompositeRecordW Covered) ] - , testGroup "Product Laws" - [ Product.laws @Record0 - , Product.laws @Record1 - , Product.laws @Record3 - , Product.laws @CompositeRecord + , testGroup "Product Laws of derived applicatives" + [ Applicative.productLaws @Record0 + , Applicative.productLaws @Record1 + , Applicative.productLaws @Record3 + , Applicative.productLaws @CompositeRecord - , Product.laws @Record1S - , Product.laws @Record3S + , Applicative.productLaws @Record1S + , Applicative.productLaws @Record3S - , Product.laws @(Record1W Covered) - , Product.laws @(Record3W Covered) - , Product.laws @(CompositeRecordW Covered) + , Applicative.productLaws @(Record1W Covered) + , Applicative.productLaws @(Record3W Covered) + , Applicative.productLaws @(CompositeRecordW Covered) - , Product.laws @(Record1WS Covered) - , Product.laws @(Record3WS Covered) + , Applicative.productLaws @(Record1WS Covered) + , Applicative.productLaws @(Record3WS Covered) ] , testGroup "Uniq Laws" - [ Product.uniqLaws @Record0 - , Product.uniqLaws @Record1 - , Product.uniqLaws @Record3 - , Product.uniqLaws @CompositeRecord + [ Applicative.uniqLaws @Record0 + , Applicative.uniqLaws @Record1 + , Applicative.uniqLaws @Record3 + , Applicative.uniqLaws @CompositeRecord - , Product.uniqLaws @Record1S - , Product.uniqLaws @Record3S + , Applicative.uniqLaws @Record1S + , Applicative.uniqLaws @Record3S - , Product.uniqLaws @(Record1W Covered) - , Product.uniqLaws @(Record3W Covered) - , Product.uniqLaws @(CompositeRecordW Covered) + , Applicative.uniqLaws @(Record1W Covered) + , Applicative.uniqLaws @(Record3W Covered) + , Applicative.uniqLaws @(CompositeRecordW Covered) - , Product.uniqLaws @(Record1WS Covered) - , Product.uniqLaws @(Record3WS Covered) + , Applicative.uniqLaws @(Record1WS Covered) + , Applicative.uniqLaws @(Record3WS Covered) ] , testGroup "adDict projection" @@ -196,9 +196,9 @@ main @?= (Sum 1, Record1 (Identity 1)) ] , testGroup - "buniqC" + "bpureC" [ testCase "Record1" $ - buniqC @Num (Identity (fromIntegral (42 :: Int))) + bpureC @Num (Identity (fromIntegral (42 :: Int))) @?= Record1 (Identity 42) ] ] diff --git a/test/Spec/Product.hs b/test/Spec/Applicative.hs similarity index 67% rename from test/Spec/Product.hs rename to test/Spec/Applicative.hs index 69d5831..4f5376f 100644 --- a/test/Spec/Product.hs +++ b/test/Spec/Applicative.hs @@ -1,11 +1,12 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -module Spec.Product ( laws, uniqLaws ) +module Spec.Applicative + ( productLaws, uniqLaws ) where import Clothes(F, G) -import Data.Functor.Barbie(FunctorB(..), ProductB(..)) +import Data.Functor.Barbie(FunctorB(..), ApplicativeB(..)) import Data.Functor.Product(Product(Pair)) import Data.Typeable(Typeable, Proxy(..), typeRep) @@ -14,16 +15,18 @@ import Test.Tasty(TestTree) import Test.Tasty.QuickCheck(Arbitrary(..), testProperty, (===)) -laws +-- We only derive ApplicativeB for products, so we test the product +-- laws, which are stronger than the applicative ones. +productLaws :: forall b - . ( ProductB b + . ( ApplicativeB b , Eq (b F), Eq (b G) , Show (b F), Show (b G) , Arbitrary (b F), Arbitrary (b G) , Typeable b ) => TestTree -laws +productLaws = testProperty (show (typeRep (Proxy :: Proxy b))) $ \l r -> bmap first (bprod l r) == (l :: b F) && bmap second (bprod l r) == (r :: b G) @@ -31,9 +34,10 @@ laws first (Pair a _) = a second (Pair _ b) = b +-- `bpure` is uniquely determined in products uniqLaws :: forall b - . ( ProductB b + . ( ApplicativeB b , Eq (b Maybe) , Show (b F), Show (b Maybe) , Arbitrary (b F) @@ -42,4 +46,4 @@ uniqLaws => TestTree uniqLaws = testProperty (show (typeRep (Proxy :: Proxy b))) $ \b -> - bmap (const Nothing) (b :: b F) === buniq Nothing + bmap (const Nothing) (b :: b F) === bpure Nothing diff --git a/test/Spec/Constraints.hs b/test/Spec/Constraints.hs index c0a3604..cd8c131 100644 --- a/test/Spec/Constraints.hs +++ b/test/Spec/Constraints.hs @@ -8,7 +8,7 @@ where import Clothes(F) import Barbies.Constraints(ClassF, Dict) -import Data.Functor.Barbie(bmap, ConstraintsB(..), AllBF, ProductBC(..)) +import Data.Functor.Barbie(bmap, bdicts, ApplicativeB, ConstraintsB(..), AllBF) import Data.Functor.Product (Product(Pair)) import Data.Typeable(Typeable, Proxy(..), typeRep) @@ -35,7 +35,7 @@ lawAddDictPrj lawDictsEquivPrj :: forall b - . ( ProductBC b, AllBF Show F b + . ( ApplicativeB b, ConstraintsB b, AllBF Show F b , Eq (b (Dict (ClassF Show F))) , Show (b F), Show (b (Dict (ClassF Show F))) , Arbitrary (b F) diff --git a/test/Spec/Wrapper.hs b/test/Spec/Wrapper.hs index 330fdb1..9399d5d 100644 --- a/test/Spec/Wrapper.hs +++ b/test/Spec/Wrapper.hs @@ -8,8 +8,7 @@ where import Prelude hiding (Semigroup, (<>)) -import Barbies (Barbie(..)) -import Data.Functor.Barbie (AllBF, ProductBC) +import Barbies (AllBF, ApplicativeB, Barbie(..), ConstraintsB) import Data.Semigroup (Semigroup, (<>)) @@ -19,7 +18,8 @@ import Test.Tasty.QuickCheck(Arbitrary(..), testProperty) lawsMonoid :: forall b . ( Arbitrary (b []), Eq (b []), Show (b []) - , ProductBC b + , ApplicativeB b + , ConstraintsB b , AllBF Semigroup [] b , AllBF Monoid [] b ) diff --git a/test/TestBarbies.hs b/test/TestBarbies.hs index 47c0dc4..ecf4fb0 100644 --- a/test/TestBarbies.hs +++ b/test/TestBarbies.hs @@ -46,9 +46,8 @@ data Record0 (f :: * -> *) instance FunctorB Record0 instance TraversableB Record0 -instance ProductB Record0 +instance ApplicativeB Record0 instance ConstraintsB Record0 -instance ProductBC Record0 instance Arbitrary (Record0 f) where arbitrary = pure Record0 @@ -60,9 +59,8 @@ data Record1 f instance FunctorB Record1 instance TraversableB Record1 -instance ProductB Record1 +instance ApplicativeB 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) @@ -78,9 +76,8 @@ data Record1S f instance FunctorB Record1S instance TraversableB Record1S -instance ProductB Record1S +instance ApplicativeB 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) @@ -100,9 +97,8 @@ data Record3 f instance FunctorB Record3 instance TraversableB Record3 -instance ProductB Record3 +instance ApplicativeB 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) @@ -121,9 +117,8 @@ data Record3S f instance FunctorB Record3S instance TraversableB Record3S -instance ProductB Record3S +instance ApplicativeB 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) @@ -186,9 +181,8 @@ data CompositeRecord f instance FunctorB CompositeRecord instance TraversableB CompositeRecord -instance ProductB CompositeRecord +instance ApplicativeB 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) @@ -224,9 +218,8 @@ data InfRec f instance FunctorB InfRec instance TraversableB InfRec -instance ProductB InfRec +instance ApplicativeB 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) @@ -265,9 +258,8 @@ data ParB b (f :: * -> *) instance FunctorB b => FunctorB (ParB b) instance TraversableB b => TraversableB (ParB b) -instance ProductB b => ProductB (ParB b) +instance ApplicativeB b => ApplicativeB (ParB b) instance ConstraintsB b => ConstraintsB (ParB b) -instance ProductBC b => ProductBC (ParB b) data ParBH h b (f :: * -> *) = ParBH (h (b f)) @@ -282,9 +274,8 @@ data ParX a f instance FunctorB (ParX a) instance TraversableB (ParX a) -instance ProductB (ParX a) +instance ApplicativeB (ParX a) instance ConstraintsB (ParX a) -instance ProductBC (ParX a) ----------------------------------------------------- @@ -300,6 +291,5 @@ data HKB b instance FunctorB HKB instance TraversableB HKB -instance ProductB HKB +instance ApplicativeB HKB instance ConstraintsB HKB -instance ProductBC HKB diff --git a/test/TestBarbiesW.hs b/test/TestBarbiesW.hs index 748b49e..581ec72 100644 --- a/test/TestBarbiesW.hs +++ b/test/TestBarbiesW.hs @@ -40,10 +40,9 @@ data Record1W t f instance FunctorB (Record1W Bare) instance FunctorB (Record1W Covered) instance TraversableB (Record1W Covered) -instance ProductB (Record1W Covered) +instance ApplicativeB (Record1W Covered) instance ConstraintsB (Record1W Bare) instance ConstraintsB (Record1W Covered) -instance ProductBC (Record1W Covered) instance BareB Record1W @@ -64,10 +63,9 @@ data Record1WS t f instance FunctorB (Record1WS Bare) instance FunctorB (Record1WS Covered) instance TraversableB (Record1WS Covered) -instance ProductB (Record1WS Covered) +instance ApplicativeB (Record1WS Covered) instance ConstraintsB (Record1WS Bare) instance ConstraintsB (Record1WS Covered) -instance ProductBC (Record1WS Covered) instance BareB Record1WS @@ -91,10 +89,9 @@ data Record3W t f instance FunctorB (Record3W Bare) instance FunctorB (Record3W Covered) instance TraversableB (Record3W Covered) -instance ProductB (Record3W Covered) +instance ApplicativeB (Record3W Covered) instance ConstraintsB (Record3W Bare) instance ConstraintsB (Record3W Covered) -instance ProductBC (Record3W Covered) instance BareB Record3W @@ -119,10 +116,9 @@ data Record3WS t f instance FunctorB (Record3WS Bare) instance FunctorB (Record3WS Covered) instance TraversableB (Record3WS Covered) -instance ProductB (Record3WS Covered) +instance ApplicativeB (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) @@ -182,10 +178,9 @@ data CompositeRecordW t f instance FunctorB (CompositeRecordW Bare) instance FunctorB (CompositeRecordW Covered) instance TraversableB (CompositeRecordW Covered) -instance ProductB (CompositeRecordW Covered) +instance ApplicativeB (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) @@ -232,10 +227,9 @@ data InfRecW t f instance FunctorB (InfRecW Bare) instance FunctorB (InfRecW Covered) instance TraversableB (InfRecW Covered) -instance ProductB (InfRecW Covered) +instance ApplicativeB (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) @@ -284,7 +278,7 @@ data ParBW b t (f :: * -> *) 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 ApplicativeB (b t) => ApplicativeB (ParBW b t) instance BareB b => BareB (ParBW b) -- XXX GHC currently rejects deriving this one since it @@ -298,9 +292,6 @@ 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 :: * -> *) = ParBHW (h (b t f)) @@ -317,6 +308,5 @@ data ParXW a t f instance FunctorB (ParXW a Bare) instance FunctorB (ParXW a Covered) instance TraversableB (ParXW a Covered) -instance ProductB (ParXW a Covered) +instance ApplicativeB (ParXW a Covered) instance ConstraintsB (ParXW a Covered) -instance ProductBC (ParXW a Covered)