barbies-2.0.5.0/src/0000755000000000000000000000000013606566611012252 5ustar0000000000000000barbies-2.0.5.0/src/Barbies/0000755000000000000000000000000014035406146013612 5ustar0000000000000000barbies-2.0.5.0/src/Barbies/Generics/0000755000000000000000000000000014035406146015351 5ustar0000000000000000barbies-2.0.5.0/src/Barbies/Internal/0000755000000000000000000000000014035406146015366 5ustar0000000000000000barbies-2.0.5.0/src/Data/0000755000000000000000000000000013606566611013123 5ustar0000000000000000barbies-2.0.5.0/src/Data/Barbie/0000755000000000000000000000000013550375211014277 5ustar0000000000000000barbies-2.0.5.0/src/Data/Barbie/Internal/0000755000000000000000000000000014035406146016054 5ustar0000000000000000barbies-2.0.5.0/src/Data/Functor/0000755000000000000000000000000014035406146014534 5ustar0000000000000000barbies-2.0.5.0/src/Data/Generics/0000755000000000000000000000000013606566611014662 5ustar0000000000000000barbies-2.0.5.0/test/0000755000000000000000000000000014315126605012433 5ustar0000000000000000barbies-2.0.5.0/test-legacy/0000755000000000000000000000000013554651311013676 5ustar0000000000000000barbies-2.0.5.0/test-legacy/Legacy/0000755000000000000000000000000014165352675015114 5ustar0000000000000000barbies-2.0.5.0/test-legacy/Legacy/Spec/0000755000000000000000000000000013554651311015774 5ustar0000000000000000barbies-2.0.5.0/test/Spec/0000755000000000000000000000000014035406146013325 5ustar0000000000000000barbies-2.0.5.0/src/Barbies.hs0000644000000000000000000002414413606566611014162 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module: Barbies -- -- A common Haskell idiom is to parameterise a datatype by a functor or GADT -- (or any "indexed type" @k -> 'Data.Kind.Type'@), a pattern -- sometimes called ). -- This parameter acts like the outfit of a Barbie, turning it into a different -- doll. The canonical example would be: -- -- @ -- data Person f -- = Person -- { name :: f 'String' -- , age :: f 'Int' -- } -- @ -- -- Let's say that we are writing an application where @Person@ data -- will be read from a web form, validated, and stored in a database. Some -- possibles outfits that we could use along the way are: -- -- @ -- Person ('Data.Functor.Const.Const' 'String') -- for the raw input from the web-form, -- Person ('Either' 'String') -- for the result of parsing and validating, -- Person 'Data.Functor.Identity.Identity' -- for the actual data, -- Person DbColumn -- To describe how to read / write a @Person@ to the db -- -- data DbColumn a -- = DbColumn -- { colName :: 'String' -- , fromDb :: DbDataParser a -- , toDb :: a -> DbData -- } -- @ -- -- In such application it is likely that one will have lots of types like -- @Person@ so we will like to handle these transformations uniformly, -- without boilerplate or repetitions. This package provides classes to -- manipulate these types, using notions that are familiar to haskellers like -- 'Functor', 'Applicative' or 'Traversable'. For example, instead of writing -- an ad-hoc function that checks that all fields have a correct value, like -- -- @ -- checkPerson :: Person ('Either' 'String') -> 'Either' ['String'] (Person 'Data.Functor.Identity.Identity') -- @ -- -- we can write only one such function: -- -- @ -- check :: 'TraversableB' b => b ('Either' 'String') -> 'Either' ['String'] (b 'Data.Functor.Identity.Identity') -- check be -- = case 'btraverse' ('either' ('const' 'Nothing') ('Just' . 'Daa.Functor.Identity.Identity')) be of -- 'Just' bi -> 'Right' bi -- 'Nothing' -> 'Left' ('bfoldMap' ('either' (:[]) ('const' [])) be) -- @ -- -- Moreover, these classes come with default instances based on -- `GHC.Generics.Generic`, so using them is as easy as: -- -- @ -- data Person f -- = Person -- { name :: f 'String' -- , age :: f 'Int' -- } -- deriving -- ( 'GHC.Generics.Generic' -- , 'FunctorB', 'TraversableB', 'ApplicativeB', 'ConstraintsB' -- ) -- -- deriving instance 'AllBF' 'Show' f Person => 'Show' (Person f) -- deriving instance 'AllBF' 'Eq' f Person => 'Eq' (Person f) -- @ -- ----------------------------------------------------------------------------- module Barbies ( -- * Barbies are functors -- | 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 (as :: [a]) -- @ -- -- to apply @f@ uniformly on every @a@ occurring -- in @as@, one could use the following to turn a 'Either'-outfit -- into 'Maybe'-outfit: -- -- @ -- 'bmap' ('either' ('const' '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 -- @ -- -- That is why `bmap` has a rank-2 type: -- -- @ -- 'bmap' :: 'FunctorB' b => (forall a. f a -> g a) -> b f -> b g -- @ -- -- Polymorphic functions with 'Applicative' effects can be applied -- using 'btraverse' and the effects will be accumulated: -- -- @ -- 'btraverse' :: ('TraversableB' b, 'Applicative' t) => (forall a. f a -> t (g a)) -> b f -> t (b g) -- @ -- -- Finally, some barbie-types (typically records like @Person@) have an -- 'Applicative' structure, and allow us to lift pure n-ary functions -- to functions on barbie-types. For example, 'bzipWith' gives us an analogous -- of 'Control.Applicative.liftA2': -- -- @ -- 'bzipWith' :: 'ApplicativeB' b => (forall a. f a -> g a -> h a) -> b f -> b g -> b h -- @ -- -- We can use this to combine barbies: -- -- @ -- addDefaults :: Person 'Maybe' -> Person 'Data.Functor.Identity' -> Person 'Data.Functor.Identity' -- addDefaults = 'bzipWith' (\\m d -> 'maybe' d 'pure' m) -- @ -- -- Why is there not a @MonadB@ class as well? As everyone knows, -- , -- which in this case is a problem, since barbie-types are not endofunctors: -- they map indexed-types to types, unlike the 'Functor' class, that -- captures endo-functors on 'Data.Kind.Type'. -- -- All these classes, and other convenient functions are found in: module Data.Functor.Barbie -- * Transformers are functors -- | Haskellers may be more used to playing with another family of dolls: -- . -- Consider for example the following functor-transformers: -- -- @ -- 'Data.Functor.Compose.Compose' g f a -- 'Control.Monad.Trans.Reader.ReaderT' r f a -- 'Control.Monad.Maybe.MaybeT' f a -- @ -- -- Like with barbies, we can think that different choices of @f@ will -- give us a different doll. And if we start thinking about how -- to change the outfit of a transformer, we notice that, just like -- barbie-types, transformer-types are functors too. -- -- @ -- 'tmap' :: 'FunctorT' t => (forall a. f a -> g a) -> t f x -> b g x -- @ -- -- Where 'FunctorB' captures functors from indexed-types to types, -- 'FunctorT' captures those between indexed-types. And again, we can -- identitfy familiar classes of functors: 'ApplicativeT' and 'TraversableT'. -- -- Now, transformers like the ones above, are actually endofunctors, e.g. -- they map @'Data.Kind.Type' -> 'Data.Kind.Type'@ to itself. So it makes -- sense to classify those that are actually monads: the 'MonadT' class -- gives us a notion similar to that of `Control.Monad.Trans.Class.MonadTrans', -- in that it lets us lift a value to its transformed version: -- -- @ -- 'tlift' :: 'MonadT' t => f a -> t f a -- -- -- E.g., using the instance for Compose: -- 'tlift' [1, 2, 3] = 'Data.Functor.Compose.Compose' ('Just' [1, 2, 3]) :: 'Data.Functor.Compose' 'Maybe' [] 'Int' -- @ -- -- Unlike all other classes in this package, 'MonadT' instances need to be written -- by hand. -- -- For further details, see: , module Data.Functor.Transformer -- * Bi-functors and nesting -- -- | A barbie-type that is parametric on an additional functor can be made an -- instance of both 'FunctorB' and 'FunctorT'. For example: -- -- @ -- data B f g = B (f Int) (g Bool) -- deriving (Generic) -- -- instance FunctorB (B f) -- instance FunctorT B -- @ -- -- This gives us a a bifunctor on indexed-types, as we can map -- simultaneously over both arguments using 'btmap': -- -- @ -- 'btmap' :: ('FunctorB' (b f), 'FunctorT' b) => (forall a . f a -> f' a) -> (forall a . g a -> g' a) -> b f g -> b f' g' -- @ -- -- When @f ~ g@, we can use a specialized version of 'btmap': -- -- @ -- 'btmap1' :: ('FunctorB' (b f), 'FunctorT' b) => (forall a . f a -> f' a) -> b f f -> b f' f' -- @ -- -- Functions like 'btmap1' can be useful to handle cases where we would like -- a barbie-type to occur under the functor-argument. Let's consider an example -- of this. Continuing the web form example above, one may want to find out -- about a person's dependants and model it as follows: -- -- @ -- newtype Dependants f -- = Dependants { getDependants :: f [Person f] } -- @ -- -- This has the appeal of letting us distinguish two states: -- -- @ -- Dependants { getDependants = Just [] } -- the user declared 0 dependants -- Dependants { getDependants = Nothing } -- the user didn't specify dependants yet -- @ -- -- Unfortunately, it is not possible to write a 'FunctorB' instance for such -- a type (before going on, try to write one yourself!). Intuitively, we would -- need to have @'Functor' f@, which we can't assume. However, such a type -- can be rewritten as follows: -- -- @ -- newtype Dependants f' f -- = Dependants { getDependants :: f' [Person f] } -- deriving (Generic) -- -- instance Functor f' => FunctorB (Dependants f') -- instance FunctorT Dependants -- -- type Dependants f = Dependants f f -- @ -- -- We can thus use 'btmap1' as a poor man's version of 'bmap' for 'Dependants'. -- -- For more details, see: , module Barbies.Bi -- * Container-barbies -- | Some clothes make barbies look like containers, and we can make those -- types behave like normal 'Functor's. , Containers.Container(..) , Containers.ErrorContainer(..) -- * Wrappers -- | This can be use with deriving via to automate derivation of instances -- for Barbie-types. , Wrappers.Barbie(..) -- * Trivial Barbies , Trivial.Void , Trivial.Unit (..) ) where import Barbies.Internal.Containers as Containers import Data.Functor.Barbie import Data.Functor.Transformer import Barbies.Bi import qualified Barbies.Internal.Trivial as Trivial import qualified Barbies.Internal.Wrappers as Wrappers barbies-2.0.5.0/src/Barbies/Bare.hs0000644000000000000000000000261014035406146015016 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Barbies.Bare -- -- Sometimes one needs a type like -- @Barbie 'Data.Functor.Identity.Identity'@ and it may feel like -- a second-class record type, where one needs to -- unpack values in each field. For those cases, we can leverage on -- closed type-families: -- -- @ -- data 'Bare' -- data 'Covered' -- -- type family 'Wear' t f a where -- 'Wear' 'Bare' f a = a -- 'Wear' 'Covered' f a = f a -- -- data SignUpForm t f -- = SignUpForm -- { username :: 'Wear' t f 'String', -- , password :: 'Wear' t f 'String' -- , mailingOk :: 'Wear' t f 'Bool' -- } -- instance 'Data.Functor.Barbie.FunctorB' (SignUpForm 'Covered') -- instance 'Data.Functor.Barbie.TraversableB' (SignUpForm 'Covered') -- ..., -- instance 'BareB' SignUpForm -- -- type SignUpRaw = SignUpForm 'Covered' 'Maybe' -- type SignUpData = SignUpForm 'Bare' 'Identity' -- -- formData = SignUpForm "jbond" "shaken007" False :: SignUpData -- @ ---------------------------------------------------------------------------- module Barbies.Bare ( -- * Bare values Wear , Bare , Covered -- * Covering and stripping , BareB(bstrip, bcover) , bstripFrom , bcoverWith , WearTwo ) where import Barbies.Internal.BareB ( Wear, Bare, Covered , BareB(..) , bstripFrom, bcoverWith , WearTwo ) barbies-2.0.5.0/src/Barbies/Bi.hs0000644000000000000000000001333614035406146014506 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE QuantifiedConstraints #-} #endif {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} module Barbies.Bi ( -- * Functor -- | A bifunctor is simultaneously a 'FunctorT' and a 'FunctorB'. btmap , btmap1 -- * Traversable -- | A traversable bifunctor is simultaneously a 'TraversableT' -- and a 'TraversableB'. , bttraverse , bttraverse1 , bttraverse_ , btfoldMap -- * Applicative -- | If @t@ is an 'ApplicativeT', the type of 'tpure' shows that its -- second argument must be a phantom-type, so there are really no -- interesting types that are both 'ApplicativeT' and 'ApplicativeB'. -- However, we can sometimes reconstruct a bi-applicative from an -- 'ApplicativeB' and a 'FunctorT'. , btpure , btpure1 , btprod -- * Wrappers , Flip(..) ) where import Barbies.Internal.Trivial (Unit(..)) import Barbies.Internal.Writer (execWr, tell) import Data.Functor.Barbie import Data.Functor.Transformer import Control.Applicative (Alternative(..)) import Control.Monad ((>=>)) import Data.Monoid (Alt(..)) import Data.Functor (void) import Data.Functor.Const (Const(..)) import Data.Functor.Product (Product(..)) -- {{ Functor ----------------------------------------------------------------- -- | Map over both arguments at the same time. btmap :: ( FunctorB (b f) , FunctorT b ) => (forall a . f a -> f' a) -> (forall a . g a -> g' a) -> b f g -> b f' g' btmap hf hg = tmap hf . bmap hg {-# INLINE btmap #-} -- | A version of 'btmap' specialized to a single argument. btmap1 :: ( FunctorB (b f) , FunctorT b ) => (forall a . f a -> g a) -> b f f -> b g g btmap1 h = btmap h h {-# INLINE btmap1 #-} -- }} Functor ----------------------------------------------------------------- -- {{ Traversable ------------------------------------------------------------- -- | Traverse over both arguments, first over @f@, then over @g@.. bttraverse :: ( TraversableB (b f) , TraversableT b , Monad t ) => (forall a . f a -> t (f' a)) -> (forall a . g a -> t (g' a)) -> b f g -> t (b f' g') bttraverse hf hg = btraverse hg >=> ttraverse hf {-# INLINE bttraverse #-} -- | A version of 'bttraverse' specialized to a single argument. bttraverse1 :: ( TraversableB (b f) , TraversableT b , Monad t ) => (forall a . f a -> t (g a)) -> b f f -> t (b g g) bttraverse1 h = bttraverse h h {-# INLINE bttraverse1 #-} -- | Map each element to an action, evaluate these actions from left to right -- and ignore the results. bttraverse_ :: ( TraversableB (b f) , TraversableT b , Monad e ) => (forall a. f a -> e c) -> (forall a. g a -> e d) -> b f g -> e () bttraverse_ hf hg = void . bttraverse (neuter . hf) (neuter . hg) where neuter = fmap (const $ Const ()) -- | Map each element to a monoid, and combine the results. btfoldMap :: ( TraversableB (b f) , TraversableT b , Monoid m ) => (forall a. f a -> m) -> (forall a. g a -> m) -> b f g -> m btfoldMap hf hg = execWr . bttraverse_ (tell . hf) (tell . hg) -- }} Traversable ------------------------------------------------------------- -- {{ Applicative ------------------------------------------------------------- -- | Conceptually, this is like simultaneously using `bpure' and 'tpure'. btpure :: ( ApplicativeB (b Unit) , FunctorT b ) => (forall a . f a) -> (forall a . g a) -> b f g btpure fa ga = tmap (\Unit-> fa) (bpure ga) {-# INLINE btpure #-} -- | A version of 'btpure' specialized to a single argument. btpure1 :: ( ApplicativeB (b Unit) , FunctorT b ) => (forall a . f a) -> b f f btpure1 h = btpure h h {-# INLINE btpure1 #-} -- | Simultaneous product on both arguments. btprod :: ( ApplicativeB (b (Alt (Product f f'))) , FunctorT b , Alternative f , Alternative f' ) => b f g -> b f' g' -> b (f `Product` f') (g `Product` g') btprod l r = tmap getAlt $ (tmap oneL l) `bprod` (tmap oneR r) where oneL la = Alt (Pair la empty) oneR ga = Alt (Pair empty ga) {-# INLINE btprod #-} -- }} Applicative ------------------------------------------------------------- -- | Convert a 'FunctorB' into a 'FunctorT' and vice-versa. newtype Flip b l r = Flip { runFlip :: b r l } deriving (Eq, Ord, Read, Show) instance FunctorT b => FunctorB (Flip b f) where bmap h (Flip bfx) = 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) = Flip <$> ttraverse h bfx {-# INLINE btraverse #-} instance ApplicativeT b => ApplicativeB (Flip b f) where bpure fa = Flip (tpure fa) {-# INLINE bpure #-} bprod (Flip bfx) (Flip bgx) = Flip (tprod bfx bgx) {-# INLINE bprod #-} #if __GLASGOW_HASKELL__ >= 806 -- ** The following instances require QuantifiedConstraints ** -- instance (forall f. FunctorB (b f)) => FunctorT (Flip b) where 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) = Flip <$> btraverse h bxf {-# INLINE ttraverse #-} instance (forall f. ApplicativeB (b f)) => ApplicativeT (Flip b) where tpure fa = Flip (bpure fa) {-# INLINE tpure #-} tprod (Flip bxf) (Flip bxg) = Flip (bprod bxf bxg) {-# INLINE tprod #-} #endif barbies-2.0.5.0/src/Barbies/Constraints.hs0000644000000000000000000000101614514733450016456 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module: Barbies.Constraints -- -- Support for operating on Barbie-types with constrained functions. ---------------------------------------------------------------------------- module Barbies.Constraints ( -- * Instance dictionaries Dict(..) , requiringDict -- * Getting constraints , AllBF , ClassF , ClassFG -- * Helpers , type (&) ) where import Barbies.Internal.ConstraintsB import Barbies.Internal.Dicts barbies-2.0.5.0/src/Barbies/Internal.hs0000644000000000000000000000430514035406146015724 0ustar0000000000000000module Barbies.Internal ( -- * Functor Internal.gbmapDefault , Generics.GFunctor(..) , 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 , Internal.gbprodDefault , Generics.GApplicative(..) , Internal.CanDeriveApplicativeB , Internal.CanDeriveApplicativeT -- * Constraints , Internal.gbaddDictsDefault , Generics.GConstraints(..) , Internal.CanDeriveConstraintsB , Internal.CanDeriveConstraintsT , Generics.GAll , Internal.GAllRepB , Internal.GAllRepT , Generics.X, Generics.Y , Generics.Self, Generics.Other, Generics.SelfOrOther , Internal.TagSelf0, Internal.TagSelf0' , Internal.TagSelf1, Internal.TagSelf1' -- * Bare values , Internal.gbcoverDefault , Internal.gbstripDefault , Generics.GBare(..) , Internal.CanDeriveBareB -- * Generic derivation support , module Data.Generics.GenericN ) where 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 import qualified Barbies.Internal.ApplicativeB as Internal import qualified Barbies.Internal.ApplicativeT as Internal 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 import qualified Barbies.Internal.TraversableT as Internal import Data.Generics.GenericN barbies-2.0.5.0/src/Data/Functor/Barbie.hs0000644000000000000000000000377614035406146016271 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module: Data.Functor.Barbie -- -- Functors from indexed-types to types. ---------------------------------------------------------------------------- module Data.Functor.Barbie ( -- * Functor Func.FunctorB(bmap) -- * Traversable , Trav.TraversableB(btraverse) -- ** Utility functions , Trav.btraverse_ , Trav.bfoldMap , Trav.bsequence , Trav.bsequence' -- * Distributive , Distr.DistributiveB(bdistribute) , Distr.bdistribute' , Distr.bcotraverse , Distr.bdecompose , Distr.brecompose -- * Applicative , Appl.ApplicativeB(bpure, bprod) -- ** Utility functions , Appl.bzip , Appl.bunzip , Appl.bzipWith , Appl.bzipWith3 , Appl.bzipWith4 -- * Constraints and instance dictionaries -- | Consider the following function: -- -- @ -- showIt :: 'Show' a => 'Maybe' a -> 'Data.Functor.Const' 'String' a -- showIt = 'Data.Functor.Const' . 'show' -- @ -- -- We would then like to be able to do: -- -- @ -- '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 'Cons.ConstraintsB' class let us overcome this problem. , Cons.ConstraintsB(..) , Cons.AllBF -- ** Utility functions , Cons.bdicts , Cons.bmapC , Cons.bfoldMapC , Cons.btraverseC , Cons.bpureC , Cons.bzipWithC , Cons.bzipWith3C , Cons.bzipWith4C , Cons.bmempty -- * Support for generic derivations , GenericN.Rec(..) ) where 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 barbies-2.0.5.0/src/Data/Functor/Transformer.hs0000644000000000000000000000261314035406146017374 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module: Data.Functor.Transformer -- -- Functors on indexed-types. ---------------------------------------------------------------------------- module Data.Functor.Transformer ( -- * Functor Func.FunctorT(tmap) -- * Traversable , Trav.TraversableT(ttraverse) -- ** Utility functions , Trav.ttraverse_ , Trav.tfoldMap , Trav.tsequence , Trav.tsequence' -- * Distributive , Dist.DistributiveT(tdistribute) , Dist.tdistribute' , Dist.tcotraverse , Dist.tdecompose , Dist.trecompose -- * Applicative , Appl.ApplicativeT(tpure, tprod) -- ** Utility functions , Appl.tzip , Appl.tunzip , Appl.tzipWith , Appl.tzipWith3 , Appl.tzipWith4 -- * Monad , Mon.MonadT(..) -- * Constraints and instance dictionaries , Cons.ConstraintsT(..) , Cons.AllTF -- ** Utility functions , Cons.tmapC , Cons.ttraverseC -- * Support for generic derivations , GenericsN.Rec(..) ) where 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 import qualified Data.Generics.GenericN as GenericsN barbies-2.0.5.0/src/Data/Barbie.hs0000644000000000000000000000507313606566611014650 0ustar0000000000000000{-# 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 /* barbies-2.0.5.0/src/Data/Barbie/Bare.hs0000644000000000000000000000050313546116165015510 0ustar0000000000000000module 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 barbies-2.0.5.0/src/Data/Barbie/Constraints.hs0000644000000000000000000000063213550375211017143 0ustar0000000000000000module 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 barbies-2.0.5.0/src/Data/Functor/Prod.hs0000644000000000000000000001644513546116165016013 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 barbies-2.0.5.0/src/Barbies/Generics/Applicative.hs0000644000000000000000000000603314071526067020155 0ustar0000000000000000{-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} module Barbies.Generics.Applicative ( GApplicative(..) ) where import Data.Functor.Product(Product(..)) import Data.Kind(Type) import Data.Proxy(Proxy (..)) import Data.Generics.GenericN class GApplicative n (f :: k -> Type) (g :: k -> Type) repbf repbg repbfg where gprod :: Proxy n -> Proxy f -> Proxy g -> repbf x -> repbg x -> repbfg x gpure :: (f ~ g, repbf ~ repbg) => Proxy n -> Proxy f -> Proxy repbf -> Proxy repbfg -> (forall a . f a) -> repbf x -- ---------------------------------- -- Trivial cases -- ---------------------------------- instance ( GApplicative n f g repf repg repfg ) => GApplicative n f g (M1 i c repf) (M1 i c repg) (M1 i c repfg) where gprod pn pf pg (M1 l) (M1 r) = M1 (gprod pn pf pg l r) {-# INLINE gprod #-} gpure pn pf _ _ x = M1 (gpure pn pf (Proxy @repf) (Proxy @repfg) x) {-# INLINE gpure #-} instance GApplicative n f g U1 U1 U1 where gprod _ _ _ U1 U1 = U1 {-# INLINE gprod #-} gpure _ _ _ _ _ = U1 {-# INLINE gpure #-} instance ( GApplicative n f g lf lg lfg , GApplicative n f g rf rg rfg ) => GApplicative n f g (lf :*: rf) (lg :*: rg) (lfg :*: rfg) where gprod pn pf pg (l1 :*: l2) (r1 :*: r2) = (l1 `lprod` r1) :*: (l2 `rprod` r2) where lprod = gprod pn pf pg rprod = gprod pn pf pg {-# INLINE gprod #-} gpure pn pf _ _ x = gpure pn pf (Proxy @lf) (Proxy @lfg) x :*: gpure pn pf (Proxy @rf) (Proxy @rfg) x {-# INLINE gpure #-} -- -------------------------------- -- The interesting cases -- -------------------------------- type P = Param -- {{ Functor application ----------------------------------------------------- instance GApplicative n f g (Rec (P n f a) (f a)) (Rec (P n g a) (g a)) (Rec (P n (f `Product` g) a) ((f `Product` g) a)) where gpure _ _ _ _ x = Rec (K1 x) {-# INLINE gpure #-} gprod _ _ _ (Rec (K1 fa)) (Rec (K1 ga)) = Rec (K1 (Pair fa ga)) {-# INLINE gprod #-} instance ( Applicative h ) => GApplicative n f g (Rec (h (P n f a)) (h (f a))) (Rec (h (P n g a)) (h (g a))) (Rec (h (P n (f `Product` g) a)) (h ((f `Product` g) a))) where gpure _ _ _ _ x = Rec (K1 $ pure x) {-# INLINE gpure #-} gprod _ _ _ (Rec (K1 fa)) (Rec (K1 ga)) = Rec (K1 (Pair <$> fa <*> ga)) {-# INLINE gprod #-} -- }} Functor application ----------------------------------------------------- -- {{ Not a functor application ----------------------------------------------- instance ( Monoid x ) => GApplicative n f g (Rec x x) (Rec x x) (Rec x x) where gpure _ _ _ _ _ = Rec (K1 mempty) {-# INLINE gpure #-} gprod _ _ _ (Rec (K1 l)) (Rec (K1 r)) = Rec (K1 (l <> r)) {-# INLINE gprod #-} -- }} Not a functor application ----------------------------------------------- barbies-2.0.5.0/src/Barbies/Generics/Bare.hs0000644000000000000000000000351014035406146016555 0ustar0000000000000000{-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} module Barbies.Generics.Bare ( GBare(..) ) where import Data.Functor.Identity (Identity(..)) import Data.Coerce (Coercible, coerce) import Data.Generics.GenericN import Data.Proxy (Proxy(..)) import GHC.TypeLits (Nat) class GBare (n :: Nat) repbi repbb where gstrip :: Proxy n -> repbi x -> repbb x gcover :: Proxy n -> repbb x -> repbi x -- ---------------------------------- -- Trivial cases -- ---------------------------------- instance GBare n repbi repbb => GBare n (M1 i k repbi) (M1 i k repbb) where gstrip pn = M1 . gstrip pn . unM1 {-# INLINE gstrip #-} gcover pn = M1 . gcover pn . unM1 {-# INLINE gcover #-} instance GBare n V1 V1 where gstrip _ _ = undefined gcover _ _ = undefined instance GBare n U1 U1 where gstrip _ = id {-# INLINE gstrip #-} gcover _ = id {-# INLINE gcover #-} instance (GBare n l l', GBare n r r') => GBare n (l :*: r) (l' :*: r') where gstrip pn (l :*: r) = (gstrip pn l) :*: gstrip pn r {-# INLINE gstrip #-} gcover pn (l :*: r) = (gcover pn l) :*: gcover pn r {-# INLINE gcover #-} instance (GBare n l l', GBare n r r') => GBare n (l :+: r) (l' :+: r') where gstrip pn = \case L1 l -> L1 (gstrip pn l) R1 r -> R1 (gstrip pn r) {-# INLINE gstrip #-} gcover pn = \case L1 l -> L1 (gcover pn l) R1 r -> R1 (gcover pn r) {-# INLINE gcover #-} -- -------------------------------- -- The interesting cases -- -------------------------------- type P = Param instance Coercible a b => GBare n (Rec (P n Identity a) (Identity a)) (Rec b b) where gstrip _ = coerce {-# INLINE gstrip #-} gcover _ = coerce {-# INLINE gcover #-} instance repbi ~ repbb => GBare n (Rec repbi repbi) (Rec repbb repbb) where gstrip _ = id {-# INLINE gstrip #-} gcover _ = id {-# INLINE gcover #-} barbies-2.0.5.0/src/Barbies/Generics/Constraints.hs0000644000000000000000000000747114035406146020225 0ustar0000000000000000{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE PolyKinds #-} module Barbies.Generics.Constraints ( GAll , X, Y , Self, Other, SelfOrOther , GConstraints(..) ) where import Barbies.Internal.Dicts(Dict (..)) import Data.Functor.Product (Product (..)) import Data.Kind (Constraint, Type) import GHC.TypeLits (Nat) import Data.Generics.GenericN class GConstraints n c f repbx repbf repbdf where gaddDicts :: GAll n c repbx => repbf x -> repbdf x type family GAll (n :: Nat) (c :: k -> Constraint) (repbf :: Type -> Type) :: Constraint data X a data family Y :: k -- ---------------------------------- -- Trivial cases -- ---------------------------------- type instance GAll n c (M1 i k repbf) = GAll n c repbf instance GConstraints n c f repbx repbf repbdf => GConstraints n c f (M1 i k repbx) (M1 i k repbf) (M1 i k repbdf) where gaddDicts = M1 . gaddDicts @n @c @f @repbx . unM1 {-# INLINE gaddDicts #-} type instance GAll n c V1 = () instance GConstraints n c f V1 V1 V1 where gaddDicts _ = undefined type instance GAll n c U1 = () instance GConstraints n c f U1 U1 U1 where gaddDicts = id {-# INLINE gaddDicts #-} type instance GAll n c (l :*: r) = (GAll n c l, GAll n c r) instance ( GConstraints n c f lx lf ldf , GConstraints n c f rx rf rdf ) => GConstraints n c f (lx :*: rx) (lf :*: rf) (ldf :*: rdf) where gaddDicts (l :*: r) = (gaddDicts @n @c @f @lx l) :*: (gaddDicts @n @c @f @rx r) {-# INLINE gaddDicts #-} type instance GAll n c (l :+: r) = (GAll n c l, GAll n c r) instance ( GConstraints n c f lx lf ldf , GConstraints n c f rx rf rdf ) => GConstraints n c f (lx :+: rx) (lf :+: rf) (ldf :+: rdf) where gaddDicts = \case L1 l -> L1 (gaddDicts @n @c @f @lx l) R1 r -> R1 (gaddDicts @n @c @f @rx r) {-# INLINE gaddDicts #-} -- -------------------------------- -- The interesting cases -- -------------------------------- type P = Param type instance GAll n c (Rec l r) = GAllRec n c l r type family GAllRec (n :: Nat) (c :: k -> Constraint) (l :: Type) (r :: Type) :: Constraint where GAllRec n c (P n X _) (X a) = c a GAllRec _ _ _ _ = () -- {{ Functor application ----------------------------------------------------- instance -- a' is a, maybe with Param applications GConstraints n c f (Rec (P n X a') (X a)) (Rec (P n f a') (f a)) (Rec (P n (Dict c `Product` f) a') ((Dict c `Product` f) a)) where gaddDicts = Rec . K1 . Pair Dict . unK1 . unRec {-# INLINE gaddDicts #-} -- }} Functor application ----------------------------------------------------- -- {{ Not a functor application ----------------------------------------------- instance -- b is a, but with X or Y instead of Param ... -- a' is a, maybe with occurrences of Param -- b' is b, maybe with occurences of Param GConstraints n c f (Rec a' a) -- a' may contain Y or Param m (m > n) (Rec b' b) -- a'' may only contain Param m (m > n) (Rec b' b) where gaddDicts = id {-# INLINE gaddDicts #-} -- }} Not a functor application ----------------------------------------------- -- ============================================================================ -- ## Identifying recursive usages of the barbie-type ## -- -- ============================================================================ data Self (p :: Type) (a :: Type) (x :: Type) data Other (p :: Type) (a :: Type) (x :: Type) type family SelfOrOther (b :: k) (b' :: k) :: Type -> Type -> Type -> Type where SelfOrOther b b = Self SelfOrOther b b' = Other barbies-2.0.5.0/src/Barbies/Generics/Distributive.hs0000644000000000000000000000351314035406146020364 0ustar0000000000000000{-# 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 #-} barbies-2.0.5.0/src/Barbies/Generics/Functor.hs0000644000000000000000000000376713606566611017351 0ustar0000000000000000{-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} module Barbies.Generics.Functor ( GFunctor(..) ) where import Data.Generics.GenericN import Data.Proxy (Proxy (..)) import GHC.TypeLits (Nat) class GFunctor (n :: Nat) f g repbf repbg where gmap :: Proxy n -> (forall a . f a -> g a) -> repbf x -> repbg x -- ---------------------------------- -- Trivial cases -- ---------------------------------- instance ( GFunctor n f g bf bg ) => GFunctor n f g (M1 i c bf) (M1 i c bg) where gmap pn h = M1 . gmap pn h . unM1 {-# INLINE gmap #-} instance GFunctor n f g V1 V1 where gmap _ _ _ = undefined instance GFunctor n f g U1 U1 where gmap _ _ = id {-# INLINE gmap #-} instance ( GFunctor n f g l l' , GFunctor n f g r r' ) => GFunctor n f g (l :*: r) (l' :*: r') where gmap pn h (l :*: r) = (gmap pn h l) :*: gmap pn h r {-# INLINE gmap #-} instance ( GFunctor n f g l l' , GFunctor n f g r r' ) => GFunctor n f g (l :+: r) (l' :+: r') where gmap pn h = \case L1 l -> L1 (gmap pn h l) R1 r -> R1 (gmap pn h r) {-# INLINE gmap #-} -- --------------------------------------------------------- -- The interesting cases. -- There are more interesting cases for specific values of n -- --------------------------------------------------------- type P = Param -- {{ Functor application ------------------------------------ instance GFunctor n f g (Rec (P n f a') (f a)) (Rec (P n g a') (g a)) where gmap _ h (Rec (K1 fa)) = Rec (K1 (h fa)) {-# INLINE gmap #-} instance ( Functor h ) => GFunctor n f g (Rec (h (P n f a')) (h (f a))) (Rec (h (P n g a')) (h (g a))) where gmap _ h (Rec (K1 hfa)) = Rec (K1 (h <$> hfa)) {-# INLINE gmap #-} -- }} Functor application ------------------------------------ -- {{ Not a functor application -------------------------- instance GFunctor n f g (Rec x x) (Rec x x) where gmap _ _ = id {-# INLINE gmap #-} -- }} Not a functor application -------------------------- barbies-2.0.5.0/src/Barbies/Generics/Traversable.hs0000644000000000000000000000426313606566611020173 0ustar0000000000000000{-# LANGUAGE PolyKinds #-} module Barbies.Generics.Traversable ( GTraversable(..) ) where import Data.Generics.GenericN import Data.Proxy (Proxy (..)) class GTraversable n f g repbf repbg where gtraverse :: Applicative t => Proxy n -> (forall a . f a -> t (g a)) -> repbf x -> t (repbg x) -- ---------------------------------- -- Trivial cases -- ---------------------------------- instance ( GTraversable n f g bf bg ) => GTraversable n f g (M1 i c bf) (M1 i c bg) where gtraverse pn h = fmap M1 . gtraverse pn h . unM1 {-# INLINE gtraverse #-} instance GTraversable n f g V1 V1 where gtraverse _ _ _ = undefined {-# INLINE gtraverse #-} instance GTraversable n f g U1 U1 where gtraverse _ _ = pure {-# INLINE gtraverse #-} instance ( GTraversable n f g l l' , GTraversable n f g r r' ) => GTraversable n f g (l :*: r) (l' :*: r') where gtraverse pn h (l :*: r) = (:*:) <$> gtraverse pn h l <*> gtraverse pn h r {-# INLINE gtraverse #-} instance ( GTraversable n f g l l' , GTraversable n f g r r' ) => GTraversable n f g (l :+: r) (l' :+: r') where gtraverse pn h = \case L1 l -> L1 <$> gtraverse pn h l R1 r -> R1 <$> gtraverse pn h r {-# INLINE gtraverse #-} -- -------------------------------- -- The interesting cases -- -------------------------------- type P = Param -- {{ Functor application ------------------------------------------------------ instance GTraversable n f g (Rec (P n f a') (f a)) (Rec (P n g a') (g a)) where gtraverse _ h = fmap (Rec . K1) . h . unK1 . unRec {-# INLINE gtraverse #-} instance ( Traversable h ) => GTraversable n f g (Rec (h (P n f a)) (h (f a))) (Rec (h (P n g a)) (h (g a))) where gtraverse _ h = fmap (Rec . K1) . traverse h . unK1 . unRec {-# INLINE gtraverse #-} -- }} Functor application ------------------------------------------------------ -- {{ Not a functor application ----------------------------------------------- instance GTraversable n f g (Rec a a) (Rec a a) where gtraverse _ _ = pure {-# INLINE gtraverse #-} -- }} Not a functor application ----------------------------------------------- barbies-2.0.5.0/src/Barbies/Internal/ApplicativeB.hs0000644000000000000000000001613613606566611020303 0ustar0000000000000000{-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} module Barbies.Internal.ApplicativeB ( ApplicativeB(bpure, bprod) , bzip, bunzip, bzipWith, bzipWith3, bzipWith4 , CanDeriveApplicativeB , gbprodDefault, gbpureDefault ) where import Barbies.Generics.Applicative(GApplicative(..)) import Barbies.Internal.FunctorB (FunctorB (..)) import Data.Functor.Const (Const (..)) import Data.Functor.Constant(Constant (..)) 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 the same way as '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 every field is either a 'Monoid' or -- covered by the argument @f@. 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'. bzip :: ApplicativeB b => b f -> b g -> b (f `Product` g) bzip = bprod -- | An equivalent of 'unzip'. 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'. 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'. 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'. 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 either a monoid, or of the form @f a@, for -- some type @a@. type CanDeriveApplicativeB b f g = ( GenericP 0 (b f) , GenericP 0 (b g) , GenericP 0 (b (f `Product` g)) , GApplicative 0 f g (RepP 0 (b f)) (RepP 0 (b g)) (RepP 0 (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 = toP p0 $ gprod p0 (Proxy @f) (Proxy @g) (fromP p0 l) (fromP p0 r) where p0 = Proxy @0 {-# INLINE gbprodDefault #-} gbpureDefault :: forall b f . CanDeriveApplicativeB b f f => (forall a . f a) -> b f gbpureDefault fa = toP (Proxy @0) $ gpure (Proxy @0) (Proxy @f) (Proxy @(RepP 0 (b f))) (Proxy @(RepP 0 (b (f `Product` f)))) fa {-# INLINE gbpureDefault #-} -- ------------------------------------------------------------ -- Generic derivation: Special cases for ApplicativeB -- ------------------------------------------------------------- type P = Param instance ( ApplicativeB b ) => GApplicative 0 f g (Rec (b (P 0 f)) (b f)) (Rec (b (P 0 g)) (b g)) (Rec (b (P 0 (f `Product` g))) (b (f `Product` g))) where gpure _ _ _ _ fa = Rec (K1 (bpure fa)) {-# INLINE gpure #-} gprod _ _ _ (Rec (K1 bf)) (Rec (K1 bg)) = Rec (K1 (bf `bprod` bg)) {-# INLINE gprod #-} instance ( Applicative h , ApplicativeB b ) => GApplicative 0 f g (Rec (h (b (P 0 f))) (h (b f))) (Rec (h (b (P 0 g))) (h (b g))) (Rec (h (b (P 0 (f `Product` g)))) (h (b (f `Product` g)))) where gpure _ _ _ _ fa = Rec (K1 (pure $ bpure fa)) {-# INLINE gpure #-} gprod _ _ _ (Rec (K1 hbf)) (Rec (K1 hbg)) = Rec (K1 (bprod <$> hbf <*> hbg)) {-# INLINE gprod #-} -- This is the same as the previous instance, but for nested Applicatives. instance ( Applicative h , Applicative m , ApplicativeB b ) => GApplicative 0 f g (Rec (m (h (b (P 0 f)))) (m (h (b f)))) (Rec (m (h (b (P 0 g)))) (m (h (b g)))) (Rec (m (h (b (P 0 (f `Product` g))))) (m (h (b (f `Product` g))))) where gpure _ _ _ _ x = Rec (K1 (pure . pure $ bpure x)) {-# INLINE gpure #-} gprod _ _ _ (Rec (K1 hbf)) (Rec (K1 hbg)) = Rec (K1 (go <$> hbf <*> hbg)) where go a b = bprod <$> a <*> b {-# INLINE gprod #-} -- -------------------------------- -- Instances for base types -- -------------------------------- instance ApplicativeB Proxy where bpure _ = Proxy {-# INLINE bpure #-} bprod _ _ = Proxy {-# INLINE bprod #-} instance Monoid a => ApplicativeB (Const a) where bpure _ = Const mempty {-# INLINE bpure #-} bprod (Const l) (Const r) = Const (l `mappend` r) {-# INLINE bprod #-} instance (ApplicativeB a, ApplicativeB b) => ApplicativeB (Product a b) where bpure x = Pair (bpure x) (bpure x) {-# INLINE bpure #-} bprod (Pair ll lr) (Pair rl rr) = Pair (bprod ll rl) (bprod lr rr) {-# INLINE bprod #-} -- -------------------------------- -- Instances for base types -- -------------------------------- instance Monoid a => ApplicativeB (Constant a) where bpure _ = Constant mempty {-# INLINE bpure #-} bprod (Constant l) (Constant r) = Constant (l `mappend` r) {-# INLINE bprod #-} barbies-2.0.5.0/src/Barbies/Internal/ApplicativeT.hs0000644000000000000000000001673014035406146020316 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE QuantifiedConstraints #-} #endif {-# OPTIONS_GHC -Wno-orphans #-} module Barbies.Internal.ApplicativeT ( ApplicativeT(tpure, tprod) , tzip, tunzip, tzipWith, tzipWith3, tzipWith4 , CanDeriveApplicativeT , gtprodDefault, gtpureDefault ) where import Barbies.Generics.Applicative(GApplicative(..)) import Barbies.Internal.FunctorT (FunctorT (..)) import Control.Applicative (Alternative(..)) import Data.Functor.Compose (Compose (..)) import Data.Functor.Product (Product (..)) import Data.Functor.Reverse (Reverse (..)) import Data.Functor.Sum (Sum (..)) import Data.Kind (Type) import Data.Proxy (Proxy (..)) import Data.Generics.GenericN -- | A 'FunctorT' with application, providing operations to: -- -- * embed an "empty" value ('tpure') -- -- * align and combine values ('tprod') -- -- It should satisfy the following laws: -- -- [Naturality of 'tprod'] -- -- @ -- 'tmap' (\('Pair' a b) -> 'Pair' (f a) (g b)) (u `'tprod'` v) = 'tmap' f u `'tprod'` 'tmap' g v -- @ -- -- [Left and right identity] -- -- @ -- 'tmap' (\('Pair' _ b) -> b) ('tpure' e `'tprod'` v) = v -- 'tmap' (\('Pair' a _) -> a) (u `'tprod'` 'tpure' e) = u -- @ -- -- [Associativity] -- -- @ -- 'tmap' (\('Pair' a ('Pair' b c)) -> 'Pair' ('Pair' a b) c) (u `'tprod'` (v `'tprod'` w)) = (u `'tprod'` v) `'tprod'` w -- @ -- -- It is to 'FunctorT' in the same way is 'Applicative' -- relates to 'Functor'. For a presentation of 'Applicative' as -- a monoidal functor, see Section 7 of -- . -- -- There is a default implementation of 'tprod' and 'tpure' based on 'Generic'. -- Intuitively, it works on types where the value of `tpure` is uniquely defined. -- This corresponds rougly to record types (in the presence of sums, there would -- be several candidates for `tpure`), where every field is either a 'Monoid' or -- covered by the argument @f@. class FunctorT t => ApplicativeT (t :: (k -> Type) -> (k' -> Type)) where tpure :: (forall a . f a) -> t f x tprod :: t f x -> t g x -> t (f `Product` g) x default tpure :: CanDeriveApplicativeT t f f x => (forall a . f a) -> t f x tpure = gtpureDefault default tprod :: CanDeriveApplicativeT t f g x => t f x -> t g x -> t (f `Product` g) x tprod = gtprodDefault -- | An alias of 'tprod'. tzip :: ApplicativeT t => t f x -> t g x -> t (f `Product` g) x tzip = tprod -- | An equivalent of 'unzip'. tunzip :: ApplicativeT t => t (f `Product` g) x -> (t f x, t g x) tunzip tfg = (tmap (\(Pair a _) -> a) tfg, tmap (\(Pair _ b) -> b) tfg) -- | An equivalent of 'Data.List.zipWith'. tzipWith :: ApplicativeT t => (forall a. f a -> g a -> h a) -> t f x -> t g x -> t h x tzipWith f tf tg = tmap (\(Pair fa ga) -> f fa ga) (tf `tprod` tg) -- | An equivalent of 'Data.List.zipWith3'. tzipWith3 :: ApplicativeT t => (forall a. f a -> g a -> h a -> i a) -> t f x -> t g x -> t h x -> t i x tzipWith3 f tf tg th = tmap (\(Pair (Pair fa ga) ha) -> f fa ga ha) (tf `tprod` tg `tprod` th) -- | An equivalent of 'Data.List.zipWith4'. tzipWith4 :: ApplicativeT t => (forall a. f a -> g a -> h a -> i a -> j a) -> t f x -> t g x -> t h x -> t i x -> t j x tzipWith4 f tf tg th ti = tmap (\(Pair (Pair (Pair fa ga) ha) ia) -> f fa ga ha ia) (tf `tprod` tg `tprod` th `tprod` ti) -- | @'CanDeriveApplicativeT' T f g x@ is in practice a predicate about @T@ only. -- Intuitively, it says that the following holds, for any arbitrary @f@: -- -- * There is an instance of @'Generic' (T f)@. -- -- * @T@ has only one constructor (that is, it is not a sum-type). -- -- * Every field of @T f x@ is either a monoid, or of the form @f a@, for -- some type @a@. type CanDeriveApplicativeT t f g x = ( GenericP 1 (t f x) , GenericP 1 (t g x) , GenericP 1 (t (f `Product` g) x) , GApplicative 1 f g (RepP 1 (t f x)) (RepP 1 (t g x)) (RepP 1 (t (f `Product` g) x)) ) -- ====================================== -- Generic derivation of instances -- ====================================== -- | Default implementation of 'tprod' based on 'Generic'. gtprodDefault :: forall t f g x . CanDeriveApplicativeT t f g x => t f x -> t g x -> t (f `Product` g) x gtprodDefault l r = toP p1 $ gprod p1 (Proxy @f) (Proxy @g) (fromP p1 l) (fromP p1 r) where p1 = Proxy @1 {-# INLINE gtprodDefault #-} gtpureDefault :: forall t f x . CanDeriveApplicativeT t f f x => (forall a . f a) -> t f x gtpureDefault fa = toP (Proxy @1) $ gpure (Proxy @1) (Proxy @f) (Proxy @(RepP 1 (t f x))) (Proxy @(RepP 1 (t (f `Product` f) x))) fa {-# INLINE gtpureDefault #-} -- ------------------------------------------------------------ -- Generic derivation: Special cases for ApplicativeT -- ------------------------------------------------------------- type P = Param instance ( ApplicativeT t ) => GApplicative 1 f g (Rec (t (P 1 f) x) (t f x)) (Rec (t (P 1 g) x) (t g x)) (Rec (t (P 1 (f `Product` g)) x) (t (f `Product` g) x)) where gpure _ _ _ _ fa = Rec (K1 (tpure fa)) {-# INLINE gpure #-} gprod _ _ _ (Rec (K1 tf)) (Rec (K1 tg)) = Rec (K1 (tf `tprod` tg)) {-# INLINE gprod #-} instance ( Applicative h , ApplicativeT t ) => GApplicative 1 f g (Rec (h (t (P 1 f) x)) (h (t f x))) (Rec (h (t (P 1 g) x)) (h (t g x))) (Rec (h (t (P 1 (f `Product` g)) x)) (h (t (f `Product` g) x))) where gpure _ _ _ _ fa = Rec (K1 (pure $ tpure fa)) {-# INLINE gpure #-} gprod _ _ _ (Rec (K1 htf)) (Rec (K1 htg)) = Rec (K1 (tprod <$> htf <*> htg)) {-# INLINE gprod #-} -- This is the same as the previous instance, but for nested Applicatives. instance ( Applicative h , Applicative m , ApplicativeT t ) => GApplicative 1 f g (Rec (m (h (t (P 1 f) x))) (m (h (t f x)))) (Rec (m (h (t (P 1 g) x))) (m (h (t g x)))) (Rec (m (h (t (P 1 (f `Product` g)) x))) (m (h (t (f `Product` g) x)))) where gpure _ _ _ _ x = Rec (K1 (pure . pure $ tpure x)) {-# INLINE gpure #-} gprod _ _ _ (Rec (K1 htfx)) (Rec (K1 htgx)) = Rec (K1 (go <$> htfx <*> htgx)) where go a b = tprod <$> a <*> b {-# INLINE gprod #-} -- -------------------------------- -- Instances for base types -- -------------------------------- instance Applicative f => ApplicativeT (Compose f) where tpure fa = Compose (pure fa) {-# INLINE tpure #-} tprod (Compose fga) (Compose fha) = Compose (Pair <$> fga <*> fha) {-# INLINE tprod #-} instance ApplicativeT Reverse where tpure fa = Reverse fa {-# INLINE tpure #-} tprod (Reverse fa) (Reverse ga) = Reverse (Pair fa ga) {-# INLINE tprod #-} instance Alternative f => ApplicativeT (Product f) where tpure fa = Pair empty fa {-# INLINE tpure #-} tprod (Pair fl gl) (Pair fr gr) = Pair (fl <|> fr) (Pair gl gr) {-# INLINE tprod #-} instance Alternative f => ApplicativeT (Sum f) where tpure fa = InR fa {-# INLINE tpure #-} tprod l r = case (l, r) of (InR gl, InR gr) -> InR (Pair gl gr) (InR _, InL fr) -> InL fr (InL fl, InR _) -> InL fl (InL fl, InL fr) -> InL (fl <|> fr) {-# INLINE tprod #-} barbies-2.0.5.0/src/Barbies/Internal/BareB.hs0000644000000000000000000000676014035406146016706 0ustar0000000000000000{-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} module Barbies.Internal.BareB ( Wear, Bare, Covered , BareB(..) , bstripFrom, bcoverWith , WearTwo , gbstripDefault , gbcoverDefault , CanDeriveBareB ) where import Barbies.Generics.Bare(GBare(..)) import Barbies.Internal.FunctorB (FunctorB(..)) import Barbies.Internal.Wear(Bare, Covered, Wear, WearTwo) import Data.Functor.Identity (Identity(..)) import Data.Generics.GenericN import Data.Proxy (Proxy(..)) -- | Class of Barbie-types defined using 'Wear' and can therefore -- have 'Bare' versions. Must satisfy: -- -- @ -- 'bcover' . 'bstrip' = 'id' -- 'bstrip' . 'bcover' = 'id' -- @ class FunctorB (b Covered) => BareB b where bstrip :: b Covered Identity -> b Bare Identity bcover :: b Bare Identity -> b Covered Identity default bstrip :: CanDeriveBareB b => b Covered Identity -> b Bare Identity bstrip = gbstripDefault default bcover :: CanDeriveBareB b => b Bare Identity -> b Covered Identity bcover = gbcoverDefault -- | Generalization of 'bstrip' to arbitrary functors bstripFrom :: BareB b => (forall a . f a -> a) -> b Covered f -> b Bare Identity bstripFrom f = bstrip . bmap (Identity . f) -- | Generalization of 'bcover' to arbitrary functors bcoverWith :: BareB b => (forall a . a -> f a) -> b Bare Identity -> b Covered f bcoverWith f = bmap (f . runIdentity) . bcover -- | All types that admit a generic 'FunctorB' instance, and have all -- their occurrences of @f@ under a 'Wear' admit a generic 'BareB' -- instance. type CanDeriveBareB b = ( GenericP 0 (b Bare Identity) , GenericP 0 (b Covered Identity) , GBare 0 (RepP 0 (b Covered Identity)) (RepP 0 (b Bare Identity)) ) -- | Default implementation of 'bstrip' based on 'Generic'. gbstripDefault :: CanDeriveBareB b => b Covered Identity -> b Bare Identity gbstripDefault = toP (Proxy @0) . gstrip (Proxy @0) . fromP (Proxy @0) {-# INLINE gbstripDefault #-} -- | Default implementation of 'bstrip' based on 'Generic'. gbcoverDefault :: CanDeriveBareB b => b Bare Identity -> b Covered Identity gbcoverDefault = toP (Proxy @0) . gcover (Proxy @0) . fromP (Proxy @0) {-# INLINE gbcoverDefault #-} -- ------------------------------------------------------------ -- Generic derivation: Special cases for FunctorB -- ----------------------------------------------------------- type P = Param instance ( BareB b ) => GBare 0 (Rec (b Covered (P 0 Identity)) (b Covered Identity)) (Rec (b Bare (P 0 Identity)) (b Bare Identity)) where gstrip _ = Rec . K1 . bstrip . unK1 . unRec {-# INLINE gstrip #-} gcover _ = Rec . K1 . bcover . unK1 . unRec {-# INLINE gcover #-} instance ( Functor h , BareB b ) => GBare 0 (Rec (h (b Covered (P 0 Identity))) (h (b Covered Identity))) (Rec (h (b Bare (P 0 Identity))) (h (b Bare Identity))) where gstrip _ = Rec . K1 . fmap bstrip . unK1 . unRec {-# INLINE gstrip #-} gcover _ = Rec . K1 . fmap bcover . unK1 . unRec {-# INLINE gcover #-} -- This instance is the same as the previous, but for nested Functors instance ( Functor h , Functor m , BareB b ) => GBare 0 (Rec (m (h (b Covered (P 0 Identity)))) (m (h (b Covered Identity)))) (Rec (m (h (b Bare (P 0 Identity)))) (m (h (b Bare Identity)))) where gstrip _ = Rec . K1 . fmap (fmap bstrip) . unK1 . unRec {-# INLINE gstrip #-} gcover _ = Rec . K1 . fmap (fmap bcover) . unK1 . unRec {-# INLINE gcover #-} barbies-2.0.5.0/src/Barbies/Internal/ConstraintsB.hs0000644000000000000000000002622414514733520020342 0ustar0000000000000000{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} {-# OPTIONS_GHC -Wno-orphans #-} module Barbies.Internal.ConstraintsB ( ConstraintsB(..) , bmapC , btraverseC , AllBF , bdicts , bpureC , bmempty , bzipWithC , bzipWith3C , bzipWith4C , bfoldMapC , type (&) , CanDeriveConstraintsB , gbaddDictsDefault , GAllRepB , TagSelf0, TagSelf0' ) where import Barbies.Generics.Constraints ( GConstraints(..) , GAll , Self , Other , SelfOrOther , X ) import Barbies.Internal.ApplicativeB(ApplicativeB(..)) import Barbies.Internal.Dicts(ClassF, Dict (..), requiringDict) import Barbies.Internal.FunctorB(FunctorB (..)) import Barbies.Internal.TraversableB(TraversableB (..)) import Data.Functor.Compose (Compose (..)) import Data.Functor.Const (Const (..)) import Data.Functor.Product (Product (..)) import Data.Functor.Sum (Sum (..)) import Data.Kind (Constraint, Type) import Data.Proxy (Proxy (..)) import Data.Generics.GenericN -- | Instances of this class provide means to talk about constraints, -- both at compile-time, using 'AllB', and at run-time, in the form -- of 'Dict', via 'baddDicts'. -- -- A manual definition would look like this: -- -- @ -- data T f = A (f 'Int') (f 'String') | B (f 'Bool') (f 'Int') -- -- instance 'ConstraintsB' T where -- type 'AllB' c T = (c 'Int', c 'String', c 'Bool') -- -- 'baddDicts' t = case t of -- A x y -> A ('Pair' 'Dict' x) ('Pair' 'Dict' y) -- B z w -> B ('Pair' 'Dict' z) ('Pair' 'Dict' w) -- @ -- -- Now, when we given a @T f@, if we need to use the 'Show' instance of -- their fields, we can use: -- -- @ -- 'baddDicts' :: AllB Show b => b f -> b ('Dict' 'Show' `'Product'` f) -- @ -- -- There is a default implementation of 'ConstraintsB' for -- 'Generic' types, so in practice one will simply do: -- -- @ -- derive instance 'Generic' (T f) -- instance 'ConstraintsB' T -- @ class FunctorB b => ConstraintsB (b :: (k -> Type) -> Type) where -- | @'AllB' c b@ should contain a constraint @c a@ for each -- @a@ occurring under an @f@ in @b f@. E.g.: -- -- @ -- 'AllB' 'Show' Person ~ ('Show' 'String', 'Show' 'Int') -- @ -- -- For requiring constraints of the form @c (f a)@, use 'AllBF'. type AllB (c :: k -> Constraint) b :: Constraint type AllB c b = GAll 0 c (GAllRepB b) baddDicts :: forall c f . AllB c b => b f -> b (Dict c `Product` f) default baddDicts :: forall c f . ( CanDeriveConstraintsB c b f , AllB c b ) => b f -> b (Dict c `Product` f) baddDicts = gbaddDictsDefault class (c a, d a) => (c & d) a where instance (c a, d a) => (c & d) a where -- | Like 'bmap' but a constraint is allowed to be required on -- each element of @b@ -- -- E.g. If all fields of @b@ are 'Show'able then you -- could store each shown value in it's slot using 'Const': -- -- > showFields :: (AllB Show b, ConstraintsB b) => b Identity -> b (Const String) -- > showFields = bmapC @Show showField -- > where -- > showField :: forall a. Show a => Identity a -> Const String a -- > showField (Identity a) = Const (show a) -- -- Notice that one can use the '(&)' class as a way to require several -- constraiints to hold simultaneously: -- -- > bmap @(Show & Eq & Enum) r bmapC :: forall c b f g . (AllB c b, ConstraintsB b) => (forall a. c a => f a -> g a) -> b f -> b g bmapC f bf = bmap go (baddDicts bf) where go :: forall a. (Dict c `Product` f) a -> g a go (d `Pair` fa) = requiringDict (f fa) d -- | Like 'btraverse' but with a constraint on the elements of @b@. btraverseC :: forall c b f g e . (TraversableB b, ConstraintsB b, AllB c b, Applicative e) => (forall a. c a => f a -> e (g a)) -> b f -> e (b g) btraverseC f b = btraverse (\(Pair (Dict :: Dict c a) x) -> f x) (baddDicts b) bfoldMapC :: forall c b m f . (TraversableB b, ConstraintsB b, AllB c b, Monoid m) => (forall a. c a => f a -> m) -> b f -> m bfoldMapC f = getConst . btraverseC @c (Const . f) -- | Like 'Data.Functor.Barbie.bzipWith' but with a constraint on the elements of @b@. bzipWithC :: forall c b f g h . (AllB c b, ConstraintsB b, ApplicativeB b) => (forall a. c a => f a -> g a -> h a) -> b f -> b g -> b h bzipWithC f bf bg = bmapC @c go (bf `bprod` bg) where go :: forall a. c a => Product f g a -> h a go (Pair fa ga) = f fa ga -- | Like 'Data.Functor.Barbie.bzipWith3' but with a constraint on the elements of @b@. bzipWith3C :: forall c b f g h i . (AllB c b, ConstraintsB b, ApplicativeB b) => (forall a. c a => f a -> g a -> h a -> i a) -> b f -> b g -> b h -> b i bzipWith3C f bf bg bh = bmapC @c go (bf `bprod` bg `bprod` bh) where go :: forall a. c a => Product (Product f g) h a -> i a go (Pair (Pair fa ga) ha) = f fa ga ha -- | Like 'Data.Functor.Barbie.bzipWith4' but with a constraint on the elements of @b@. bzipWith4C :: forall c b f g h i j . (AllB c b, ConstraintsB b, ApplicativeB b) => (forall a. c a => f a -> g a -> h a -> i a -> j a) -> b f -> b g -> b h -> b i -> b j bzipWith4C f bf bg bh bi = bmapC @c go (bf `bprod` bg `bprod` bh `bprod` bi) where go :: forall a. c a => Product (Product (Product f g) h) i a -> j a go (Pair (Pair (Pair fa ga) ha) ia) = f fa ga ha ia -- | Similar to 'AllB' but will put the functor argument @f@ -- between the constraint @c@ and the type @a@. For example: -- -- @ -- 'AllB' 'Show' Person ~ ('Show' 'String', 'Show' 'Int') -- 'AllBF' 'Show' f Person ~ ('Show' (f 'String'), 'Show' (f 'Int')) -- @ 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 fa = bmap (requiringDict @c fa) 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 -- | @'CanDeriveConstraintsB' 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 f@ can contain fields of type @b f@ as long as there exists a -- @'ConstraintsB' b@ instance. In particular, recursive usages of @B f@ -- are allowed. type CanDeriveConstraintsB c b f = ( GenericN (b f) , GenericN (b (Dict c `Product` f)) , AllB c b ~ GAll 0 c (GAllRepB b) , GConstraints 0 c f (GAllRepB b) (RepN (b f)) (RepN (b (Dict c `Product` f))) ) -- | The representation used for the generic computation of the @'AllB' c b@ -- constraints. type GAllRepB b = TagSelf0 b -- =============================================================== -- Generic derivations -- =============================================================== -- | Default implementation of 'baddDicts' based on 'Generic'. gbaddDictsDefault :: forall b c f . ( CanDeriveConstraintsB c b f , AllB c b ) => b f -> b (Dict c `Product` f) gbaddDictsDefault = toN . gaddDicts @0 @c @f @(GAllRepB b) . fromN {-# INLINE gbaddDictsDefault #-} -- ------------------------------------------------------------ -- Generic derivation: Special cases for ConstraintsB -- ----------------------------------------------------------- type P = Param -- Break recursive case type instance GAll 0 c (Self (b' (P 0 X)) (b X)) = () instance ( ConstraintsB b , AllB c b ) => -- b' is b with maybe some Param occurrences GConstraints 0 c f (Self (b' (P 0 X)) (b X)) (Rec (b' (P 0 f)) (b f)) (Rec (b' (P 0 (Dict c `Product` f))) (b (Dict c `Product` f))) where gaddDicts = Rec . K1 . baddDicts . unK1 . unRec {-# INLINE gaddDicts #-} type instance GAll 0 c (Other (b' (P 0 X)) (b X)) = AllB c b instance ( ConstraintsB b , AllB c b ) => -- b' is b with maybe some Param occurrences GConstraints 0 c f (Other (b' (P 0 X)) (b X)) (Rec (b' (P 0 f)) (b f)) (Rec (b' (P 0 (Dict c `Product` f))) (b (Dict c `Product` f))) where gaddDicts = Rec . K1 . baddDicts . unK1 . unRec {-# INLINE gaddDicts #-} -- -------------------------------- -- Instances for base types -- -------------------------------- instance ConstraintsB Proxy where type AllB c Proxy = () baddDicts _ = Proxy {-# INLINE baddDicts #-} instance (ConstraintsB a, ConstraintsB b) => ConstraintsB (Product a b) where type AllB c (Product a b) = (AllB c a, AllB c b) baddDicts (Pair x y) = Pair (baddDicts x) (baddDicts y) {-# INLINE baddDicts #-} instance (ConstraintsB a, ConstraintsB b) => ConstraintsB (Sum a b) where type AllB c (Sum a b) = (AllB c a, AllB c b) baddDicts (InL x) = InL (baddDicts x) baddDicts (InR x) = InR (baddDicts x) {-# INLINE baddDicts #-} instance ConstraintsB (Const a) where type AllB c (Const a) = () baddDicts (Const x) = Const x {-# INLINE baddDicts #-} instance (Functor f, ConstraintsB b) => ConstraintsB (f `Compose` b) where type AllB c (f `Compose` b) = AllB c b baddDicts (Compose x) = Compose (baddDicts <$> x) {-# INLINE baddDicts #-} -- ============================================================================ -- ## Identifying recursive usages of the barbie-type ## -- ============================================================================ -- | We use the type-families to generically compute @'Barbies.AllB' c b@. -- Intuitively, if @b' f'@ occurs inside @b f@, then we should just add -- @'Barbies.AllB' b' c@ to @'Barbies.AllB' b c@. The problem is that if @b@ -- is a recursive type, and @b'@ is @b@, then ghc will choke and blow the stack -- (instead of computing a fixpoint). -- -- So, we would like to behave differently when @b = b'@ and add @()@ instead -- of @'Barbies.AllB' b c@ to break the recursion. Our trick will be to use a type -- family to inspect @'Rep' (b X)@, for an arbitrary @X@, and distinguish -- recursive usages from non-recursive ones, tagging them with different types, -- so we can distinguish them in the instances. type TagSelf0 b = TagSelf0' (Indexed b 1) (RepN (b X)) type family TagSelf0' (b :: kf -> Type) (repbf :: Type -> Type) :: Type -> Type where TagSelf0' b (M1 mt m s) = M1 mt m (TagSelf0' b s) TagSelf0' b (l :+: r) = TagSelf0' b l :+: TagSelf0' b r TagSelf0' b (l :*: r) = TagSelf0' b l :*: TagSelf0' b r TagSelf0' (b :: kf -> Type) (Rec ((b' :: kf -> Type) f) ((b'' :: kf -> Type) g) ) = (SelfOrOther b b') (b' f) (b'' g) TagSelf0' b (Rec x y) = Rec x y TagSelf0' b U1 = U1 TagSelf0' b V1 = V1 barbies-2.0.5.0/src/Barbies/Internal/ConstraintsT.hs0000644000000000000000000002253414071526417020367 0ustar0000000000000000{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module Barbies.Internal.ConstraintsT ( ConstraintsT(..) , tmapC , ttraverseC , AllTF , tdicts , tpureC , tmempty , tzipWithC , tzipWith3C , tzipWith4C , tfoldMapC , CanDeriveConstraintsT , gtaddDictsDefault , GAllRepT , TagSelf1, TagSelf1' ) where import Barbies.Internal.ApplicativeT(ApplicativeT (..)) import Barbies.Generics.Constraints ( GConstraints(..) , GAll , Self, Other, SelfOrOther , X, Y ) import Barbies.Internal.Dicts(ClassF, Dict (..), requiringDict) import Barbies.Internal.FunctorT(FunctorT (..)) import Barbies.Internal.TraversableT(TraversableT (..)) import Data.Functor.Const(Const(..)) import Data.Functor.Product(Product(..)) import Data.Kind(Constraint, Type) import Data.Proxy(Proxy(..)) import Data.Generics.GenericN -- | Instances of this class provide means to talk about constraints, -- both at compile-time, using 'AllT', and at run-time, in the form -- of 'Dict', via 'taddDicts'. -- -- A manual definition would look like this: -- -- @ -- data T f a = A (f 'Int') (f 'String') | B (f 'Bool') (f 'Int') -- -- instance 'ConstraintsT' T where -- type 'AllT' c T = (c 'Int', c 'String', c 'Bool') -- -- 'taddDicts' t = case t of -- A x y -> A ('Pair' 'Dict' x) ('Pair' 'Dict' y) -- B z w -> B ('Pair' 'Dict' z) ('Pair' 'Dict' w) -- @ -- -- Now, when we given a @T f@, if we need to use the 'Show' instance of -- their fields, we can use: -- -- @ -- 'taddDicts' :: AllT Show t => t f -> t ('Dict' 'Show' `'Product'` f) -- @ -- -- There is a default implementation of 'ConstraintsT' for -- 'Generic' types, so in practice one will simply do: -- -- @ -- derive instance 'Generic' (T f a) -- instance 'ConstraintsT' T -- @ class FunctorT t => ConstraintsT (t :: (kl -> Type) -> (kr -> Type)) where -- | @'AllT' c t@ should contain a constraint @c a@ for each -- @a@ occurring under an @f@ in @t f@. -- -- For requiring constraints of the form @c (f a)@, use 'AllTF'. type AllT (c :: k -> Constraint) t :: Constraint type AllT c t = GAll 1 c (GAllRepT t) taddDicts :: forall c f x . AllT c t => t f x -> t (Dict c `Product` f) x default taddDicts :: forall c f x . ( CanDeriveConstraintsT c t f x , AllT c t ) => t f x -> t (Dict c `Product` f) x taddDicts = gtaddDictsDefault -- | Like 'tmap' but a constraint is allowed to be required on -- each element of @t@. tmapC :: forall c t f g x . (AllT c t, ConstraintsT t) => (forall a. c a => f a -> g a) -> t f x -> t g x tmapC f tf = tmap go (taddDicts tf) where go :: forall a. (Dict c `Product` f) a -> g a go (d `Pair` fa) = requiringDict (f fa) d -- | Like 'ttraverse' but with a constraint on the elements of @t@. ttraverseC :: forall c t f g e x . (TraversableT t, ConstraintsT t, AllT c t, Applicative e) => (forall a. c a => f a -> e (g a)) -> t f x -> e (t g x) ttraverseC f t = ttraverse (\(Pair (Dict :: Dict c a) x) -> f x) (taddDicts t) -- | Like 'Data.Functor.Transformer.tfoldMap' but with a constraint on the function. tfoldMapC :: forall c t m f x . (TraversableT t, ConstraintsT t, AllT c t, Monoid m) => (forall a. c a => f a -> m) -> t f x -> m tfoldMapC f = getConst . ttraverseC @c (Const . f) -- | Like 'Data.Functor.Barbie.tzipWith' but with a constraint on the elements of @t@. tzipWithC :: forall c t f g h x . (AllT c t, ConstraintsT t, ApplicativeT t) => (forall a. c a => f a -> g a -> h a) -> t f x -> t g x -> t h x tzipWithC f tf tg = tmapC @c go (tf `tprod` tg) where go :: forall a. c a => Product f g a -> h a go (Pair fa ga) = f fa ga -- | Like 'Data.Functor.Barbie.tzipWith3' but with a constraint on the elements of @t@. tzipWith3C :: forall c t f g h i x . (AllT c t, ConstraintsT t, ApplicativeT t) => (forall a. c a => f a -> g a -> h a -> i a) -> t f x -> t g x -> t h x -> t i x tzipWith3C f tf tg th = tmapC @c go (tf `tprod` tg `tprod` th) where go :: forall a. c a => Product (Product f g) h a -> i a go (Pair (Pair fa ga) ha) = f fa ga ha -- | Like 'Data.Functor.Barbie.tzipWith4' but with a constraint on the elements of @t@. tzipWith4C :: forall c t f g h i j x . (AllT c t, ConstraintsT t, ApplicativeT t) => (forall a. c a => f a -> g a -> h a -> i a -> j a) -> t f x -> t g x -> t h x -> t i x -> t j x tzipWith4C f tf tg th ti = tmapC @c go (tf `tprod` tg `tprod` th `tprod` ti) where go :: forall a. c a => Product (Product (Product f g) h) i a -> j a go (Pair (Pair (Pair fa ga) ha) ia) = f fa ga ha ia -- | Similar to 'AllT' but will put the functor argument @f@ -- between the constraint @c@ and the type @a@. type AllTF c f t = AllT (ClassF c f) t -- | Similar to 'taddDicts' but can produce the instance dictionaries -- "out of the blue". tdicts :: forall c t x . (ConstraintsT t, ApplicativeT t, AllT c t) => t (Dict c) x tdicts = tmap (\(Pair c _) -> c) $ taddDicts $ tpure Proxy -- | Like 'tpure' but a constraint is allowed to be required on -- each element of @t@. tpureC :: forall c f t x . ( AllT c t , ConstraintsT t , ApplicativeT t ) => (forall a . c a => f a) -> t f x tpureC fa = tmap (requiringDict @c fa) tdicts -- | Builds a @t f x@, by applying 'mempty' on every field of @t@. tmempty :: forall f t x . ( AllTF Monoid f t , ConstraintsT t , ApplicativeT t ) => t f x tmempty = tpureC @(ClassF Monoid f) mempty -- | @'CanDeriveConstraintsT' T f g x@ is in practice a predicate about @T@ only. -- Intuitively, it says that the following holds, for any arbitrary @f@ and @x@: -- -- * There is an instance of @'Generic' (T f x)@. -- -- * @T f@ can contain fields of type @t f x@ as long as there exists a -- @'ConstraintsT' t@ instance. In particular, recursive usages of @T f x@ -- are allowed. type CanDeriveConstraintsT c t f x = ( GenericN (t f x) , GenericN (t (Dict c `Product` f) x) , AllT c t ~ GAll 1 c (GAllRepT t) , GConstraints 1 c f (GAllRepT t) (RepN (t f x)) (RepN (t (Dict c `Product` f) x)) ) -- | The representation used for the generic computation of the @'AllT' c t@ -- constraints. . type GAllRepT t = TagSelf1 t -- =============================================================== -- Generic derivations -- =============================================================== -- | Default implementation of ibaddDicts' based on 'Generic'. gtaddDictsDefault :: forall t c f x . ( CanDeriveConstraintsT c t f x , AllT c t ) => t f x -> t (Dict c `Product` f) x gtaddDictsDefault = toN . gaddDicts @1 @c @f @(GAllRepT t) . fromN {-# INLINE gtaddDictsDefault #-} -- ------------------------------------------------------------ -- Generic derivation: Special cases for ConstraintsT -- ----------------------------------------------------------- type P = Param -- Break recursive case type instance GAll 1 c (Self (t' (P 1 X) Y) (t X Y)) = () instance ( ConstraintsT t , AllT c t ) => -- t' is t, maybe with some Param occurrences GConstraints 1 c f (Self (t' (P 1 X) Y) (t X Y)) (Rec (t' (P 1 f) (P 0 y)) (t f y)) (Rec (t' (P 1 (Dict c `Product` f)) (P 0 y)) (t (Dict c `Product` f) y)) where gaddDicts = Rec . K1 . taddDicts . unK1 . unRec {-# INLINE gaddDicts #-} type instance GAll 1 c (Other (t' (P 1 X) Y) (t X Y)) = AllT c t instance ( ConstraintsT t , AllT c t ) => -- t' is t maybe with some Param occurrences GConstraints 1 c f (Other (t' (P 1 X) Y) (t X Y)) (Rec (t' (P 1 f) (P 0 y)) (t f y)) (Rec (t' (P 1 (Dict c `Product` f)) (P 0 y)) (t (Dict c `Product` f) y)) where gaddDicts = Rec . K1 . taddDicts . unK1 . unRec {-# INLINE gaddDicts #-} -- | We use the type-families to generically compute @'Barbies.AllT' c b@. -- Intuitively, if @t' f' x'@ occurs inside @t f x@, then we should just add -- @'Barbies.AllT' t' c@ to @'Barbies.AllT' t c@. The problem is that if @t@ -- is a recursive type, and @t'@ is @t@, then ghc will choke and blow the -- stack (instead of computing a fixpoint). -- -- So, we would like to behave differently when @t = t'@ and add @()@ instead -- of @'Barbies.AllT' t c@ to break the recursion. Our trick will be to use a -- type family to inspect @'Rep' (t X Y)@, for arbitrary @X@ and @Y@ and -- distinguish recursive usages from non-recursive ones, tagging them with -- different types, so we can distinguish them in the instances. type TagSelf1 b = TagSelf1' (Indexed b 2) (Zip (Rep (Indexed (b X) 1 Y)) (Rep (b X Y))) type family TagSelf1' (b :: kf -> kg -> Type) (repbf :: Type -> Type) :: Type -> Type where TagSelf1' b (M1 mt m s) = M1 mt m (TagSelf1' b s) TagSelf1' b (l :+: r) = TagSelf1' b l :+: TagSelf1' b r TagSelf1' b (l :*: r) = TagSelf1' b l :*: TagSelf1' b r TagSelf1' (b :: kf -> kg -> Type) (Rec ((b' :: kf -> kg -> Type) fl fr) ((b'' :: kf -> kg -> Type) gl gr) ) = (SelfOrOther b b') (b' fl gr) (b'' gl gr) TagSelf1' b (Rec x y) = Rec x y TagSelf1' b U1 = U1 TagSelf1' b V1 = V1 barbies-2.0.5.0/src/Barbies/Internal/Containers.hs0000644000000000000000000000506313546116165020040 0ustar0000000000000000{-# LANGUAGE UndecidableInstances #-} module Barbies.Internal.Containers ( Container(..) , ErrorContainer(..) ) where import Data.Functor.Barbie import Data.Bifunctor (first) import Data.Bitraversable (bitraverse) import Data.Functor.Const import GHC.Generics (Generic) -- {{ Container --------------------------------------------------------------- -- | Wrapper for barbies that act as containers of @a@ -- by wearing @('Const' a)@. newtype Container b a = Container { getContainer :: b (Const a) } deriving (Generic) deriving instance Eq (b (Const a)) => Eq (Container b a) deriving instance Ord (b (Const a)) => Ord (Container b a) deriving instance Read (b (Const a)) => Read (Container b a) deriving instance Show (b (Const a)) => Show (Container b a) instance FunctorB b => Functor (Container b) where fmap f = Container . (bmap (first f)) . getContainer instance TraversableB b => Foldable (Container b) where foldMap f = bfoldMap (f . getConst) . getContainer instance TraversableB b => Traversable (Container b) where traverse f = fmap Container . btraverse (bitraverse f pure) . getContainer instance ApplicativeB b => Applicative (Container b) where pure a = Container $ bpure (Const a) l <*> r = Container $ bzipWith appConst (getContainer l) (getContainer r) where appConst :: Const (a -> a') x -> Const a x -> Const a' x appConst (Const f) (Const a) = Const (f a) -- }} Container --------------------------------------------------------------- -- {{ ErrorContainer ---------------------------------------------------------- -- | Wrapper for barbies that act as containers of @e@ -- by wearing @'Either' e@. newtype ErrorContainer b e = ErrorContainer { getErrorContainer :: b (Either e) } deriving (Generic) deriving instance Eq (b (Either e)) => Eq (ErrorContainer b e) deriving instance Ord (b (Either e)) => Ord (ErrorContainer b e) deriving instance Read (b (Either e)) => Read (ErrorContainer b e) deriving instance Show (b (Either e)) => Show (ErrorContainer b e) instance FunctorB b => Functor (ErrorContainer b) where fmap f = ErrorContainer . (bmap (first f)) . getErrorContainer instance TraversableB b => Foldable (ErrorContainer b) where foldMap f = bfoldMap (either f (const mempty)) . getErrorContainer instance TraversableB b => Traversable (ErrorContainer b) where traverse f = fmap ErrorContainer . btraverse (bitraverse f pure) . getErrorContainer -- }} ErrorContainer ---------------------------------------------------------- barbies-2.0.5.0/src/Barbies/Internal/Dicts.hs0000644000000000000000000000300213606566611016772 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} module Barbies.Internal.Dicts ( Dict(..) , requiringDict , ClassF , ClassFG ) where import Data.Functor.Classes (Show1(..)) -- | @'Dict' c a@ is evidence that there exists an instance of @c a@. -- -- It is essentially equivalent to @Dict (c a)@ from the -- package, -- but because of its kind, it allows us to define things like @'Dict' 'Show'@. data Dict c a where Dict :: c a => Dict c a instance Eq (Dict c a) where _ == _ = True instance Show (Dict c a) where showsPrec _ Dict = showString "Dict" instance Show1 (Dict c) where liftShowsPrec _ _ = showsPrec -- | Turn a constrained-function into an unconstrained one -- that uses the packed instance dictionary instead. requiringDict :: (c a => r) -> (Dict c a -> r) requiringDict r = \Dict -> r -- | 'ClassF' has one universal instance that makes @'ClassF' c f a@ -- equivalent to @c (f a)@. However, we have -- -- @ -- 'ClassF c f :: k -> 'Data.Kind.Constraint' -- @ -- -- This is useful since it allows to define constraint-constructors like -- @'ClassF' 'Monoid' 'Maybe'@ class c (f a) => ClassF c f a where instance c (f a) => ClassF c f a -- | Like 'ClassF' but for binary relations. class c (f a) (g a) => ClassFG c f g a where instance c (f a) (g a) => ClassFG c f g a barbies-2.0.5.0/src/Barbies/Internal/DistributiveB.hs0000644000000000000000000001372014035406146020504 0ustar0000000000000000{-# 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 #-} barbies-2.0.5.0/src/Barbies/Internal/DistributiveT.hs0000644000000000000000000002063514347142124020530 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# 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 (..)) #if MIN_VERSION_transformers(0,5,3) import Control.Monad.Trans.Accum(AccumT(..), runAccumT) #endif 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 -- -- -------------------------------- #if MIN_VERSION_transformers(0,5,3) instance DistributiveT (AccumT w) where tdistribute fh = AccumT $ \w -> Compose $ fmap (\h -> runAccumT h w) fh {-# INLINE tdistribute #-} #endif 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 #-} barbies-2.0.5.0/src/Barbies/Internal/FunctorB.hs0000644000000000000000000000765113606566611017464 0ustar0000000000000000{-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} module Barbies.Internal.FunctorB ( FunctorB(..) , gbmapDefault , CanDeriveFunctorB ) where import Barbies.Generics.Functor (GFunctor(..)) import Data.Functor.Compose (Compose (..)) import Data.Functor.Const (Const (..)) import Data.Functor.Constant (Constant (..)) import Data.Functor.Product (Product (..)) import Data.Functor.Sum (Sum (..)) import Data.Generics.GenericN import Data.Proxy (Proxy (..)) import Data.Kind (Type) -- | Barbie-types that can be mapped over. Instances of 'FunctorB' should -- satisfy the following laws: -- -- @ -- 'bmap' 'id' = 'id' -- 'bmap' f . 'bmap' g = 'bmap' (f . g) -- @ -- -- There is a default 'bmap' implementation for 'Generic' types, so -- instances can derived automatically. class FunctorB (b :: (k -> Type) -> Type) where bmap :: (forall a . f a -> g a) -> b f -> b g default bmap :: forall f g . CanDeriveFunctorB b f g => (forall a . f a -> g a) -> b f -> b g bmap = gbmapDefault -- | @'CanDeriveFunctorB' 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 f@ can contain fields of type @b f@ as long as there exists a -- @'FunctorB' b@ instance. In particular, recursive usages of @B f@ -- are allowed. -- -- * @B f@ can also contain usages of @b f@ under a @'Functor' h@. -- For example, one could use @'Maybe' (B f)@ when defining @B f@. type CanDeriveFunctorB b f g = ( GenericP 0 (b f) , GenericP 0 (b g) , GFunctor 0 f g (RepP 0 (b f)) (RepP 0 (b g)) ) -- | Default implementation of 'bmap' based on 'Generic'. gbmapDefault :: CanDeriveFunctorB b f g => (forall a . f a -> g a) -> b f -> b g gbmapDefault f = toP (Proxy @0) . gmap (Proxy @0) f . fromP (Proxy @0) {-# INLINE gbmapDefault #-} -- ------------------------------------------------------------ -- Generic derivation: Special cases for FunctorB -- ----------------------------------------------------------- type P = Param -- b' is b, maybe with 'Param' annotations instance ( FunctorB b ) => GFunctor 0 f g (Rec (b' (P 0 f)) (b f)) (Rec (b' (P 0 g)) (b g)) where gmap _ h (Rec (K1 bf)) = Rec (K1 (bmap h bf)) {-# INLINE gmap #-} -- h' and b' are essentially h and b, but maybe -- with 'Param' annotations instance ( Functor h , FunctorB b ) => GFunctor 0 f g (Rec (h' (b' (P 0 f))) (h (b f))) (Rec (h' (b' (P 0 g))) (h (b g))) where gmap _ h (Rec (K1 hbf)) = Rec (K1 (fmap (bmap h) hbf)) {-# INLINE gmap #-} -- This is the same as the previous instance, but for nested (normal-flavoured) -- functors. instance ( Functor h , Functor m , FunctorB b ) => GFunctor 0 f g (Rec (m' (h' (b' (P 0 f)))) (m (h (b f)))) (Rec (m' (h' (b' (P 0 g)))) (m (h (b g)))) where gmap _ h (Rec (K1 hbf)) = Rec (K1 (fmap (fmap (bmap h)) hbf)) {-# INLINE gmap #-} -- -------------------------------- -- Instances for base types -- -------------------------------- instance FunctorB Proxy where bmap _ _ = Proxy {-# INLINE bmap #-} instance (FunctorB a, FunctorB b) => FunctorB (Product a b) where bmap f (Pair x y) = Pair (bmap f x) (bmap f y) {-# INLINE bmap #-} instance (FunctorB a, FunctorB b) => FunctorB (Sum a b) where bmap f (InL x) = InL (bmap f x) bmap f (InR x) = InR (bmap f x) {-# INLINE bmap #-} instance FunctorB (Const x) where bmap _ (Const x) = Const x {-# INLINE bmap #-} instance (Functor f, FunctorB b) => FunctorB (f `Compose` b) where bmap h (Compose x) = Compose (bmap h <$> x) {-# INLINE bmap #-} -- -------------------------------- -- Instances for transformer types -- -------------------------------- instance FunctorB (Constant x) where bmap _ (Constant x) = Constant x {-# INLINE bmap #-} barbies-2.0.5.0/src/Barbies/Internal/FunctorT.hs0000644000000000000000000001317014347140202017462 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module Barbies.Internal.FunctorT ( FunctorT(..) , gtmapDefault , CanDeriveFunctorT ) where import Barbies.Generics.Functor (GFunctor(..)) import Control.Applicative.Backwards(Backwards (..)) import Control.Applicative.Lift(Lift, mapLift ) #if MIN_VERSION_transformers(0,5,3) import Control.Monad.Trans.Accum(AccumT, mapAccumT) #endif import Control.Monad.Trans.Except(ExceptT, mapExceptT) import Control.Monad.Trans.Identity(IdentityT, mapIdentityT) import Control.Monad.Trans.Maybe(MaybeT, mapMaybeT) import Control.Monad.Trans.RWS.Lazy as Lazy (RWST, mapRWST) import Control.Monad.Trans.RWS.Strict as Strict (RWST, mapRWST) import Control.Monad.Trans.Reader(ReaderT, mapReaderT) import Control.Monad.Trans.State.Lazy as Lazy (StateT, mapStateT) import Control.Monad.Trans.State.Strict as Strict (StateT, mapStateT) import Control.Monad.Trans.Writer.Lazy as Lazy (WriterT, mapWriterT) import Control.Monad.Trans.Writer.Strict as Strict (WriterT, mapWriterT) import Data.Functor.Compose (Compose (..)) import Data.Functor.Product (Product (..)) import Data.Functor.Reverse (Reverse (..)) import Data.Functor.Sum (Sum (..)) import Data.Generics.GenericN import Data.Proxy (Proxy (..)) import Data.Kind (Type) -- | Functor from indexed-types to indexed-types. Instances of 'FunctorT' should -- satisfy the following laws: -- -- @ -- 'tmap' 'id' = 'id' -- 'tmap' f . 'tmap' g = 'tmap' (f . g) -- @ -- -- There is a default 'tmap' implementation for 'Generic' types, so -- instances can derived automatically. class FunctorT (t :: (k -> Type) -> k' -> Type) where tmap :: (forall a . f a -> g a) -> t f x -> t g x default tmap :: forall f g x . CanDeriveFunctorT t f g x => (forall a . f a -> g a) -> t f x -> t g x tmap = gtmapDefault -- | @'CanDeriveFunctorT' T f g x@ is in practice a predicate about @T@ only. -- Intuitively, it says that the following holds, for any arbitrary @f@: -- -- * There is an instance of @'Generic' (T f)@. -- -- * @T f x@ can contain fields of type @t f y@ as long as there exists a -- @'FunctorT' t@ instance. In particular, recursive usages of @T f y@ -- are allowed. -- -- * @T f x@ can also contain usages of @t f y@ under a @'Functor' h@. -- For example, one could use @'Maybe' (T f y)@ when defining @T f y@. type CanDeriveFunctorT t f g x = ( GenericP 1 (t f x) , GenericP 1 (t g x) , GFunctor 1 f g (RepP 1 (t f x)) (RepP 1 (t g x)) ) -- | Default implementation of 'tmap' based on 'Generic'. gtmapDefault :: CanDeriveFunctorT t f g x => (forall a . f a -> g a) -> t f x -> t g x gtmapDefault f = toP (Proxy @1) . gmap (Proxy @1) f . fromP (Proxy @1) {-# INLINE gtmapDefault #-} -- ------------------------------------------------------------ -- Generic derivation: Special cases for FunctorT -- ----------------------------------------------------------- type P = Param instance ( FunctorT t ) => GFunctor 1 f g (Rec (t (P 1 f) x) (t f x)) (Rec (t (P 1 g) x) (t g x)) where gmap _ h (Rec (K1 tf)) = Rec (K1 (tmap h tf)) {-# INLINE gmap #-} instance ( Functor h , FunctorT t ) => GFunctor 1 f g (Rec (h (t (P 1 f) x)) (h (t f x))) (Rec (h (t (P 1 g) x)) (h (t g x))) where gmap _ h (Rec (K1 htf)) = Rec (K1 (fmap (tmap h) htf)) {-# INLINE gmap #-} -- This is the same as the previous instance, but for nested (normal-flavoured) -- functors. instance ( Functor h , Functor m , FunctorT t ) => GFunctor 1 f g (Rec (m (h (t (P 1 f) x))) (m (h (t f x)))) (Rec (m (h (t (P 1 g) x))) (m (h (t g x)))) where gmap _ h (Rec (K1 mhtf)) = Rec (K1 (fmap (fmap (tmap h)) mhtf)) {-# INLINE gmap #-} -- -------------------------------- -- Instances for base types -- -------------------------------- instance Functor f => FunctorT (Compose f) where tmap h (Compose fga) = Compose (fmap h fga) {-# INLINE tmap #-} instance FunctorT (Product f) where tmap h (Pair fa ga) = Pair fa (h ga) {-# INLINE tmap #-} instance FunctorT (Sum f) where tmap h = \case InL fa -> InL fa InR ga -> InR (h ga) {-# INLINE tmap #-} -- -------------------------------- -- Instances for transformers types -- -------------------------------- #if MIN_VERSION_transformers(0,5,3) instance FunctorT (AccumT w) where tmap h = mapAccumT h {-# INLINE tmap #-} #endif instance FunctorT Backwards where tmap h (Backwards fa) = Backwards (h fa) {-# INLINE tmap #-} instance FunctorT Reverse where tmap h (Reverse fa) = Reverse (h fa) {-# INLINE tmap #-} instance FunctorT Lift where tmap h = mapLift h {-# INLINE tmap #-} instance FunctorT (ExceptT e) where tmap h = mapExceptT h {-# INLINE tmap #-} instance FunctorT IdentityT where tmap h = mapIdentityT h {-# INLINE tmap #-} instance FunctorT MaybeT where tmap h = mapMaybeT h {-# INLINE tmap #-} instance FunctorT (Lazy.RWST r w s) where tmap h = Lazy.mapRWST h {-# INLINE tmap #-} instance FunctorT (Strict.RWST r w s) where tmap h = Strict.mapRWST h {-# INLINE tmap #-} instance FunctorT (ReaderT r) where tmap h = mapReaderT h {-# INLINE tmap #-} instance FunctorT (Lazy.StateT s) where tmap h = Lazy.mapStateT h {-# INLINE tmap #-} instance FunctorT (Strict.StateT s) where tmap h = Strict.mapStateT h {-# INLINE tmap #-} instance FunctorT (Lazy.WriterT w) where tmap h = Lazy.mapWriterT h {-# INLINE tmap #-} instance FunctorT (Strict.WriterT w) where tmap h = Strict.mapWriterT h {-# INLINE tmap #-} barbies-2.0.5.0/src/Barbies/Internal/MonadT.hs0000644000000000000000000000753613606566611017126 0ustar0000000000000000{-# LANGUAGE PolyKinds #-} module Barbies.Internal.MonadT ( MonadT(..) ) where import Barbies.Internal.FunctorT(FunctorT(..)) import Control.Applicative (Alternative(..)) import Control.Applicative.Lift as Lift (Lift(..)) import Control.Applicative.Backwards as Backwards (Backwards(..)) import Control.Monad (join) import Control.Monad.Trans.Identity(IdentityT(..)) import Control.Monad.Trans.Reader(ReaderT(..)) import Data.Coerce (coerce) import Data.Functor.Compose (Compose(..)) import Data.Functor.Reverse (Reverse(..)) import Data.Functor.Product (Product(..)) import Data.Functor.Sum (Sum(..)) -- | Some endo-functors on indexed-types are monads. Common examples would be -- "functor-transformers", like 'Compose' or 'ReaderT'. In that sense, 'MonadT' -- is similar to 'Control.Monad.Trans.Class.MonadTrans' but with additional -- structure (see also 's -- @MMonad@ class). -- -- Notice though that while 'Control.Monad.Trans.Class.lift' assumes -- a 'Monad' instance of the value to be lifted, 'tlift' has no such constraint. -- This means we cannot have instances for most "monad transformers", since -- lifting typically involves an 'fmap'. -- -- 'MonadT' also corresponds to the indexed-monad of -- . -- -- Instances of this class should to satisfy the monad laws. They laws can stated -- either in terms of @('tlift', 'tjoin')@ or @('tlift', 'tembed')@. In the former: -- -- @ -- 'tmap' h . 'tlift' = 'tlift' . h -- 'tmap' h . 'tjoin' = 'tjoin' . 'tmap' ('tmap' h) -- 'tjoin' . 'tlift' = 'id' -- 'tjoin' . 'tmap tlift' = 'id' -- 'tjoin' . 'tjoin' = 'tjoin' . 'tmap' 'tjoin' -- @ -- -- In the latter: -- -- @ -- 'tembed' f . 'tlift' = f -- 'tembed' 'tlift' = 'id' -- 'tembed' f . 'tembed' g = 'tembed' ('tembed' f . g) -- @ -- class FunctorT t => MonadT t where -- | Lift a functor to a transformed functor. tlift :: f a -> t f a -- | The conventional monad join operator. It is used to remove -- one level of monadic structure, projecting its bound argument -- into the outer level. tjoin :: t (t f) a -> t f a tjoin = tembed id -- | Analogous to @('Control.Monad.=<<')@. tembed :: MonadT t => (forall x. f x -> t g x) -> t f a -> t g a tembed h = tjoin . tmap h {-# MINIMAL tlift, tjoin | tlift, tembed #-} -- -------------------------------- -- Instances for base types -- -------------------------------- instance Monad f => MonadT (Compose f) where tlift = Compose . pure {-# INLINE tlift #-} tjoin (Compose ffga) = Compose (join $ coerce <$> ffga) {-# INLINE tjoin #-} instance Alternative f => MonadT (Product f) where tlift = Pair empty {-# INLINE tlift #-} tjoin (Pair fa (Pair fa' ga)) = Pair (fa <|> fa') ga {-# INLINE tjoin #-} instance MonadT (Sum f) where tlift = InR {-# INLINE tlift #-} tjoin = \case InL fa -> InL fa InR (InL fa) -> InL fa InR (InR ga) -> InR ga -- -------------------------------- -- Instances for transformers types -- -------------------------------- instance MonadT Backwards where tlift = Backwards {-# INLINE tlift #-} tjoin = coerce {-# INLINE tjoin #-} instance MonadT Lift where tlift = Lift.Other {-# INLINE tlift #-} tjoin = \case Lift.Pure a -> Lift.Pure a Lift.Other (Lift.Pure a) -> Lift.Pure a Lift.Other (Lift.Other fa) -> Lift.Other fa {-# INLINE tjoin #-} instance MonadT IdentityT where tlift = coerce {-# INLINE tlift #-} tjoin = coerce {-# INLINE tjoin #-} instance MonadT (ReaderT r) where tlift = ReaderT . const {-# INLINE tlift #-} tjoin rra = ReaderT $ \e -> coerce rra e e {-# INLINE tjoin #-} instance MonadT Reverse where tlift = coerce {-# INLINE tlift #-} tjoin = coerce {-# INLINE tjoin #-} barbies-2.0.5.0/src/Barbies/Internal/TraversableB.hs0000644000000000000000000001334113606566611020307 0ustar0000000000000000{-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} module Barbies.Internal.TraversableB ( TraversableB(..) , btraverse_ , bsequence , bsequence' , bfoldMap , CanDeriveTraversableB , gbtraverseDefault ) where import Barbies.Generics.Traversable(GTraversable(..)) import Barbies.Internal.FunctorB(FunctorB (..)) import Barbies.Internal.Writer(execWr, tell) import Data.Functor (void) import Data.Functor.Compose (Compose (..)) import Data.Functor.Const (Const (..)) import Data.Functor.Constant (Constant (..)) import Data.Functor.Identity (Identity (..)) import Data.Functor.Product (Product (..)) import Data.Functor.Sum (Sum (..)) import Data.Kind (Type) import Data.Generics.GenericN import Data.Proxy (Proxy (..)) -- | Barbie-types that can be traversed from left to right. Instances should -- satisfy the following laws: -- -- @ -- t . 'btraverse' f = 'btraverse' (t . f) -- naturality -- 'btraverse' 'Data.Functor.Identity' = 'Data.Functor.Identity' -- identity -- 'btraverse' ('Compose' . 'fmap' g . f) = 'Compose' . 'fmap' ('btraverse' g) . 'btraverse' f -- composition -- @ -- -- There is a default 'btraverse' implementation for 'Generic' types, so -- instances can derived automatically. class FunctorB b => TraversableB (b :: (k -> Type) -> Type) where btraverse :: Applicative e => (forall a . f a -> e (g a)) -> b f -> e (b g) default btraverse :: ( Applicative e, CanDeriveTraversableB b f g) => (forall a . f a -> e (g a)) -> b f -> e (b g) btraverse = gbtraverseDefault -- | Map each element to an action, evaluate these actions from left to right, -- and ignore the results. btraverse_ :: (TraversableB b, Applicative e) => (forall a. f a -> e c) -> b f -> e () btraverse_ f = void . btraverse (fmap (const $ Const ()) . f) -- | Evaluate each action in the structure from left to right, -- and collect the results. bsequence :: (Applicative e, TraversableB b) => b (Compose e f) -> e (b f) bsequence = btraverse getCompose -- | A version of 'bsequence' with @f@ specialized to 'Identity'. bsequence' :: (Applicative e, TraversableB b) => b e -> e (b Identity) bsequence' = btraverse (fmap Identity) -- | Map each element to a monoid, and combine the results. bfoldMap :: (TraversableB b, Monoid m) => (forall a. f a -> m) -> b f -> m bfoldMap f = execWr . btraverse_ (tell . f) -- | @'CanDeriveTraversableB' B f g@ is in practice a predicate about @B@ only. -- It is analogous to 'Barbies.Internal.FunctorB.CanDeriveFunctorB', so it -- essentially requires the following to hold, for any arbitrary @f@: -- -- * There is an instance of @'Generic' (B f)@. -- -- * @B f@ can contain fields of type @b f@ as long as there exists a -- @'TraversableB' b@ instance. In particular, recursive usages of @B f@ -- are allowed. -- -- * @B f@ can also contain usages of @b f@ under a @'Traversable' h@. -- For example, one could use @'Maybe' (B f)@ when defining @B f@. type CanDeriveTraversableB b f g = ( GenericP 0 (b f) , GenericP 0 (b g) , GTraversable 0 f g (RepP 0 (b f)) (RepP 0 (b g)) ) -- | Default implementation of 'btraverse' based on 'Generic'. gbtraverseDefault :: forall b f g e . (Applicative e, CanDeriveTraversableB b f g) => (forall a . f a -> e (g a)) -> b f -> e (b g) gbtraverseDefault h = fmap (toP (Proxy @0)) . gtraverse (Proxy @0) h . fromP (Proxy @0) {-# INLINE gbtraverseDefault #-} -- ------------------------------------------------------------ -- Generic derivation: Special cases for TraversableB -- ----------------------------------------------------------- type P = Param instance ( TraversableB b ) => GTraversable 0 f g (Rec (b (P 0 f)) (b f)) (Rec (b (P 0 g)) (b g)) where gtraverse _ h = fmap (Rec . K1) . btraverse h . unK1 . unRec {-# INLINE gtraverse #-} instance ( Traversable h , TraversableB b ) => GTraversable 0 f g (Rec (h (b (P 0 f))) (h (b f))) (Rec (h (b (P 0 g))) (h (b g))) where gtraverse _ h = fmap (Rec . K1) . traverse (btraverse h) . unK1 . unRec {-# INLINE gtraverse #-} -- This instance is the same as the previous instance but for nested -- Traversables. instance ( Traversable h , Traversable m , TraversableB b ) => GTraversable 0 f g (Rec (m (h (b (P 0 f)))) (m (h (b f)))) (Rec (m (h (b (P 0 g)))) (m (h (b g)))) where gtraverse _ h = fmap (Rec . K1) . traverse (traverse (btraverse h)) . unK1 . unRec {-# INLINE gtraverse #-} -- ----------------------------------------------------------- -- Instances for base types -- ----------------------------------------------------------- instance TraversableB Proxy where btraverse _ _ = pure Proxy {-# INLINE btraverse #-} instance (TraversableB a, TraversableB b) => TraversableB (Product a b) where btraverse f (Pair x y) = Pair <$> btraverse f x <*> btraverse f y {-# INLINE btraverse #-} instance (TraversableB a, TraversableB b) => TraversableB (Sum a b) where btraverse f (InL x) = InL <$> btraverse f x btraverse f (InR x) = InR <$> btraverse f x {-# INLINE btraverse #-} instance TraversableB (Const a) where btraverse _ (Const x) = pure (Const x) {-# INLINE btraverse #-} instance (Traversable f, TraversableB b) => TraversableB (f `Compose` b) where btraverse h (Compose x) = Compose <$> traverse (btraverse h) x {-# INLINE btraverse #-} -- ----------------------------------------------------------- -- Instances for transformer types -- ----------------------------------------------------------- instance TraversableB (Constant a) where btraverse _ (Constant x) = pure (Constant x) {-# INLINE btraverse #-} barbies-2.0.5.0/src/Barbies/Internal/TraversableT.hs0000644000000000000000000001540514035406146020325 0ustar0000000000000000{-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module Barbies.Internal.TraversableT ( TraversableT(..) , ttraverse_ , tsequence , tsequence' , tfoldMap , CanDeriveTraversableT , ttraverseDefault ) where import Barbies.Generics.Traversable(GTraversable(..)) import Barbies.Internal.FunctorT(FunctorT (..)) import Barbies.Internal.Writer(execWr, tell) import Control.Applicative.Backwards(Backwards (..)) import Control.Applicative.Lift(Lift(..)) import Control.Monad.Trans.Except(ExceptT(..)) import Control.Monad.Trans.Identity(IdentityT(..)) import Control.Monad.Trans.Maybe(MaybeT(..)) import Control.Monad.Trans.Writer.Lazy as Lazy (WriterT(..)) import Control.Monad.Trans.Writer.Strict as Strict (WriterT(..)) import Data.Functor (void) import Data.Functor.Compose (Compose (..)) import Data.Functor.Const (Const (..)) import Data.Functor.Identity (Identity (..)) import Data.Functor.Product (Product (..)) import Data.Functor.Reverse (Reverse (..)) import Data.Functor.Sum (Sum (..)) import Data.Kind (Type) import Data.Generics.GenericN import Data.Proxy (Proxy (..)) -- | Indexed-functors that can be traversed from left to right. Instances should -- satisfy the following laws: -- -- @ -- t . 'ttraverse' f = 'ttraverse' (t . f) -- naturality -- 'ttraverse' 'Data.Functor.Identity' = 'Data.Functor.Identity' -- identity -- 'ttraverse' ('Compose' . 'fmap' g . f) = 'Compose' . 'fmap' ('ttraverse' g) . 'ttraverse' f -- composition -- @ -- -- There is a default 'ttraverse' implementation for 'Generic' types, so -- instances can derived automatically. class FunctorT t => TraversableT (t :: (k -> Type) -> k' -> Type) where ttraverse :: Applicative e => (forall a . f a -> e (g a)) -> t f x -> e (t g x) default ttraverse :: ( Applicative e, CanDeriveTraversableT t f g x) => (forall a . f a -> e (g a)) -> t f x -> e (t g x) ttraverse = ttraverseDefault -- | Map each element to an action, evaluate these actions from left to right, -- and ignore the results. ttraverse_ :: (TraversableT t, Applicative e) => (forall a. f a -> e c) -> t f x -> e () ttraverse_ f = void . ttraverse (fmap (const $ Const ()) . f) -- | Evaluate each action in the structure from left to right, -- and collect the results. tsequence :: (Applicative e, TraversableT t) => t (Compose e f) x -> e (t f x) tsequence = ttraverse getCompose -- | A version of 'tsequence' with @f@ specialized to 'Identity'. tsequence' :: (Applicative e, TraversableT t) => t e x -> e (t Identity x) tsequence' = ttraverse (fmap Identity) -- | Map each element to a monoid, and combine the results. tfoldMap :: ( TraversableT t, Monoid m) => (forall a. f a -> m) -> t f x -> m tfoldMap f = execWr . ttraverse_ (tell . f) -- | @'CanDeriveTraversableT' T f g x@ is in practice a predicate about @T@ only. -- It is analogous to 'Barbies.Internal.FunctorT.CanDeriveFunctorT', so it -- essentially requires the following to hold, for any arbitrary @f@: -- -- * There is an instance of @'Generic' (T f x)@. -- -- * @T f x@ can contain fields of type @t f x@ as long as there exists a -- @'TraversableT' t@ instance. In particular, recursive usages of @T f x@ -- are allowed. -- -- * @T f x@ can also contain usages of @t f x@ under a @'Traversable' h@. -- For example, one could use @'Maybe' (T f x)@ when defining @T f x@. type CanDeriveTraversableT t f g x = ( GenericP 1 (t f x) , GenericP 1 (t g x) , GTraversable 1 f g (RepP 1 (t f x)) (RepP 1 (t g x)) ) -- | Default implementation of 'ttraverse' based on 'Generic'. ttraverseDefault :: forall t f g e x . (Applicative e, CanDeriveTraversableT t f g x) => (forall a . f a -> e (g a)) -> t f x -> e (t g x) ttraverseDefault h = fmap (toP (Proxy @1)) . gtraverse (Proxy @1) h . fromP (Proxy @1) {-# INLINE ttraverseDefault #-} -- ------------------------------------------------------------ -- Generic derivation: Special cases for TraversableT -- ----------------------------------------------------------- type P = Param instance ( TraversableT t ) => GTraversable 1 f g (Rec (t (P 1 f) x) (t f x)) (Rec (t (P 1 g) x) (t g x)) where gtraverse _ h = fmap (Rec . K1) . ttraverse h . unK1 . unRec {-# INLINE gtraverse #-} instance ( Traversable h , TraversableT t ) => GTraversable 1 f g (Rec (h (t (P 1 f) x)) (h (t f x))) (Rec (h (t (P 1 g) x)) (h (t g x))) where gtraverse _ h = fmap (Rec . K1) . traverse (ttraverse h) . unK1 . unRec {-# INLINE gtraverse #-} -- This instance is the same as the previous instance but for nested -- Traversables. instance ( Traversable h , Traversable m , TraversableT t ) => GTraversable 1 f g (Rec (m (h (t (P 1 f) x))) (m (h (t f x)))) (Rec (m (h (t (P 1 g) x))) (m (h (t g x)))) where gtraverse _ h = fmap (Rec . K1) . traverse (traverse (ttraverse h)) . unK1 . unRec {-# INLINE gtraverse #-} -- ----------------------------------------------------------- -- Instances for base types -- ----------------------------------------------------------- instance Traversable f => TraversableT (Compose f) where ttraverse h (Compose fga) = Compose <$> traverse h fga {-# INLINE ttraverse #-} instance TraversableT (Product f) where ttraverse h (Pair fa ga) = Pair fa <$> h ga {-# INLINE ttraverse #-} instance TraversableT (Sum f) where ttraverse h = \case InL fa -> pure $ InL fa InR ga -> InR <$> h ga {-# INLINE ttraverse #-} -- ----------------------------------------------------------- -- Instances for transformers types -- ----------------------------------------------------------- instance TraversableT Backwards where ttraverse h (Backwards fa) = Backwards <$> h fa {-# INLINE ttraverse #-} instance TraversableT Lift where ttraverse h = \case Pure a -> pure $ Pure a Other fa -> Other <$> h fa {-# INLINE ttraverse #-} instance TraversableT Reverse where ttraverse h (Reverse fa) = Reverse <$> h fa {-# INLINE ttraverse #-} instance TraversableT (ExceptT e) where ttraverse h (ExceptT mea) = ExceptT <$> h mea {-# INLINE ttraverse #-} instance TraversableT IdentityT where ttraverse h (IdentityT ma) = IdentityT <$> h ma {-# INLINE ttraverse #-} instance TraversableT MaybeT where ttraverse h (MaybeT mma) = MaybeT <$> h mma {-# INLINE ttraverse #-} instance TraversableT (Lazy.WriterT w) where ttraverse h (Lazy.WriterT maw) = Lazy.WriterT <$> h maw {-# INLINE ttraverse #-} instance TraversableT (Strict.WriterT w) where ttraverse h (Strict.WriterT maw) = Strict.WriterT <$> h maw {-# INLINE ttraverse #-} barbies-2.0.5.0/src/Barbies/Internal/Trivial.hs0000644000000000000000000000256214035406146017341 0ustar0000000000000000{-# LANGUAGE PolyKinds #-} module Barbies.Internal.Trivial ( Void , Unit (..) ) where 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(..)) import Data.Kind (Type) import Data.Typeable (Typeable) import GHC.Generics (Generic) --------------------------------------------------- -- Trivial Barbies --------------------------------------------------- -- | Uninhabited barbie type. data Void (f :: k -> Type) deriving (Generic, Typeable) instance Eq (Void f) where (==) v = case v of instance Ord (Void f) where compare v = case v of instance Show (Void f) where showsPrec _ v = case v of instance Semigroup (Void f) where (<>) v = case v of instance FunctorB Void instance TraversableB Void instance ConstraintsB Void -- | A barbie type without structure. data Unit (f :: k -> Type) = Unit deriving ( Data, Generic, Typeable , Eq, Ord, Read, Show ) instance Semigroup (Unit f) where Unit <> Unit = Unit instance Monoid (Unit f) where mempty = Unit mappend = (<>) instance FunctorB Unit instance DistributiveB Unit instance TraversableB Unit instance ApplicativeB Unit instance ConstraintsB Unit barbies-2.0.5.0/src/Barbies/Internal/Wear.hs0000644000000000000000000000474414035406146016631 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Barbies.Internal.Wear ( Wear, Bare, Covered, WearTwo ) where import GHC.TypeLits (ErrorMessage (..), TypeError) import Data.Generics.GenericN (Param) data Bare data Covered -- | The 'Wear' type-function allows one to define a Barbie-type as -- -- @ -- data B t f -- = B { f1 :: 'Wear' t f 'Int' -- , f2 :: 'Wear' t f 'Bool' -- } -- @ -- -- This gives rise to two rather different types: -- -- * @B 'Covered' f@ is a normal Barbie-type, in the sense that -- @f1 :: B 'Covered' f -> f 'Int'@, etc. -- -- * @B 'Bare' f@, on the other hand, is a normal record with -- no functor around the type: -- -- @ -- B { f1 :: 5, f2 = 'True' } :: B 'Bare' f -- @ type family Wear t f a where Wear Bare f a = a Wear Covered f a = f a Wear (Param _ t) f a = Wear t f a Wear t _ _ = TypeError ( 'Text "`Wear` should only be used with " ':<>: 'Text "`Bare` or `Covered`." ':$$: 'Text "`" ':<>: 'ShowType t ':<>: 'Text "`" ':<>: 'Text " is not allowed in this context." ) -- | Like the `Wear` family, but with two wrappers @f@ and @g@ instead of one. -- This is useful if you have a data-type where @f@ is parametric but @g@ is -- not, consider this: -- -- @ -- data T t f = -- T { f1 :: 'Wear' t f [Bool] -- , f2 :: 'Wear' t f (Sum Int) -- , f3 :: 'WearTwo' t f Sum Int -- , f4 :: 'WearTwo' t f Max Int -- } -- @ -- -- with @x :: T Covered Option@ we would have -- -- @ -- f1 x :: IO (Option [Bool]) -- f2 x :: IO (Option (Sum Int)) -- f3 x :: IO (Option (Sum Int)) -- f4 x :: IO (Option (Max Int)) -- @ -- -- and with @y :: T Bare Identity@ we would have -- -- @ -- f1 y :: Int -- f2 y :: Sum Int -- f3 y :: Int -- f4 y :: Int -- @ -- -- Note how @(Option (Sum Int))@ (or @Max@) has a nice Semigroup instance that -- we can use to merge two (covered) barbies, -- while `WearTwo` removes the wrapper for the bare barbie. type family WearTwo t f g a where WearTwo Bare f g a = a WearTwo Covered f g a = f (g a) WearTwo (Param _ t) f g a = WearTwo t f g a WearTwo t _ _ _ = TypeError ( 'Text "`WearTwo` should only be used with " ':<>: 'Text "`Bare` or `Covered`." ':$$: 'Text "`" ':<>: 'ShowType t ':<>: 'Text "`" ':<>: 'Text " is not allowed in this context." ) barbies-2.0.5.0/src/Barbies/Internal/Wrappers.hs0000644000000000000000000000241113553036163017525 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Barbies.Internal.Wrappers ( Barbie(..) ) where import Barbies.Internal.ApplicativeB import Barbies.Internal.ConstraintsB import Barbies.Internal.Dicts import Barbies.Internal.FunctorB import Barbies.Internal.TraversableB import Data.Kind (Type) -- | A wrapper for Barbie-types, providing useful instances. newtype Barbie (b :: (k -> Type) -> Type) f = Barbie { getBarbie :: b f } deriving (FunctorB, ApplicativeB) -- Need to derive it manually to make GHC 8.0.2 happy instance ConstraintsB b => ConstraintsB (Barbie b) where type AllB c (Barbie b) = AllB c b baddDicts = Barbie . baddDicts . getBarbie instance TraversableB b => TraversableB (Barbie b) where btraverse f = fmap Barbie . btraverse f . getBarbie 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 (ConstraintsB b, ApplicativeB b, AllBF Semigroup f b, AllBF Monoid f b) => Monoid (Barbie b f) where mempty = bmempty mappend = (<>) barbies-2.0.5.0/src/Barbies/Internal/Writer.hs0000644000000000000000000000207114035406146017176 0ustar0000000000000000module Barbies.Internal.Writer ( Wr , execWr , tell ) where -- --------------------------------------------------------------------- -- We roll our own State/efficient-Writer monad, not to add dependencies -- --------------------------------------------------------------------- newtype St s a = St (s -> (a, s)) runSt :: s -> St s a -> (a, s) runSt s (St f) = f s instance Functor (St s) where fmap f (St g) = St $ (\(a, s') -> (f a, s')) . g {-# INLINE fmap #-} instance Applicative (St s) where pure = St . (,) {-# INLINE pure #-} St l <*> St r = St $ \s -> let (f, s') = l s (x, s'') = r s' in (f x, s'') {-# INLINE (<*>) #-} instance Monad (St s) where return = pure {-# INLINE return #-} St action >>= f = St $ \s -> let (a, s') = action s St go = f a in go s' {-# INLINE (>>=) #-} type Wr = St execWr :: Monoid w => Wr w a -> w execWr = snd . runSt mempty tell :: Monoid w => w -> Wr w () tell w = St (\s -> ((), seq s s `mappend` w)) barbies-2.0.5.0/src/Data/Generics/GenericN.hs0000644000000000000000000000546513606566611016722 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Generics.GenericN -- Copyright : (C) 2018 Csongor Kiss -- License : BSD3 -- Stability : experimental -- Portability : non-portable -- -- Generic representation of types with multiple parameters -- -------------------------------------------------------------------------------- module Data.Generics.GenericN ( Param , Indexed , FilterIndex , Zip , Rec (Rec, unRec) , GenericN (..) , GenericP (..) , module GHC.Generics ) where import Data.Kind import Data.Proxy (Proxy) import GHC.Generics import GHC.TypeLits import Data.Coerce data family Param (n :: Nat) (a :: k) :: k type family Indexed (t :: k) (i :: Nat) :: k where Indexed (t a) i = Indexed t (i + 1) (Param i a) Indexed t _ = t type family FilterIndex (n :: Nat) (t :: k) :: k where FilterIndex n (t (Param n a)) = FilterIndex n t (Param n a) FilterIndex n (t (Param _ a)) = FilterIndex n t a FilterIndex _ t = t newtype Rec (p :: Type) a x = Rec { unRec :: K1 R a x } type family Zip (a :: Type -> Type) (b :: Type -> Type) :: Type -> Type where Zip (M1 mt m s) (M1 mt m t) = M1 mt m (Zip s t) Zip (l :+: r) (l' :+: r') = Zip l l' :+: Zip r r' Zip (l :*: r) (l' :*: r') = Zip l l' :*: Zip r r' Zip (Rec0 p) (Rec0 a) = Rec p a Zip U1 U1 = U1 Zip V1 V1 = V1 class ( Coercible (Rep a) (RepN a) , Generic a ) => GenericN (a :: Type) where type family RepN (a :: Type) :: Type -> Type type instance RepN a = Zip (Rep (Indexed a 0)) (Rep a) toN :: RepN a x -> a fromN :: a -> RepN a x instance ( Coercible (Rep a) (RepN a) , Generic a ) => GenericN a where toN :: forall x. RepN a x -> a toN = coerce (to :: Rep a x -> a) {-# INLINE toN #-} fromN :: forall x. a -> RepN a x fromN = coerce (from :: a -> Rep a x) {-# INLINE fromN #-} class ( Coercible (Rep a) (RepP n a) , Generic a ) => GenericP (n :: Nat) (a :: Type) where type family RepP n a :: Type -> Type type instance RepP n a = Zip (Rep (FilterIndex n (Indexed a 0))) (Rep a) toP :: Proxy n -> RepP n a x -> a fromP :: Proxy n -> a -> RepP n a x instance ( Coercible (Rep a) (RepP n a) , Generic a ) => GenericP (n :: Nat) (a :: Type) where toP :: forall x . Proxy n -> RepP n a x -> a toP _ = coerce (to :: Rep a x -> a) {-# INLINE toP #-} fromP :: forall x . Proxy n -> a -> RepP n a x fromP _ = coerce (from :: a -> Rep a x) {-# INLINE fromP #-} barbies-2.0.5.0/src/Data/Barbie/Internal/Product.hs0000644000000000000000000001140014071527146020030 0ustar0000000000000000{-# 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 #-} barbies-2.0.5.0/src/Data/Barbie/Internal/ProductC.hs0000644000000000000000000000661714035406146020145 0ustar0000000000000000{-# 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 #-} barbies-2.0.5.0/test-legacy/Legacy/Spec.hs0000644000000000000000000001473513554651311016342 0ustar0000000000000000import 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) ] ] barbies-2.0.5.0/test-legacy/Legacy/TestBarbies.hs0000644000000000000000000001663414165352675017671 0ustar0000000000000000{-# 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 barbies-2.0.5.0/test-legacy/Legacy/TestBarbiesW.hs0000644000000000000000000002477114165352675020021 0ustar0000000000000000{-# 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) barbies-2.0.5.0/test-legacy/Legacy/Clothes.hs0000644000000000000000000000766313554651311017053 0ustar0000000000000000{-# 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 _ = " G>" instance Show GH where show _ = " H>" instance Show HI where show _ = " I>" barbies-2.0.5.0/test-legacy/Legacy/Spec/Bare.hs0000644000000000000000000000152613554651311017205 0ustar0000000000000000{-# 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) ] barbies-2.0.5.0/test-legacy/Legacy/Spec/Constraints.hs0000644000000000000000000000225213554651311020640 0ustar0000000000000000{-# 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 barbies-2.0.5.0/test-legacy/Legacy/Spec/Functor.hs0000644000000000000000000000143613554651311017754 0ustar0000000000000000{-# 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) ] barbies-2.0.5.0/test-legacy/Legacy/Spec/Traversable.hs0000644000000000000000000000240413554651311020602 0ustar0000000000000000{-# 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) ] barbies-2.0.5.0/test-legacy/Legacy/Spec/Product.hs0000644000000000000000000000177513554651311017762 0ustar0000000000000000{-# 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 barbies-2.0.5.0/test-legacy/Legacy/Spec/Wrapper.hs0000644000000000000000000000167013554651311017754 0ustar0000000000000000{-# 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 barbies-2.0.5.0/test/Spec.hs0000644000000000000000000002454414035406146013672 0ustar0000000000000000import Test.Tasty (defaultMain, testGroup) 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.Applicative as Applicative import qualified Spec.Traversable as Traversable import qualified Spec.Distributive as Distributive import qualified Spec.Wrapper as Wrapper import TestBarbies import TestBarbiesW import qualified TestBiBarbies as Bi import Barbies(Flip) import Barbies.Bare(Covered) import Control.Applicative ( liftA2 ) import Data.Functor.Barbie(bfoldMap, bmapC, btraverseC, bpureC, bfoldMapC, bzipWithC, bzipWith3C, bzipWith4C) import Data.Functor.Const (Const (..)) import Data.Functor.Identity (Identity (..)) import Data.Monoid (Sum (..)) import Data.Typeable ( Typeable, typeOf ) 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 @Nested2F , Functor.laws @(CompositeRecordW Covered) , Functor.laws @(NestedFW Covered) , Functor.laws @(Nested2FW Covered) , Functor.laws @(ParF Maybe) , Functor.laws @(Flip Bi.Record0 ()) , Functor.laws @(Flip Bi.Record1 ()) , Functor.laws @(Flip Bi.Record3 ()) , Functor.laws @(Flip Bi.Record1S ()) , Functor.laws @(Flip Bi.Record3S ()) , Functor.laws @(Flip Bi.Ignore1 ()) , Functor.laws @(Flip Bi.Sum3 ()) , Functor.laws @(Flip Bi.CompositeRecord ()) , Functor.laws @(Flip Bi.SumRec ()) , Functor.laws @(Flip Bi.NestedF ()) , Functor.laws @(Flip Bi.Nested2F ()) , Functor.laws @(Flip Bi.NestedB Maybe) , Functor.laws @(Bi.MixedBT Maybe) , Functor.laws @(Flip Bi.MixedBT 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" [ 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 @Nested2F , Traversable.laws @(CompositeRecordW Covered) , Traversable.laws @(NestedFW Covered) , Traversable.laws @(Nested2FW Covered) , Traversable.laws @(ParF Maybe) , Traversable.laws @(Flip Bi.Record0 ()) , Traversable.laws @(Flip Bi.Record1 ()) , Traversable.laws @(Flip Bi.Record3 ()) , Traversable.laws @(Flip Bi.Record1S ()) , Traversable.laws @(Flip Bi.Record3S ()) , Traversable.laws @(Flip Bi.Ignore1 ()) , Traversable.laws @(Flip Bi.Sum3 ()) , Traversable.laws @(Flip Bi.CompositeRecord ()) , Traversable.laws @(Flip Bi.SumRec ()) , Traversable.laws @(Flip Bi.NestedF ()) , Traversable.laws @(Flip Bi.Nested2F ()) , Traversable.laws @(Flip Bi.NestedB Maybe) , Traversable.laws @(Bi.MixedBT Maybe) , Traversable.laws @(Flip Bi.MixedBT Maybe) ] , testGroup "Applicative laws" [ Applicative.laws @Record0 , Applicative.laws @Record1 , Applicative.laws @Record3 , Applicative.laws @CompositeRecord , Applicative.laws @NestedF , Applicative.laws @Nested2F , Applicative.laws @Record1S , Applicative.laws @Record3S , Applicative.laws @(Record1W Covered) , Applicative.laws @(Record3W Covered) , Applicative.laws @(CompositeRecordW Covered) , Applicative.laws @(NestedFW Covered) , Applicative.laws @(Nested2FW Covered) , Applicative.laws @(Record1WS Covered) , Applicative.laws @(Record3WS Covered) , Applicative.laws @(ParX (Maybe ())) , Applicative.laws @(ParF Sum) , Applicative.laws @(Flip Bi.Record0 ()) , Applicative.laws @(Flip Bi.Record1 ()) , Applicative.laws @(Flip Bi.Record3 ()) , Applicative.laws @(Flip Bi.Record1S ()) , Applicative.laws @(Flip Bi.Record3S ()) , Applicative.laws @(Flip Bi.CompositeRecord ()) , Applicative.laws @(Flip Bi.NestedF ()) , Applicative.laws @(Flip Bi.Nested2F ()) , Applicative.laws @(Flip (Bi.ParX (Maybe ())) ()) , Applicative.laws @(Bi.MixedBT []) ] , testGroup "addDict 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) , Constraints.lawAddDictPrj @(Bi.MixedBT Maybe) ] , 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") Nothing 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 "bpureC" [ testCase "Record1" $ bpureC @Num (Identity (fromIntegral (42 :: Int))) @?= Record1 (Identity 42) ] , testGroup "bfoldMapC" [ testCase "Record3S" $ do let b = Record3S (Just 22) Nothing (Just 'x') go :: forall a. Typeable a => Maybe a -> Maybe String go = fmap (show . typeOf) bfoldMapC @Typeable go b @?= Just "IntChar" ] , testGroup "bzipWithC" [ testCase "Record1S" $ do let a = Record1S (Just 44) b = Record1S (Just 22) bzipWithC @Num (liftA2 (+)) a b @?= Record1S (Just 66) ] , testGroup "bzipWith3C" [ testCase "Record1S" $ do let a = Record1S (Just 44) b = Record1S (Just 22) c = Record1S (Just 88) go :: forall a. Num a => Maybe a -> Maybe a -> Maybe a -> Maybe a go x y z = liftA2 (+) x $ liftA2 (+) y z bzipWith3C @Num go a b c @?= Record1S (Just 154) ] , testGroup "bzipWith4C" [ testCase "Record1S" $ do let a = Record1S (Just 44) b = Record1S (Just 22) c = Record1S (Just 88) d = Record1S (Just 11) go :: forall a. Num a => Maybe a -> Maybe a -> Maybe a -> Maybe a -> Maybe a go w x y z = liftA2 (+) (liftA2 (+) w x) (liftA2 (+) y z) bzipWith4C @Num go a b c d @?= Record1S (Just 165) ] ] barbies-2.0.5.0/test/TestBarbies.hs0000644000000000000000000002153314315126605015202 0ustar0000000000000000{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module TestBarbies ( Barbies.Void , Record0(..) , Record1(..) , Record3(..) , Record1S(..) , Record3S(..) , Ignore1(..) , Sum3(..) , CompositeRecord(..) , SumRec(..) , InfRec(..) , NestedF(..) , Nested2F(..) , ParX(..) , ParF(..) , HKB(..) ) where import qualified Barbies import Data.Functor.Barbie import Data.Distributive 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 DistributiveB Record0 instance TraversableB Record0 instance ApplicativeB Record0 instance ConstraintsB Record0 instance Arbitrary (Record0 f) where arbitrary = pure Record0 data Record1 f = Record1 { rec1_f1 :: f Int } deriving (Generic, Typeable) instance FunctorB Record1 instance DistributiveB Record1 instance TraversableB Record1 instance ApplicativeB Record1 instance ConstraintsB 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 DistributiveB Record1S instance TraversableB Record1S instance ApplicativeB Record1S instance ConstraintsB 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 , rec3_m1 :: Maybe () } deriving (Generic, Typeable) instance FunctorB Record3 instance TraversableB Record3 instance ApplicativeB Record3 instance ConstraintsB 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 <*> arbitrary data Record3S f = Record3S { rec3s_f1 :: !(f Int) , rec3s_f2 :: !(f Bool) , rec3s_f3 :: !(f Char) } deriving (Generic, Typeable) instance FunctorB Record3S instance DistributiveB Record3S instance TraversableB Record3S instance ApplicativeB Record3S instance ConstraintsB 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_f4 :: Record1 f } deriving (Generic, Typeable) instance FunctorB CompositeRecord instance DistributiveB CompositeRecord instance TraversableB CompositeRecord instance ApplicativeB CompositeRecord instance ConstraintsB 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 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 DistributiveB InfRec instance TraversableB InfRec instance ApplicativeB InfRec instance ConstraintsB 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 (NestedF f) , npg_4 :: Maybe (f Int) } deriving (Generic, Typeable) instance FunctorB NestedF instance TraversableB NestedF instance ApplicativeB NestedF deriving instance (Show (f Int), Show (Record3 f)) => Show (NestedF f) deriving instance (Eq (f Int), Eq (Record3 f)) => Eq (NestedF f) instance (Arbitrary (f Int), AllBF Arbitrary f Record3) => Arbitrary (NestedF f) where arbitrary = scale (`div` 2) $ NestedF <$> arbitrary <*> scale (`div` 2) arbitrary <*> arbitrary <*> arbitrary data Nested2F f = Nested2F { np2f_1 :: f Int , np2f_2 :: [Maybe (Nested2F f)] } deriving (Generic, Typeable) instance FunctorB Nested2F instance TraversableB Nested2F instance ApplicativeB Nested2F deriving instance Show (f Int) => Show (Nested2F f) deriving instance Eq (f Int) => Eq (Nested2F f) instance Arbitrary (f Int) => Arbitrary (Nested2F f) where arbitrary = scale (`div` 2) $ Nested2F <$> arbitrary <*> scale (`div` 2) arbitrary ----------------------------------------------------- -- Parametric barbies ----------------------------------------------------- data ParB b (f :: Type -> Type) = ParB (b f) 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) data ParBH h b (f :: Type -> Type) = ParBH (h (b f)) 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) data ParX a f = ParX (f a) a deriving (Generic, Typeable) instance FunctorB (ParX a) instance TraversableB (ParX a) instance Monoid a => ApplicativeB (ParX a) instance ConstraintsB (ParX a) deriving instance (Show a, Show (f a)) => Show (ParX a f) deriving instance (Eq a, Eq (f a)) => Eq (ParX a f) instance (Arbitrary a, Arbitrary (f a)) => Arbitrary (ParX a f) where arbitrary = ParX <$> arbitrary <*> arbitrary data ParF g f = ParF { pf1 :: g Int , pf2 :: f Int } deriving (Generic, Typeable) instance FunctorB (ParF g) instance TraversableB (ParF g) instance Monoid (g Int) => ApplicativeB (ParF g) instance ConstraintsB (ParF g) deriving instance (Show (g Int), Show (f Int)) => Show (ParF g f) deriving instance (Eq (g Int), Eq (f Int)) => Eq (ParF g f) instance (Arbitrary (g Int), Arbitrary (f Int)) => Arbitrary (ParF g f) where arbitrary = ParF <$> arbitrary <*> arbitrary ----------------------------------------------------- -- Higher-kinded barbies ----------------------------------------------------- data HKB b = HKB { hkb1 :: b Maybe , khb2 :: b ([]) } deriving (Generic, Typeable) instance FunctorB HKB instance TraversableB HKB instance ApplicativeB HKB instance ConstraintsB HKB barbies-2.0.5.0/test/TestBarbiesW.hs0000644000000000000000000002634014165352675015345 0ustar0000000000000000{-# OPTIONS_GHC -O0 #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module TestBarbiesW ( Record1W(..) , Record3W(..) , Record1WS(..) , Record3WS(..) , Sum3W(..) , CompositeRecordW(..) , SumRecW(..) , InfRecW(..) , NestedFW(..) , Nested2FW(..) ) where import Data.Functor.Barbie import Barbies.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 DistributiveB (Record1W Covered) instance TraversableB (Record1W Covered) instance ApplicativeB (Record1W Covered) instance ConstraintsB (Record1W Bare) instance ConstraintsB (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 DistributiveB (Record1WS Covered) instance TraversableB (Record1WS Covered) instance ApplicativeB (Record1WS Covered) instance ConstraintsB (Record1WS Bare) instance ConstraintsB (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 DistributiveB (Record3W Covered) instance TraversableB (Record3W Bare) instance TraversableB (Record3W Covered) instance ApplicativeB (Record3W Covered) instance ConstraintsB (Record3W Bare) instance ConstraintsB (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 DistributiveB (Record3WS Covered) instance TraversableB (Record3WS Covered) instance ApplicativeB (Record3WS Covered) instance ConstraintsB (Record3WS Bare) instance ConstraintsB (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 DistributiveB (CompositeRecordW Covered) instance TraversableB (CompositeRecordW Covered) instance ApplicativeB (CompositeRecordW Covered) instance ConstraintsB (CompositeRecordW Bare) instance ConstraintsB (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 DistributiveB (InfRecW Covered) instance TraversableB (InfRecW Covered) instance ApplicativeB (InfRecW Covered) instance ConstraintsB (InfRecW Bare) instance ConstraintsB (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_4 :: Maybe (NestedFW t f) } deriving (Generic, Typeable) instance FunctorB (NestedFW Bare) instance FunctorB (NestedFW Covered) instance TraversableB (NestedFW Bare) instance TraversableB (NestedFW Covered) instance ApplicativeB (NestedFW Covered) instance BareB NestedFW deriving instance Show (NestedFW Bare f) deriving instance Eq (NestedFW Bare f) deriving instance (Show (f Int), Show (Record3W Covered f)) => Show (NestedFW Covered f) deriving instance (Eq (f Int), Eq (Record3W Covered f)) => Eq (NestedFW Covered f) instance (Arbitrary (f Int), Arbitrary (f Bool), Arbitrary (f Char)) => Arbitrary (NestedFW Covered f) where arbitrary = scale (`div` 2) $ NestedFW <$> arbitrary <*> scale (`div` 2) arbitrary <*> arbitrary data Nested2FW t f = Nested2FW { np2fw_1 :: Wear t f Int , np2fw_2 :: [Maybe (Nested2FW t f)] } deriving (Generic, Typeable) instance FunctorB (Nested2FW Bare) instance FunctorB (Nested2FW Covered) instance TraversableB (Nested2FW Bare) instance TraversableB (Nested2FW Covered) instance ApplicativeB (Nested2FW Covered) instance BareB Nested2FW deriving instance Show (Nested2FW Bare f) deriving instance Eq (Nested2FW Bare f) deriving instance Show (f Int) => Show (Nested2FW Covered f) deriving instance Eq (f Int) => Eq (Nested2FW Covered f) instance Arbitrary (f Int) => Arbitrary (Nested2FW Covered f) where arbitrary = scale (`div` 2) $ Nested2FW <$> arbitrary <*> scale (`div` 2) 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 ApplicativeB (b t) => ApplicativeB (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) 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 (Applicative h, ApplicativeB (b t)) => ApplicativeB (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 DistributiveB (ParXW a Covered) instance TraversableB (ParXW a Covered) instance ApplicativeB (ParXW a Covered) instance ConstraintsB (ParXW a Covered) barbies-2.0.5.0/test/TestBiBarbies.hs0000644000000000000000000002451114165352675015467 0ustar0000000000000000{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module TestBiBarbies ( Record0(..) , Record1(..) , Record3(..) , Record1S(..) , Record3S(..) , Ignore1(..) , Sum3(..) , CompositeRecord(..) , SumRec(..) , InfRec(..) , NestedF(..) , Nested2F(..) , ParX(..) , HKB(..) , NestedB(..) , MixedBT(..) ) where import Barbies import Data.Distributive import qualified TestBarbies import Data.Kind(Type) import Data.Typeable import GHC.Generics import Test.Tasty.QuickCheck instance Arbitrary (b r l) => Arbitrary (Barbies.Flip b l r) where arbitrary = Barbies.Flip <$> arbitrary ---------------------------------------------------- -- Product Barbies ---------------------------------------------------- data Record0 (f :: kl -> Type) (x :: kr) = Record0 deriving ( Generic, Typeable , Eq, Show ) instance FunctorT Record0 instance DistributiveT Record0 instance ApplicativeT Record0 instance TraversableT Record0 instance ConstraintsT Record0 instance Arbitrary (Record0 f g) where arbitrary = pure Record0 data Record1 f (x :: kr) = Record1 { rec1_f1 :: f Int } deriving (Generic, Typeable) instance FunctorT Record1 instance DistributiveT Record1 instance ApplicativeT Record1 instance TraversableT Record1 instance ConstraintsT Record1 deriving instance AllTF Show f Record1 => Show (Record1 f x) deriving instance AllTF Eq f Record1 => Eq (Record1 f x) instance AllTF Arbitrary f Record1 => Arbitrary (Record1 f g) where arbitrary = Record1 <$> arbitrary data Record1S f (x :: kr) = Record1S { rec1s_f1 :: !(f Int) } deriving (Generic, Typeable) instance FunctorT Record1S instance DistributiveT Record1S instance ApplicativeT Record1S instance TraversableT Record1S instance ConstraintsT Record1S deriving instance AllTF Show f Record1S => Show (Record1S f x) deriving instance AllTF Eq f Record1S => Eq (Record1S f x) instance AllTF Arbitrary f Record1S => Arbitrary (Record1S f x) where arbitrary = Record1S <$> arbitrary data Record3 f x = Record3 { rec3_f1 :: f Int , rec3_f2 :: f Bool , rec3_f3 :: f Char , rec3_m1 :: Maybe () } deriving (Generic, Typeable) instance FunctorT Record3 instance ApplicativeT Record3 instance TraversableT Record3 instance ConstraintsT Record3 deriving instance AllTF Show f Record3 => Show (Record3 f x) deriving instance AllTF Eq f Record3 => Eq (Record3 f x) instance AllTF Arbitrary f Record3 => Arbitrary (Record3 f x) where arbitrary = Record3 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary data Record3S f x = Record3S { rec3s_f1 :: !(f Int) , rec3s_f2 :: !(f Bool) , rec3s_f3 :: !(f Char) } deriving (Generic, Typeable) instance FunctorT Record3S instance DistributiveT Record3S instance ApplicativeT Record3S instance TraversableT Record3S instance ConstraintsT Record3S deriving instance AllTF Show f Record3S => Show (Record3S f x) deriving instance AllTF Eq f Record3S => Eq (Record3S f x) instance AllTF Arbitrary f Record3S => Arbitrary (Record3S f x) where arbitrary = Record3S <$> arbitrary <*> arbitrary <*> arbitrary ----------------------------------------------------- -- Bad products ----------------------------------------------------- data Ignore1 (f :: Type -> Type) (x :: kx) = Ignore1 { ign1_f1 :: Int } deriving (Generic, Typeable, Eq, Show) instance FunctorT Ignore1 instance TraversableT Ignore1 instance ConstraintsT Ignore1 instance Arbitrary (Ignore1 f x) where arbitrary = Ignore1 <$> arbitrary ----------------------------------------------------- -- Sums ----------------------------------------------------- data Sum3 f x = Sum3_0 | Sum3_1 (f Int) | Sum3_2 (f Int) (f Bool) deriving (Generic, Typeable) instance FunctorT Sum3 instance TraversableT Sum3 instance ConstraintsT Sum3 deriving instance AllTF Show f Sum3 => Show (Sum3 f x) deriving instance AllTF Eq f Sum3 => Eq (Sum3 f x) instance AllTF Arbitrary f Sum3 => Arbitrary (Sum3 f x) where arbitrary = oneof [ pure Sum3_0 , Sum3_1 <$> arbitrary , Sum3_2 <$> arbitrary <*> arbitrary ] ----------------------------------------------------- -- Composite and recursive ----------------------------------------------------- data CompositeRecord f x = CompositeRecord { crec_f1 :: f Int , crec_F2 :: f Bool , crec_f3 :: Record3 f x , crec_f4 :: Record1 f x } deriving (Generic, Typeable) instance FunctorT CompositeRecord instance ApplicativeT CompositeRecord instance TraversableT CompositeRecord instance ConstraintsT CompositeRecord deriving instance AllTF Show f CompositeRecord => Show (CompositeRecord f x) deriving instance AllTF Eq f CompositeRecord => Eq (CompositeRecord f x) instance AllTF Arbitrary f CompositeRecord => Arbitrary (CompositeRecord f x) where arbitrary = CompositeRecord <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary data SumRec f x = SumRec_0 | SumRec_1 (f Int) | SumRec_2 (f Int) (SumRec f x) deriving (Generic, Typeable) instance FunctorT SumRec instance TraversableT SumRec instance ConstraintsT SumRec deriving instance AllTF Show f SumRec => Show (SumRec f x) deriving instance AllTF Eq f SumRec => Eq (SumRec f x) instance AllTF Arbitrary f SumRec => Arbitrary (SumRec f x) where arbitrary = oneof [ pure SumRec_0 , SumRec_1 <$> arbitrary , SumRec_2 <$> arbitrary <*> arbitrary ] data InfRec f x = InfRec { ir_1 :: f Int, ir_2 :: InfRec f x } deriving (Generic, Typeable) instance FunctorT InfRec instance ApplicativeT InfRec instance TraversableT InfRec instance ConstraintsT InfRec deriving instance AllTF Show f InfRec => Show (InfRec f x) deriving instance AllTF Eq f InfRec => Eq (InfRec f x) ----------------------------------------------------- -- Nested under functors ----------------------------------------------------- data NestedF f x = NestedF { npf_1 :: f Int , npf_2 :: [Record3 f x] , npf_3 :: Maybe (NestedF f x) } deriving (Generic, Typeable) instance FunctorT NestedF instance ApplicativeT NestedF instance TraversableT NestedF deriving instance (Show (f Int), Show (Record3 f x)) => Show (NestedF f x) deriving instance (Eq (f Int), Eq (Record3 f x)) => Eq (NestedF f x) instance (Arbitrary (f Int), AllTF Arbitrary f Record3, AllTF Arbitrary f Sum3) => Arbitrary (NestedF f x) where arbitrary = scale (`div` 2) $ NestedF <$> arbitrary <*> scale (`div` 2) arbitrary <*> arbitrary data Nested2F f x = Nested2F { np2f_1 :: f Int , np2f_2 :: [Maybe (Nested2F f x)] } deriving (Generic, Typeable) instance FunctorT Nested2F instance TraversableT Nested2F instance ApplicativeT Nested2F deriving instance Show (f Int) => Show (Nested2F f x) deriving instance Eq (f Int) => Eq (Nested2F f x) instance Arbitrary (f Int) => Arbitrary (Nested2F f x) where arbitrary = scale (`div` 2) $ Nested2F <$> arbitrary <*> scale (`div` 2) arbitrary ----------------------------------------------------- -- Parametric barbies ----------------------------------------------------- data ParB b (f :: k -> Type) (x :: kx) = ParB (b f x) 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) data ParBH h b (f :: k -> Type) (x :: kx) = ParBH (h (b f x)) 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) data ParX a f x = ParX (f a) a deriving (Generic, Typeable) instance FunctorT (ParX a) instance Monoid a => ApplicativeT (ParX a) instance TraversableT (ParX a) instance ConstraintsT (ParX a) deriving instance (Show a, Show (f a)) => Show (ParX a f x) deriving instance (Eq a, Eq (f a)) => Eq (ParX a f x) instance (Arbitrary a, Arbitrary (f a)) => Arbitrary (ParX a f x) where arbitrary = ParX <$> arbitrary <*> arbitrary ----------------------------------------------------- -- Higher-kinded barbies ----------------------------------------------------- data HKB b x = HKB { hkb1 :: b Maybe , khb2 :: b ([]) } deriving (Generic, Typeable) instance FunctorT HKB instance ApplicativeT HKB instance TraversableT HKB instance ConstraintsT HKB ----------------------------------------------------- -- Actual bi-barbies ----------------------------------------------------- type Record1' = TestBarbies.Record1 data NestedB f g = NestedB { nb_1 :: g Int , nb_2 :: f (g Bool) , 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 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 Record1', Arbitrary (f (Record1' g))) => Arbitrary (NestedB f g) where arbitrary = NestedB <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary data MixedBT f g = MixedBT { mx_1 :: f Int , mx_2 :: g Bool } deriving (Generic, Typeable) instance FunctorT MixedBT instance TraversableT MixedBT instance ConstraintsT MixedBT instance FunctorB (MixedBT f) instance (Monoid (f Int)) => ApplicativeB (MixedBT f) instance TraversableB (MixedBT f) instance ConstraintsB (MixedBT f) deriving instance (AllBF Show g (MixedBT f), AllTF Show f MixedBT) => Show (MixedBT f g) deriving instance (AllBF Eq g (MixedBT f), AllTF Eq f MixedBT) => Eq (MixedBT f g) instance (AllBF Arbitrary g (MixedBT f), AllTF Arbitrary f MixedBT) => Arbitrary (MixedBT f g) where arbitrary = MixedBT <$> arbitrary <*> arbitrary barbies-2.0.5.0/test/Clothes.hs0000644000000000000000000001441514035406146014375 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-} module Clothes where import Prelude hiding ((.), id) import Control.Category import Data.Functor.Classes (Eq1(..), Show1(..), liftShowsPrec2, showsUnaryWith) 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, Functor) instance Eq1 F where liftEq eq (F as) (F bs) = liftEq eq as bs instance Show1 F where liftShowsPrec sp sl d (F as) = showsUnaryWith (liftShowsPrec sp sl) "F" d as data G a = NoG | G1 a | Gn [a] deriving(Eq, Show, Typeable, Functor) instance Eq1 G where liftEq _ NoG NoG = True liftEq _ NoG _ = False liftEq eq (G1 a) (G1 b) = a `eq` b liftEq _ (G1 _) _ = False liftEq eq (Gn as) (Gn bs) = liftEq eq as bs liftEq _ (Gn _ ) _ = False instance Show1 G where liftShowsPrec sp sl d = \case NoG -> showString "NoG" G1 a -> showsUnaryWith sp "G1" d a Gn as -> showsUnaryWith (liftShowsPrec sp sl) "Gn" d as data H a = NoH1 | NoH2 | H1 [a] | H2 [a] | H3 [a] deriving(Eq, Show, Typeable, Functor) instance Show1 H where liftShowsPrec sp sl d = \case NoH1 -> showString "NoH1" NoH2 -> showString "NoH2" H1 as -> showsUnaryWith (liftShowsPrec sp sl) "H1" d as H2 as -> showsUnaryWith (liftShowsPrec sp sl) "H2" d as H3 as -> showsUnaryWith (liftShowsPrec sp sl) "H3" d as instance Eq1 H where liftEq _ NoH1 NoH1 = True liftEq _ NoH1 _ = False liftEq _ NoH2 NoH2 = True liftEq _ NoH2 _ = False liftEq eq (H1 as) (H1 bs) = liftEq eq as bs liftEq _ (H1 _ ) _ = False liftEq eq (H2 as) (H2 bs) = liftEq eq as bs liftEq _ (H2 _ ) _ = False liftEq eq (H3 as) (H3 bs) = liftEq eq as bs liftEq _ (H3 _ ) _ = False data I a = NoI1 | NoI2 | NoI3 | I1 a | I2 (a,a) deriving(Eq, Show, Typeable) instance Show1 I where liftShowsPrec sp sl d = \case NoI1 -> showString "NoI1" NoI2 -> showString "NoI2" NoI3 -> showString "NoI3" I1 a -> showsUnaryWith sp "I1" d a I2 aa -> showsUnaryWith (liftShowsPrec2 sp sl sp sl) "I2" d aa instance Eq1 I where liftEq _ NoI1 NoI1 = True liftEq _ NoI1 _ = False liftEq _ NoI2 NoI2 = True liftEq _ NoI2 _ = False liftEq _ NoI3 NoI3 = True liftEq _ NoI3 _ = False liftEq eq (I1 a) (I1 b) = a `eq` b liftEq _ (I1 _ ) _ = False liftEq eq (I2 (a,b)) (I2 (c,d)) = (a `eq` c) && (b `eq` d) liftEq _ (I2 _ ) _ = False instance Arbitrary a => Arbitrary (F a) where arbitrary = scale (`div` 2) $ F <$> arbitrary instance Arbitrary a => Arbitrary (G a) where arbitrary = scale (`div` 2) $ oneof [ pure NoG , G1 <$> arbitrary , Gn <$> arbitrary ] instance Arbitrary a => Arbitrary (H a) where arbitrary = scale (`div` 2) $ oneof [ pure NoH1 , pure NoH2 , H1 <$> arbitrary , H2 <$> arbitrary , H3 <$> arbitrary ] instance Arbitrary a => Arbitrary (I a) where arbitrary = scale (`div` 2) $ 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 = scale (`div` 2) $ 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 _ = " G>" instance Show GH where show _ = " H>" instance Show HI where show _ = " I>" barbies-2.0.5.0/test/Spec/Applicative.hs0000644000000000000000000000326113552652732016133 0ustar0000000000000000{-# LANGUAGE AllowAmbiguousTypes #-} module Spec.Applicative ( laws ) where import Clothes(F(..), G, H, I, FG(..), HI(..), NatTransf(..)) import Data.Functor.Barbie(FunctorB(..), ApplicativeB(..)) import Data.Functor.Product(Product(Pair)) import Data.Typeable(Typeable, Proxy(..), typeRep) import Test.Tasty(TestTree, testGroup) import Test.Tasty.QuickCheck(Arbitrary(..), testProperty, (===)) laws :: forall b . ( ApplicativeB b , Eq (b F), Eq (b (G `Product` I)), Eq (b ((F `Product` G) `Product` H)) , Show (b F), Show (b G), Show (b H) , Show (b (G `Product` I)), Show (b ((F `Product` G) `Product` H)) , Arbitrary (b F), Arbitrary (b G), Arbitrary (b H) , Typeable b ) => TestTree laws = testGroup (show (typeRep (Proxy @b))) [ testProperty "naturality of bprod" $ \(FG (NatTransf f)) (HI (NatTransf g)) l r -> let lhs, rhs :: b F -> b H -> b (G `Product` I) lhs u v = bmap (\(Pair a b) -> Pair (f a) (g b)) (u `bprod` v) rhs u v = bmap f u `bprod` bmap g v in lhs l r === rhs l r , testProperty "left identity" $ \u -> bmap (\(Pair _ b) -> b) (bpure (F []) `bprod` u) === (u :: b F) , testProperty "left identity" $ \u -> bmap (\(Pair a _) -> a) (u `bprod` bpure (F [])) === (u :: b F) , testProperty "associativity" $ \u v w -> let assocPair (Pair a (Pair b c)) = Pair (Pair a b) c lhs, rhs :: b ((F `Product` G) `Product` H) lhs = bmap assocPair (u `bprod` (v `bprod` w)) rhs = (u `bprod` v) `bprod` w in lhs === rhs ] barbies-2.0.5.0/test/Spec/Bare.hs0000644000000000000000000000151313546116165014537 0ustar0000000000000000{-# LANGUAGE AllowAmbiguousTypes #-} module Spec.Bare ( laws ) where import Barbies.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) ] barbies-2.0.5.0/test/Spec/Constraints.hs0000644000000000000000000000134713553043772016203 0ustar0000000000000000{-# LANGUAGE AllowAmbiguousTypes #-} module Spec.Constraints ( lawAddDictPrj ) where import Clothes(F) import Barbies.Constraints(ClassF, Dict) import Data.Functor.Barbie(bmap, ConstraintsB(..), AllBF) 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 barbies-2.0.5.0/test/Spec/Distributive.hs0000644000000000000000000000241114035406146016334 0ustar0000000000000000{-# 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) ] barbies-2.0.5.0/test/Spec/Functor.hs0000644000000000000000000000143013546116165015304 0ustar0000000000000000{-# LANGUAGE AllowAmbiguousTypes #-} module Spec.Functor ( laws ) where import Clothes (F, H, FG(..), GH(..), NatTransf(..)) import Data.Functor.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) ] barbies-2.0.5.0/test/Spec/Traversable.hs0000644000000000000000000000237613546116165016150 0ustar0000000000000000{-# LANGUAGE AllowAmbiguousTypes #-} module Spec.Traversable ( laws ) where import Clothes (F, G, H, FG(..), GH(..), NatTransf(..)) import Data.Functor.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) ] barbies-2.0.5.0/test/Spec/Wrapper.hs0000644000000000000000000000172713553036163015312 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE AllowAmbiguousTypes #-} module Spec.Wrapper ( lawsMonoid ) where import Barbies (AllBF, ApplicativeB, Barbie(..), ConstraintsB) import Test.Tasty(testGroup, TestTree) import Test.Tasty.QuickCheck(Arbitrary(..), testProperty) lawsMonoid :: forall b . ( Arbitrary (b []), Eq (b []), Show (b []) , ApplicativeB b , ConstraintsB 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 barbies-2.0.5.0/ChangeLog.md0000644000000000000000000001110214514735465013633 0ustar0000000000000000# Changelog for barbies ## 2.0.5.0 - Add helper class Barbies.Constraints.(&) (#46) ## 2.0.4.0 - Add FunctorT and DistributiveT instances for AccumT ## 2.0.3.1 - Compatibility changes for GHC 9.2 (Dan Dart) ## 2.0.3.0 - Add Barbies.Bi.bttraverse_ - Add Barbies.Bi.btfoldMap - Fix failure to derive Constraints{B,T} for proper bi-barbies. - Builds with ghc 9 (Fumiaki Kinoshita) ## 2.0.2.0 - Add `Barbies.Bare.WearTwo` type family to support having _field-specific_ newtype wrappers that get applied only to the covered barbie (Lennart Spitzner). ## 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 parameter not under the functor argument. - Fix failure to derive instances for types with arguments of kind `k -> Type`. - Fix failure to derive instances where functor arg is applied under a functor. - Derive instances for nested barbies occurring under two functors (Matthew Peddie). - Add `foldMapC` and `bzipWithxC` (Matthew Peddie). - Create a `Barbies` module, to contain wrappers, basic docs, etc. `Data.Functor.Barbie` contains only functor-related stuff. - Replace `ProductB` by `ApplicativeB`, with more lax laws. Now we can derive more instances than before, since arbitrary monoids are allowed as fields of the record. - Add `Data.Functor.Transformer`, operations for bi-barbies, including support for nesting. - Add a `ErrorContainer` wrapper, similar to `Container` but for `Either e`. - Remove `ProductBC`, since `bdicts` can now be defined in terms of `ApplicativeB` and `ConstraintsB`. - Remove functions deprecated on release 1.0 - Deprecate `Data.Functor.Prod`, `(/*)` and `(/*/)`. - Deprecate `Data.Barbie`, in favor of `Data.Functor.Barbie`. - Deprecate `Data.Barbie.Bare`, in favor of `Barbies.Bare`. - Deprecate `Data.Barbie.Constraints`, in favor of `Barbies.Constraints`. ## 1.1.3.0 - `Wear` will raise a `TypeError` instead of getting stuck (Alex Peitsinis). ## 1.1.2.1 - Uploaded 1.1.2.0 was broken (missing `btraverseC`) ## 1.1.2.0 - Add `traverseC` (Ole Krüger). - Fix typo in ProductB laws (thanks to Ben Radford). ## 1.1.1.0 - Add `bmapC` (Chris Penner). ## 1.1.0.0 - Make all classes poly-kinded (#7): a barbie can now be any type parameterised by a type `(k -> Type)`. In particular, a (higher-kinded) barbie is a type parameterised by a barbie. Thanks to Ole Krüger. - Add instances for functor transformers: `Proxy`, `Const`, `Product`, `Sum` and `Compose` (Ole Krüger). ## 1.0.0.0 - Replaced `ConstraintsOf` in `ConstraintsB` by `AllB`, which allows constraints to be given on `a` instead of on `f a`. The `ClassF` class lets us specify constraints on `f a` by doing `AllB (ClassF c f) b`. `ConstraintsOf` becomes then a type alias. Credit goes to Csongor Kiss. - `ConstraintsOf` was ultimately deprecated in favour of `AllBF`, which is shorter and more consistent with `AllB`. - Renamed `ConstraintsB(adjProof)` to `ConstraintsB(baddDicts)`. - Renamed `ProofB(bproof)` to `ProductBC(bdicts)`. - Changed the way `Wear` works: now wear-types need to have an extra type parameter that controls whether they are `Bare` or `Covered`. This let us remove all the "magic" that was involved, in the sense that one couldn't have instances of `FunctorB`, etc, for wear-types wihtout using `unsafeCoerce` (this was true also for handwritten instances). - Added `bsequence'`, a frequent specialisation of `bsequence`. - Added `bfoldMap`. - Added `buniqC` and `bmempty`. - Improved the internal instance derivation mechanism. We no longer need `unsafeCoerce` and the code should be in general indistinguishible from hand-written instances (not currently verified). - Fixed support for barbie-types that have additional type parameters (#5). ## 0.1.4.0 - Added `btraverse_` - Added the trivial `Void` and `Unit` barbies ## 0.1.3.1 - Fixed issue on Barbie-types with strictness annotations. ## 0.1.3.0 - Use both `Monoid` and `Semigroup` as constraints for the `Monoid` instance, so that this works with ghc 8.0 to 8.4 (Fraser Murray) ## 0.1.2.0 - Use `Monoid` and not `Semigroup` as constraints for the `Monoid` instance ## 0.1.1.0 - Added `instance Semigroup (Barbie b)` to go along the `Monoid` instance ## 0.1.0.1 - Works under GHC 8.0.2, but notice one needs to use empty instance declarations, because ghc chokes on `deriving` clauses. ## 0.1.0.0 - Initial release barbies-2.0.5.0/README.md0000644000000000000000000000235613606570066012747 0ustar0000000000000000# barbies [![Build Status](https://travis-ci.org/jcpetruzza/barbies.svg?branch=master)](https://travis-ci.org/jcpetruzza/barbies) Types that are parametric on unary type-constructors that control their shapes are like Barbies that can wear different clothes to become a different doll. This is a common Haskell-idiom. E.g., ```haskell data Person f = Person { name :: f String , age :: f Int } b1 :: Person Last -- Barbie with a monoid structure b2 :: Person (Const a) -- container Barbie b3 :: Person Identity -- Barbie's new clothes ``` This package provides basic classes and abstractions to work with these types and easily transform them. See the [docs](https://hackage.haskell.org/package/barbies/docs/Barbies.html) to learn more. ## Related packages - [barbies-th](https://hackage.haskell.org/package/barbies-th): Use Template Haskell to derive barbie-types from declarations that look like normal types. - [higgledy](https://hackage.haskell.org/package/higgledy): Use Generics to give a barbie-type interface to a normal type. - [harg](https://hackage.haskell.org/package/harg): Program-configuration (from command-line arguments, environment variables, configuration files, etc) via barbie-types barbies-2.0.5.0/LICENSE0000644000000000000000000000276514035406146012473 0ustar0000000000000000Copyright Daniel Gorin (c) 2018 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Author name here nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. barbies-2.0.5.0/Setup.hs0000644000000000000000000000005613271362553013115 0ustar0000000000000000import Distribution.Simple main = defaultMain barbies-2.0.5.0/barbies.cabal0000644000000000000000000001046714514735236014066 0ustar0000000000000000name: barbies version: 2.0.5.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 homepage: https://github.com/jcpetruzza/barbies#readme bug-reports: https://github.com/jcpetruzza/barbies/issues author: Daniel Gorin maintainer: jcpetruzza@gmail.com copyright: 2018 Daniel Gorin license: BSD3 license-file: LICENSE build-type: Simple cabal-version: >= 1.10 extra-source-files: ChangeLog.md README.md source-repository head type: git location: https://github.com/jcpetruzza/barbies library exposed-modules: Barbies Barbies.Bare Barbies.Bi Barbies.Constraints Barbies.Internal 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 Barbies.Generics.Constraints Barbies.Generics.Distributive Barbies.Generics.Functor Barbies.Generics.Traversable Barbies.Internal.ApplicativeB Barbies.Internal.ApplicativeT Barbies.Internal.BareB Barbies.Internal.ConstraintsB Barbies.Internal.ConstraintsT Barbies.Internal.Containers Barbies.Internal.Dicts Barbies.Internal.DistributiveB Barbies.Internal.DistributiveT Barbies.Internal.FunctorB Barbies.Internal.FunctorT Barbies.Internal.MonadT Barbies.Internal.TraversableB Barbies.Internal.TraversableT Barbies.Internal.Trivial Barbies.Internal.Wear Barbies.Internal.Wrappers Barbies.Internal.Writer Data.Generics.GenericN -- To be removed Data.Barbie.Internal.Product Data.Barbie.Internal.ProductC hs-source-dirs: src build-depends: base >=4.11 && <5, distributive, transformers ghc-options: -Wall default-language: Haskell2010 default-extensions: ConstraintKinds , DataKinds , DefaultSignatures , DeriveFunctor , DeriveFoldable , DeriveTraversable , DeriveGeneric , DeriveDataTypeable , EmptyCase , ExplicitForAll , FlexibleContexts , FlexibleInstances , GADTSyntax , KindSignatures , LambdaCase , MultiParamTypeClasses , Rank2Types , ScopedTypeVariables , StandaloneDeriving , TypeApplications , TypeOperators test-suite barbies-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: TestBarbies TestBarbiesW TestBiBarbies Clothes Spec.Applicative Spec.Bare Spec.Constraints Spec.Distributive Spec.Functor Spec.Traversable Spec.Wrapper hs-source-dirs: test ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -O0 build-depends: 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 , tasty-quickcheck default-language: Haskell2010 default-extensions: DeriveDataTypeable DeriveGeneric KindSignatures LambdaCase Rank2Types ScopedTypeVariables StandaloneDeriving TypeApplications TypeOperators