diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,28 @@ # Changelog for barbies +## 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). @@ -15,7 +38,7 @@ - Add `bmapC` (Chris Penner). ## 1.1.0.0 - - Make all classes poly-kinded (#7): a barbie can now be any type + - 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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -6,16 +6,26 @@ ```haskell -data Barbie f - = Barbie +data Person f + = Person { name :: f String , age :: f Int } -b1 :: Barbie Last -- Barbie with a monoid structure -b2 :: Barbie (Const a) -- container Barbie -b3 :: Barbie Identity -- Barbie's new clothes +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 diff --git a/barbies.cabal b/barbies.cabal --- a/barbies.cabal +++ b/barbies.cabal @@ -1,5 +1,5 @@ name: barbies -version: 1.1.3.0 +version: 2.0.0.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 @@ -19,53 +19,85 @@ source-repository head type: git - location: https://github.com/jcpetruzza/barbie + 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.Barbie.Container - Data.Barbie.Internal Data.Functor.Prod - other-modules: - Data.Barbie.Internal.Bare - Data.Barbie.Internal.Constraints - Data.Barbie.Internal.Dicts - Data.Barbie.Internal.Functor - Data.Barbie.Internal.Instances - Data.Barbie.Internal.Product - Data.Barbie.Internal.ProductC - Data.Barbie.Internal.Traversable - Data.Barbie.Internal.Wear - Data.Barbie.Trivial + Barbies.Generics.Applicative + Barbies.Generics.Bare + Barbies.Generics.Constraints + 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.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.7 && <5 - ,bifunctors + base >=4.11 && <5, + transformers - ghc-options: -Wall -Wnoncanonical-monoid-instances + ghc-options: -Wall default-language: Haskell2010 default-extensions: ConstraintKinds , DataKinds , DefaultSignatures + , DeriveFunctor + , DeriveFoldable + , DeriveTraversable , DeriveGeneric , DeriveDataTypeable , EmptyCase , ExplicitForAll , FlexibleContexts , FlexibleInstances + , GADTSyntax , KindSignatures , LambdaCase , MultiParamTypeClasses @@ -81,20 +113,65 @@ main-is: Spec.hs other-modules: - Barbies - BarbiesW + TestBarbies + TestBarbiesW + TestBiBarbies Clothes + Spec.Applicative Spec.Bare Spec.Constraints Spec.Functor Spec.Traversable - Spec.Product Spec.Wrapper hs-source-dirs: test - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -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 + +-- 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 diff --git a/src/Barbies.hs b/src/Barbies.hs new file mode 100644 --- /dev/null +++ b/src/Barbies.hs @@ -0,0 +1,285 @@ +----------------------------------------------------------------------------- +-- | +-- 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 diff --git a/src/Barbies/Bare.hs b/src/Barbies/Bare.hs new file mode 100644 --- /dev/null +++ b/src/Barbies/Bare.hs @@ -0,0 +1,53 @@ +----------------------------------------------------------------------------- +-- | +-- 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 'Maybe' +-- type SignUpData = SignUpForm 'Bare' +-- +-- formData = SignUpForm "jbond" "shaken007" False :: SignUpData +-- @ +---------------------------------------------------------------------------- +module Barbies.Bare + ( -- * Bare values + Wear + , Bare + , Covered + + -- * Covering and stripping + , BareB(bstrip, bcover) + , bstripFrom + , bcoverWith + + ) where + +import Barbies.Internal.BareB + ( Wear, Bare, Covered + , BareB(..) + , bstripFrom, bcoverWith + ) diff --git a/src/Barbies/Bi.hs b/src/Barbies/Bi.hs new file mode 100644 --- /dev/null +++ b/src/Barbies/Bi.hs @@ -0,0 +1,203 @@ +{-# 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 + + -- * 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 Data.Functor.Barbie +import Data.Functor.Transformer + +import Control.Applicative (Alternative(..)) +import Control.Monad ((>=>)) +import Data.Monoid (Alt(..)) +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 #-} +-- }} 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 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. 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 diff --git a/src/Barbies/Constraints.hs b/src/Barbies/Constraints.hs new file mode 100644 --- /dev/null +++ b/src/Barbies/Constraints.hs @@ -0,0 +1,21 @@ +----------------------------------------------------------------------------- +-- | +-- Module: Barbies.Constraints +-- +-- Support for operating on Barbie-types with constrained functions. +---------------------------------------------------------------------------- +module Barbies.Constraints + ( -- * Instance dictionaries + Dict(..) + , requiringDict + + -- * Getting constraints + , AllBF + , ClassF + , ClassFG + ) + +where + +import Barbies.Internal.ConstraintsB +import Barbies.Internal.Dicts diff --git a/src/Barbies/Generics/Applicative.hs b/src/Barbies/Generics/Applicative.hs new file mode 100644 --- /dev/null +++ b/src/Barbies/Generics/Applicative.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +module Barbies.Generics.Applicative + ( GApplicative(..) + ) + +where + + +import Data.Functor.Product(Product(..)) +import Data.Proxy(Proxy (..)) + +import Data.Generics.GenericN + + +class GApplicative n (f :: k -> *) (g :: k -> *) 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 ----------------------------------------------- diff --git a/src/Barbies/Generics/Bare.hs b/src/Barbies/Generics/Bare.hs new file mode 100644 --- /dev/null +++ b/src/Barbies/Generics/Bare.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +module Barbies.Generics.Bare + ( GBare(..) + ) + +where + +import Data.Functor.Identity (Identity(..)) + +import Data.Coerce (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 GBare n (Rec (P n Identity a) (Identity a)) (Rec a a) 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 #-} diff --git a/src/Barbies/Generics/Constraints.hs b/src/Barbies/Generics/Constraints.hs new file mode 100644 --- /dev/null +++ b/src/Barbies/Generics/Constraints.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +module Barbies.Generics.Constraints + ( GAll + , X, Y + , TagSelf, TagSelf', Self, Other + , GConstraints(..) + ) + +where + +import Barbies.Internal.Dicts(Dict (..)) + +import Data.Functor.Product (Product (..)) +import Data.Kind (Constraint, Type) +import GHC.TypeLits (Nat, type (+)) + +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 (P n X _) (X a)) = c a + +-- {{ Functor application ----------------------------------------------------- +instance + 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 ----------------------------------------------- + +-- Break all recursive cases +-- b' is b, maybe with 'Param' annotations +type instance GAll 0 c (Rec (Self b' (P 0 X)) (b X)) = () +type instance GAll 1 c (Rec (Self b' (P 1 X) (P 0 Y)) (b X Y)) = () + +type instance GAll n c (Rec a a) = () + +instance + GConstraints n c f (Rec a' a) + (Rec a a) + (Rec a a) + where + gaddDicts = id + {-# INLINE gaddDicts #-} +-- }} Not a functor application ----------------------------------------------- + + +-- ============================================================================ +-- ## Identifying recursive usages of the barbie-type ## +-- +-- ============================================================================ + +data family Self (b :: k -> k') :: k -> k' +data family Other (b :: k -> k') :: k -> k' + +-- | 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 f@ to break the recursion. Our trick will be to use a type +-- family to inspect @'RepN' (b f)@ and distinguish recursive usages from +-- non-recursive ones, tagging them with different types, so we can distinguish +-- them in the instances. +type TagSelf n b repbf + = TagSelf' n b (Indexed b (n + 1)) repbf + +type family TagSelf' (n :: Nat) (b :: kb) (b' :: kb) (repbf :: * -> *) :: * -> * where + TagSelf' n b b' (M1 mt m s) + = M1 mt m (TagSelf' n b b' s) + + TagSelf' n b b' (l :+: r) + = TagSelf' n b b' l :+: TagSelf' n b b' r + + TagSelf' n b b' (l :*: r) + = TagSelf' n b b' l :*: TagSelf' n b b' r + + TagSelf' 0 b b' (Rec (b' f) (b g)) + = Rec (Self b' f) (b g) + + TagSelf' 0 (b :: k -> *) b' (Rec ((b'' :: k -> *) f) ((b''' :: k -> *) g)) + = Rec (Other b'' f) (b''' g) + + TagSelf' 1 b b' (Rec (b' fl fr) (b gl gr)) + = Rec (Self b' fl fr) (b gl gr) + + TagSelf' 1 (b :: kl -> kr -> *) b' (Rec ((b'' :: kl -> kr -> *) fl fr) ((b''' :: kl -> kr -> *) gl gr)) + = Rec (Other b'' fl fr) (b''' gl gr) + + TagSelf' n b b' (Rec p a) + = Rec p a + + TagSelf' n b b' U1 + = U1 + + TagSelf' n b b' V1 + = V1 diff --git a/src/Barbies/Generics/Functor.hs b/src/Barbies/Generics/Functor.hs new file mode 100644 --- /dev/null +++ b/src/Barbies/Generics/Functor.hs @@ -0,0 +1,91 @@ +{-# 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 -------------------------- diff --git a/src/Barbies/Generics/Traversable.hs b/src/Barbies/Generics/Traversable.hs new file mode 100644 --- /dev/null +++ b/src/Barbies/Generics/Traversable.hs @@ -0,0 +1,90 @@ +{-# 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 ----------------------------------------------- diff --git a/src/Barbies/Internal.hs b/src/Barbies/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Barbies/Internal.hs @@ -0,0 +1,70 @@ +module Barbies.Internal + ( -- * Functor + Internal.gbmapDefault + , Generics.GFunctor(..) + , Internal.CanDeriveFunctorB + , Internal.CanDeriveFunctorT + + + + -- * Traversable + , Internal.gbtraverseDefault + , Generics.GTraversable(..) + , Internal.CanDeriveTraversableB + , Internal.CanDeriveTraversableT + + + + -- * 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.TagSelf, Generics.TagSelf', Generics.Self, Generics.Other + + -- * 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.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.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 diff --git a/src/Barbies/Internal/ApplicativeB.hs b/src/Barbies/Internal/ApplicativeB.hs new file mode 100644 --- /dev/null +++ b/src/Barbies/Internal/ApplicativeB.hs @@ -0,0 +1,287 @@ +{-# 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 #-} diff --git a/src/Barbies/Internal/ApplicativeT.hs b/src/Barbies/Internal/ApplicativeT.hs new file mode 100644 --- /dev/null +++ b/src/Barbies/Internal/ApplicativeT.hs @@ -0,0 +1,300 @@ +{-# 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) + -> (forall x . 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 #-} diff --git a/src/Barbies/Internal/BareB.hs b/src/Barbies/Internal/BareB.hs new file mode 100644 --- /dev/null +++ b/src/Barbies/Internal/BareB.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module Barbies.Internal.BareB + ( Wear, Bare, Covered + , BareB(..) + , bstripFrom, bcoverWith + + , gbstripDefault + , gbcoverDefault + + , CanDeriveBareB + ) + +where + +import Barbies.Generics.Bare(GBare(..)) +import Barbies.Internal.FunctorB (FunctorB(..)) +import Barbies.Internal.Wear(Bare, Covered, Wear) +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 #-} diff --git a/src/Barbies/Internal/ConstraintsB.hs b/src/Barbies/Internal/ConstraintsB.hs new file mode 100644 --- /dev/null +++ b/src/Barbies/Internal/ConstraintsB.hs @@ -0,0 +1,330 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module Barbies.Internal.ConstraintsB + ( ConstraintsB(..) + , bmapC + , btraverseC + , AllBF + , bdicts + , bpureC + , bmempty + , bzipWithC + , bzipWith3C + , bzipWith4C + , bfoldMapC + + , CanDeriveConstraintsB + , gbaddDictsDefault + , GAllRepB + ) + +where + +import Barbies.Generics.Constraints(GConstraints(..), GAll, TagSelf, Self, Other, 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) +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 -> *) -> *) 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 + + +-- | 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) +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 + = ( GenericP 0 (b f) + , GenericP 0 (b (Dict c `Product` f)) + , AllB c b ~ GAll 0 c (GAllRepB b) + , GConstraints 0 c f (GAllRepB b) (RepP 0 (b f)) (RepP 0 (b (Dict c `Product` f))) + ) + +-- | The representation used for the generic computation of the @'AllB' c b@ +-- constraints. Here 'X' is an arbitrary constant since the actual +-- argument to @b@ is irrelevant. +type GAllRepB b = TagSelf 0 b (RepN (b X)) + + +-- =============================================================== +-- 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 + = toP (Proxy @0) . gaddDicts @0 @c @f @(GAllRepB b) . fromP (Proxy @0) +{-# INLINE gbaddDictsDefault #-} + + +-- ------------------------------------------------------------ +-- Generic derivation: Special cases for ConstraintsB +-- ----------------------------------------------------------- + +type P = Param + + +instance + ( ConstraintsB b + , AllB c b + ) => -- b' is b, maybe with 'Param' annotations + GConstraints 0 c f (Rec (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 (Rec (Other b (P 0 X)) (b' X)) = AllB c b' + +instance + ( ConstraintsB b + , AllB c b + ) => GConstraints 0 c f (Rec (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 #-} diff --git a/src/Barbies/Internal/ConstraintsT.hs b/src/Barbies/Internal/ConstraintsT.hs new file mode 100644 --- /dev/null +++ b/src/Barbies/Internal/ConstraintsT.hs @@ -0,0 +1,283 @@ +{-# 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 + ) + +where + +import Barbies.Internal.ApplicativeT(ApplicativeT (..)) +import Barbies.Generics.Constraints(GConstraints(..), GAll, TagSelf, Self, Other, 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) +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 -> *) -> (kr -> *)) 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 + = ( GenericP 1 (t f x) + , GenericP 1 (t (Dict c `Product` f) x) + , AllT c t ~ GAll 1 c (GAllRepT t) + , GConstraints 1 c f (GAllRepT t) (RepP 1 (t f x)) (RepP 1 (t (Dict c `Product` f) x)) + ) + +-- | The representation used for the generic computation of the @'AllT' c t@ +-- constraints. Here 'X' and 'Y' are arbitrary constants since the actual +-- argument to @t@ is irrelevant. +type GAllRepT t = TagSelf 1 t (RepN (t X Y)) + +-- =============================================================== +-- 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 + = toP (Proxy @1) . gaddDicts @1 @c @f @(GAllRepT t) . fromP (Proxy @1) +{-# INLINE gtaddDictsDefault #-} + + +-- ------------------------------------------------------------ +-- Generic derivation: Special cases for ConstraintsT +-- ----------------------------------------------------------- + +type P = Param + +instance + ( ConstraintsT t + , AllT c t + ) => -- t' is t, maybe with 'Param' annotations + GConstraints 1 c f (Rec (Self t' (P 1 X) (P 0 Y)) (t X Y)) + (Rec (t (P 1 f) y) (t f y)) + (Rec (t (P 1 (Dict c `Product` f)) y) + (t (Dict c `Product` f) y)) + where + gaddDicts + = Rec . K1 . taddDicts . unK1 . unRec + {-# INLINE gaddDicts #-} + + +type instance GAll 1 c (Rec (Other t (P 1 X) (P 0 Y)) (t' X Y)) = AllT c t' + +instance + ( ConstraintsT t + , AllT c t + ) => GConstraints 1 c f (Rec (Other t' (P 1 X) (P 0 Y)) (t X Y)) + (Rec (t (P 1 f) y) (t f y)) + (Rec (t (P 1 (Dict c `Product` f)) y) + (t (Dict c `Product` f) y)) + where + gaddDicts + = Rec . K1 . taddDicts . unK1 . unRec + {-# INLINE gaddDicts #-} diff --git a/src/Barbies/Internal/Containers.hs b/src/Barbies/Internal/Containers.hs new file mode 100644 --- /dev/null +++ b/src/Barbies/Internal/Containers.hs @@ -0,0 +1,85 @@ +{-# 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 ---------------------------------------------------------- diff --git a/src/Barbies/Internal/Dicts.hs b/src/Barbies/Internal/Dicts.hs new file mode 100644 --- /dev/null +++ b/src/Barbies/Internal/Dicts.hs @@ -0,0 +1,56 @@ +{-# 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 diff --git a/src/Barbies/Internal/FunctorB.hs b/src/Barbies/Internal/FunctorB.hs new file mode 100644 --- /dev/null +++ b/src/Barbies/Internal/FunctorB.hs @@ -0,0 +1,138 @@ +{-# 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 #-} diff --git a/src/Barbies/Internal/FunctorT.hs b/src/Barbies/Internal/FunctorT.hs new file mode 100644 --- /dev/null +++ b/src/Barbies/Internal/FunctorT.hs @@ -0,0 +1,196 @@ +{-# 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 ) + +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) -> (forall x. 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 +-- -------------------------------- + +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 #-} diff --git a/src/Barbies/Internal/MonadT.hs b/src/Barbies/Internal/MonadT.hs new file mode 100644 --- /dev/null +++ b/src/Barbies/Internal/MonadT.hs @@ -0,0 +1,156 @@ +{-# 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 #-} diff --git a/src/Barbies/Internal/TraversableB.hs b/src/Barbies/Internal/TraversableB.hs new file mode 100644 --- /dev/null +++ b/src/Barbies/Internal/TraversableB.hs @@ -0,0 +1,184 @@ +{-# 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 #-} diff --git a/src/Barbies/Internal/TraversableT.hs b/src/Barbies/Internal/TraversableT.hs new file mode 100644 --- /dev/null +++ b/src/Barbies/Internal/TraversableT.hs @@ -0,0 +1,233 @@ +{-# 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)) + -> (forall x . 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 #-} diff --git a/src/Barbies/Internal/Trivial.hs b/src/Barbies/Internal/Trivial.hs new file mode 100644 --- /dev/null +++ b/src/Barbies/Internal/Trivial.hs @@ -0,0 +1,63 @@ +{-# 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.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 TraversableB Unit +instance ApplicativeB Unit +instance ConstraintsB Unit diff --git a/src/Barbies/Internal/Wear.hs b/src/Barbies/Internal/Wear.hs new file mode 100644 --- /dev/null +++ b/src/Barbies/Internal/Wear.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module Barbies.Internal.Wear + ( Wear, Bare, Covered + ) + +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." + ) diff --git a/src/Barbies/Internal/Wrappers.hs b/src/Barbies/Internal/Wrappers.hs new file mode 100644 --- /dev/null +++ b/src/Barbies/Internal/Wrappers.hs @@ -0,0 +1,40 @@ +{-# 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 = (<>) diff --git a/src/Barbies/Internal/Writer.hs b/src/Barbies/Internal/Writer.hs new file mode 100644 --- /dev/null +++ b/src/Barbies/Internal/Writer.hs @@ -0,0 +1,43 @@ +module 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 (<*>) #-} + +type Wr = St + +execWr :: Monoid w => Wr w a -> w +execWr + = snd . runSt mempty + +tell :: Monoid w => w -> Wr w () +tell w + = St (\s -> ((), s `mappend` w)) diff --git a/src/Data/Barbie.hs b/src/Data/Barbie.hs --- a/src/Data/Barbie.hs +++ b/src/Data/Barbie.hs @@ -1,64 +1,6 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Barbie --- --- A common Haskell idiom is to parameterise a datatype by a type @k -> *@, --- typically a functor or a GADT. These are like outfits of a Barbie, --- that turn her into a different doll. E.g. --- --- @ --- data Barbie f --- = Barbie --- { name :: f 'String' --- , age :: f 'Int' --- } --- --- b1 :: Barbie 'Data.Monoid.Last' -- Barbie with a monoid structure --- b2 :: Barbie ('Data.Functor.Const.Const' a) -- 'Data.Barbie.Container.Container' Barbie --- b3 :: Barbie 'Data.Functor.Identity.Identity' -- Barbie's new clothes --- @ --- --- This module define the classes to work with these types and easily --- transform them. They all come with default instances based on --- `GHC.Generics.Generic`, so using them is as easy as: --- --- @ --- data Barbie f --- = Barbie --- { name :: f 'String' --- , age :: f 'Int' --- } --- deriving --- ( 'GHC.Generics.Generic' --- , 'FunctorB', 'TraversableB', 'ProductB', 'ConstraintsB', 'ProductBC' --- ) --- --- deriving instance 'AllBF' 'Show' f Barbie => 'Show' (Barbie f) --- deriving instance 'AllBF' 'Eq' f Barbie => 'Eq' (Barbie f) --- @ --- --- Sometimes one wants to use @Barbie 'Data.Functor.Identity.Identity'@ --- and it may feel like a second-class record type, where one needs to --- unpack values in each field. "Data.Barbie.Bare" offers a way to have --- bare versions of a barbie-type. --- --- Notice that all classes in this package are poly-kinded. Intuitively, --- a barbie is a type parameterised by a functor, and because a barbies is --- a type of functor, a type parameterised by a barbie is a (higher-kinded) --- barbie too: --- --- @ --- data Catalog b --- = Catalog (b 'Identity') (b 'Maybe') --- deriving --- ('GHC.Generics.Generic' --- , 'FunctorB', 'TraversableB', 'ProductB', 'ConstraintsB', 'ProductBC' --- ) --- @ - - ----------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wno-deprecations #-} module Data.Barbie + {-# DEPRECATED "Use Data.Functor.Barbie or Barbies instead" #-} ( -- * Functor FunctorB(bmap) @@ -72,10 +14,14 @@ -- * Product , ProductB(buniq, bprod) + , CanDeriveProductB + -- ** Utility functions - , bzip, bunzip, bzipWith, bzipWith3, bzipWith4 - -- ** Applicative-like interface - , (/*/), (/*) + , App.bzip + , App.bunzip + , App.bzipWith + , App.bzipWith3 + , App.bzipWith4 -- * Constraints and instance dictionaries , ConstraintsB(AllB, baddDicts) @@ -86,6 +32,7 @@ -- * Products and constaints , ProductBC(bdicts) + , CanDeriveProductBC -- ** Utility functions , buniqC , bmempty @@ -94,37 +41,65 @@ , Barbie(..) -- * Trivial Barbies - , Void - , Unit (..) + , Trivial.Void + , Trivial.Unit (..) -- * Generic derivations , Rec(..) + , GProductB(..) + , GProductBC(..) -- * Deprecations - , Deprecated.ConstraintsOf - , Deprecated.adjProof - , Deprecated.ProofB - , Deprecated.bproof + , (/*/), (/*) ) where -import Data.Barbie.Internal.Constraints (AllBF, ConstraintsB (..), bmapC, btraverseC) -import qualified Data.Barbie.Internal.Constraints as Deprecated +import Barbies.Internal.ConstraintsB (AllBF, ConstraintsB (..), bmapC, btraverseC, bmempty) -import Data.Barbie.Internal.Functor(FunctorB(..)) -import Data.Barbie.Internal.Instances(Barbie(..)) -import Data.Barbie.Internal.Product - ( ProductB(..) - , bzip, bunzip, bzipWith, bzipWith3, bzipWith4 - , (/*/), (/*) - ) -import Data.Barbie.Internal.ProductC(ProductBC(..), buniqC, bmempty) -import qualified Data.Barbie.Internal.ProductC as Deprecated -import Data.Barbie.Internal.Traversable +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 Data.Barbie.Trivial(Void, Unit(..)) +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 /* diff --git a/src/Data/Barbie/Bare.hs b/src/Data/Barbie/Bare.hs --- a/src/Data/Barbie/Bare.hs +++ b/src/Data/Barbie/Bare.hs @@ -1,55 +1,14 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Barbie.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 'FunctorB' (SignUpForm 'Covered') --- instance 'TraversableB' (SignUpForm 'Covered') --- ..., --- instance 'BareB' SignUpForm --- --- type SignUpRaw = SignUpForm 'Maybe' --- type SignUpData = SignUpForm 'Bare' --- --- formData = SignUpForm "jbond" "shaken007" False :: SignUpData --- @ - - ----------------------------------------------------------------------------- module Data.Barbie.Bare + {-# DEPRECATED "Use Barbies.Bare" #-} ( -- * Bare values - Wear - , Bare - , Covered + Barbies.Bare.Wear + , Barbies.Bare.Bare + , Barbies.Bare.Covered -- * Covering and stripping - , BareB(bstrip, bcover) - , bstripFrom - , bcoverWith - + , Barbies.Bare.BareB(bstrip, bcover) + , Barbies.Bare.bstripFrom + , Barbies.Bare.bcoverWith ) where -import Data.Barbie.Internal.Bare - ( Wear, Bare, Covered - , BareB(..) - , bstripFrom, bcoverWith - ) +import qualified Barbies.Bare diff --git a/src/Data/Barbie/Constraints.hs b/src/Data/Barbie/Constraints.hs --- a/src/Data/Barbie/Constraints.hs +++ b/src/Data/Barbie/Constraints.hs @@ -1,28 +1,5 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Barbie --- --- Support for operating on Barbie-types with constrained functions. --- --- 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.Barbie.bmap' 'showIt' :: 'Data.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@. --- --- This module adds support to overcome this problem. ----------------------------------------------------------------------------- module Data.Barbie.Constraints + {-# DEPRECATED "Use Data.Functor.Barbie or Barbie.Constraints" #-} ( -- * Instance dictionaries Dict(..) , requiringDict @@ -36,15 +13,10 @@ , AllBF , ClassF , ClassFG - - -- * Deprecated - , ConstraintsOf - , adjProof - , ProofB ) where -import Data.Barbie.Internal.Constraints -import Data.Barbie.Internal.Dicts +import Barbies.Internal.ConstraintsB +import Barbies.Internal.Dicts import Data.Barbie.Internal.ProductC diff --git a/src/Data/Barbie/Container.hs b/src/Data/Barbie/Container.hs deleted file mode 100644 --- a/src/Data/Barbie/Container.hs +++ /dev/null @@ -1,59 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Barbie.Container --- --- We get a container of @a@'s for any Barbie-type when we make it wear a --- @('Const' a)@ . The 'Container' wrapper gives us the expected --- instances for a container type. ----------------------------------------------------------------------------- -{-# LANGUAGE UndecidableInstances #-} -module Data.Barbie.Container - ( - Container(..) - ) - -where - -import Data.Barbie -import Data.Bifunctor (first) -import Data.Bitraversable (bitraverse) -import Data.Coerce (coerce) -import Data.Functor.Const -import Data.Functor.Prod (uncurryn) -import GHC.Generics (Generic) - --- | Wrapper for container-Barbies. -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 = - getConst . btraverse (coerce . first f) . getContainer - -instance TraversableB b => Traversable (Container b) where - traverse f = - fmap Container . btraverse (bitraverse f pure) . getContainer - -instance ProductB b => Applicative (Container b) where - pure a - = Container $ buniq (Const a) - - l <*> r - = Container $ bmap (uncurryn 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) - - diff --git a/src/Data/Barbie/Internal.hs b/src/Data/Barbie/Internal.hs deleted file mode 100644 --- a/src/Data/Barbie/Internal.hs +++ /dev/null @@ -1,51 +0,0 @@ -module Data.Barbie.Internal - ( -- * Functor - Internal.gbmapDefault - , Internal.GFunctorB(..) - , Internal.CanDeriveFunctorB - - -- * Traversable - , Internal.gbtraverseDefault - , Internal.GTraversableB(..) - , Internal.CanDeriveTraversableB - - -- * Product - , Internal.gbuniqDefault - , Internal.gbprodDefault - , Internal.GProductB(..) - , Internal.CanDeriveProductB - - -- * Constraints - , Internal.gbaddDictsDefault - , Internal.GConstraintsB(..) - , Internal.CanDeriveConstraintsB - , Internal.GAllBC(..) - , Internal.GAllBRep - , Internal.X - , Internal.TagSelf, Internal.Self, Internal.Other - - -- * Proof - , Internal.gbdictsDefault - , Internal.GProductBC(..) - , Internal.CanDeriveProductBC - - -- * Bare values - , Internal.gbcoverDefault - , Internal.gbstripDefault - , Internal.GBareB(..) - , Internal.CanDeriveBareB - - -- * Generic derivation support - , GenericN, Rec(..), RepN - ) - -where - -import qualified Data.Barbie.Internal.Bare as Internal -import qualified Data.Barbie.Internal.Constraints as Internal -import qualified Data.Barbie.Internal.Functor as Internal -import qualified Data.Barbie.Internal.Product as Internal -import qualified Data.Barbie.Internal.ProductC as Internal -import qualified Data.Barbie.Internal.Traversable as Internal - -import Data.Generics.GenericN (GenericN, Rec(..), RepN) diff --git a/src/Data/Barbie/Internal/Bare.hs b/src/Data/Barbie/Internal/Bare.hs deleted file mode 100644 --- a/src/Data/Barbie/Internal/Bare.hs +++ /dev/null @@ -1,159 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Data.Barbie.Internal.Bare - ( Wear, Bare, Covered - , BareB(..) - , bstripFrom, bcoverWith - - , GBareB(..) - , gbstripDefault - , gbcoverDefault - - , CanDeriveBareB - ) - -where - -import Data.Barbie.Internal.Functor (FunctorB(..)) -import Data.Barbie.Internal.Wear(Bare, Covered, Wear) -import Data.Functor.Identity (Identity(..)) - -import Data.Coerce (coerce) -import Data.Generics.GenericN - - --- | 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 - = ( GenericN (b Bare Identity) - , GenericN (b Covered Identity) - , GBareB (RepN (b Covered Identity)) (RepN (b Bare Identity)) - ) - --- | Default implementation of 'bstrip' based on 'Generic'. -gbstripDefault :: CanDeriveBareB b => b Covered Identity -> b Bare Identity -gbstripDefault - = toN . gbstrip . fromN -{-# INLINE gbstripDefault #-} - --- | Default implementation of 'bstrip' based on 'Generic'. -gbcoverDefault :: CanDeriveBareB b => b Bare Identity -> b Covered Identity -gbcoverDefault - = toN . gbcover . fromN -{-# INLINE gbcoverDefault #-} - - -class GBareB repbi repbb where - gbstrip :: repbi x -> repbb x - gbcover :: repbb x -> repbi x - --- ---------------------------------- --- Trivial cases --- ---------------------------------- - -instance GBareB repbi repbb => GBareB (M1 i k repbi) (M1 i k repbb) where - gbstrip = M1 . gbstrip . unM1 - {-# INLINE gbstrip #-} - - gbcover = M1 . gbcover . unM1 - {-# INLINE gbcover #-} - - -instance GBareB V1 V1 where - gbstrip _ = undefined - gbcover _ = undefined - -instance GBareB U1 U1 where - gbstrip = id - {-# INLINE gbstrip #-} - - gbcover = id - {-# INLINE gbcover #-} - - -instance (GBareB l l', GBareB r r') => GBareB (l :*: r) (l' :*: r') where - gbstrip (l :*: r) = (gbstrip l) :*: gbstrip r - {-# INLINE gbstrip #-} - - gbcover (l :*: r) = (gbcover l) :*: gbcover r - {-# INLINE gbcover #-} - - -instance (GBareB l l', GBareB r r') => GBareB (l :+: r) (l' :+: r') where - gbstrip = \case - L1 l -> L1 (gbstrip l) - R1 r -> R1 (gbstrip r) - {-# INLINE gbstrip #-} - - gbcover = \case - L1 l -> L1 (gbcover l) - R1 r -> R1 (gbcover r) - {-# INLINE gbcover #-} - --- -- -------------------------------- --- -- The interesting cases --- -- -------------------------------- - -type P = Param 0 - -instance GBareB (Rec (P Identity a) (Identity a)) (Rec a a) where - gbstrip = coerce - {-# INLINE gbstrip #-} - - gbcover = coerce - {-# INLINE gbcover #-} - - -instance BareB b => GBareB (Rec (b Covered (P Identity)) (b Covered Identity)) - (Rec (b Bare (P Identity)) (b Bare Identity)) where - gbstrip = Rec . K1 . bstrip . unK1 . unRec - {-# INLINE gbstrip #-} - - gbcover = Rec . K1 . bcover . unK1 . unRec - {-# INLINE gbcover #-} - - -instance (Functor h, BareB b) - => GBareB (Rec (h (b Covered (P Identity))) (h (b Covered Identity))) - (Rec (h (b Bare (P Identity))) (h (b Bare Identity))) where - gbstrip = Rec . K1 . fmap bstrip . unK1 . unRec - {-# INLINE gbstrip #-} - - gbcover = Rec . K1 . fmap bcover . unK1 . unRec - {-# INLINE gbcover #-} - - -instance repbi ~ repbb => GBareB (Rec repbi repbi) (Rec repbb repbb) where - gbstrip = id - {-# INLINE gbstrip #-} - - gbcover = id - {-# INLINE gbcover #-} diff --git a/src/Data/Barbie/Internal/Constraints.hs b/src/Data/Barbie/Internal/Constraints.hs deleted file mode 100644 --- a/src/Data/Barbie/Internal/Constraints.hs +++ /dev/null @@ -1,390 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE UndecidableInstances #-} -module Data.Barbie.Internal.Constraints - ( ConstraintsB(..) - , bmapC - , btraverseC - , AllBF - - , CanDeriveConstraintsB - , GAllBC(..) - , GAllBRep, X - , TagSelf, Self, Other - , GConstraintsB(..) - , gbaddDictsDefault - - -- DEPRECATED STUFF - , adjProof - , ConstraintsOf - ) - -where - -import Data.Barbie.Internal.Dicts (ClassF, Dict (..), requiringDict) -import Data.Barbie.Internal.Functor (FunctorB (..)) -import Data.Barbie.Internal.Traversable (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) -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 if we given a @T f@, we need to use the 'Show' instance of --- their fields, we can use: --- --- @ --- 'baddDicts' :: AllB Show b => b f -> b ('Dict' 'Show' `Product` b) --- @ --- --- 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 -> *) -> *) where - -- | @'AllB' c b@ should contain a constraint @c a@ for each - -- @a@ occurring under an @f@ in @b f@. E.g.: - -- - -- @ - -- 'AllB' 'Show' Barbie ~ ('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 = GAllB c (GAllBRep 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 - - --- | 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) -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 h - . (TraversableB b, ConstraintsB b, AllB c b, Applicative g) - => (forall a. c a => f a -> g (h a)) - -> b f - -> g (b h) -btraverseC f b = btraverse (\(Pair (Dict :: Dict c a) x) -> f x) (baddDicts b) - --- | Similar to 'AllB' but will put the functor argument @f@ --- between the constraint @c@ and the type @a@. For example: --- --- @ --- 'AllB' 'Show' Barbie ~ ('Show' 'String', 'Show' 'Int') --- 'AllBF' 'Show' f Barbie ~ ('Show' (f 'String'), 'Show' (f 'Int')) --- @ -type AllBF c f b = AllB (ClassF c f) b - - -{-# DEPRECATED ConstraintsOf "Renamed to AllBF (now based on AllB)" #-} -type ConstraintsOf c f b = AllBF c f b - -{-# DEPRECATED adjProof "Renamed to baddDicts" #-} -adjProof - :: forall b c f. (ConstraintsB b, AllB c b) => b f -> b (Dict c `Product` f) -adjProof = baddDicts - - --- | The representation used for the generic computation of the @'AllB' c b@ --- constraints. Here 'X' is an arbitrary constant since the actual --- argument to @b@ is irrelevant. -type GAllBRep b = TagSelf b (RepN (b X)) -data X a - --- | @'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 ~ GAllB c (GAllBRep b) - , GConstraintsB c f (GAllBRep b) (RepN (b f)) (RepN (b (Dict c `Product` f))) - ) - - --- =============================================================== --- 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 . gbaddDicts @c @f @(GAllBRep b) . fromN -{-# INLINE gbaddDictsDefault #-} - -class GAllBC (repbf :: * -> *) where - type GAllB (c :: k -> Constraint) repbf :: Constraint - -class GAllBC repbx => GConstraintsB c (f :: k -> *) repbx repbf repbdf where - gbaddDicts :: GAllB c repbx => repbf x -> repbdf x - - --- ---------------------------------- --- Trivial cases --- ---------------------------------- - -instance GAllBC repbf => GAllBC (M1 i k repbf) where - type GAllB c (M1 i k repbf) = GAllB c repbf - -instance - GConstraintsB c f repbx repbf repbdf - => GConstraintsB c f (M1 i k repbx) - (M1 i k repbf) - (M1 i k repbdf) where - gbaddDicts = M1 . gbaddDicts @c @f @repbx . unM1 - {-# INLINE gbaddDicts #-} - - - -instance GAllBC V1 where - type GAllB c V1 = () - -instance GConstraintsB c f V1 V1 V1 where - gbaddDicts _ = undefined - - - -instance GAllBC U1 where - type GAllB c U1 = () - -instance GConstraintsB c f U1 U1 U1 where - gbaddDicts = id - {-# INLINE gbaddDicts #-} - - -instance (GAllBC l, GAllBC r) => GAllBC (l :*: r) where - type GAllB c (l :*: r) = (GAllB c l, GAllB c r) - -instance - ( GConstraintsB c f lx lf ldf - , GConstraintsB c f rx rf rdf - ) => GConstraintsB c f (lx :*: rx) - (lf :*: rf) - (ldf :*: rdf) where - gbaddDicts (l :*: r) - = (gbaddDicts @c @f @lx l) :*: (gbaddDicts @c @f @rx r) - {-# INLINE gbaddDicts #-} - - -instance (GAllBC l, GAllBC r) => GAllBC (l :+: r) where - type GAllB c (l :+: r) = (GAllB c l, GAllB c r) - -instance - ( GConstraintsB c f lx lf ldf - , GConstraintsB c f rx rf rdf - ) => GConstraintsB c f (lx :+: rx) - (lf :+: rf) - (ldf :+: rdf) where - gbaddDicts = \case - L1 l -> L1 (gbaddDicts @c @f @lx l) - R1 r -> R1 (gbaddDicts @c @f @rx r) - {-# INLINE gbaddDicts #-} - - --- -------------------------------- --- The interesting cases --- -------------------------------- - -type P0 = Param 0 - - -instance GAllBC (Rec (P0 X a) (X a)) where - type GAllB c (Rec (P0 X a) (X a)) = c a - -instance GConstraintsB c f (Rec (P0 X a) (X a)) - (Rec (P0 f a) (f a)) - (Rec (P0 (Dict c `Product` f) a) - ((Dict c `Product` f) a)) where - gbaddDicts - = Rec . K1 . Pair Dict . unK1 . unRec - {-# INLINE gbaddDicts #-} - - - -instance GAllBC (Rec (Self b (P0 X)) (b X)) where - type GAllB c (Rec (Self b (P0 X)) (b X)) = () - -instance - ( ConstraintsB b - , AllB c b - ) => GConstraintsB c f (Rec (Self b (P0 X)) (b X)) - (Rec (b (P0 f)) (b f)) - (Rec (b (P0 (Dict c `Product` f))) - (b (Dict c `Product` f))) where - gbaddDicts - = Rec . K1 . baddDicts . unK1 . unRec - {-# INLINE gbaddDicts #-} - -instance - ( ConstraintsB b' - , SameOrParam b b' - ) => GAllBC (Rec (Other b (P0 X)) (b' X)) where - type GAllB c (Rec (Other b (P0 X)) (b' X)) = AllB c b' - -instance - ( SameOrParam b b' - , ConstraintsB b' - , AllB c b' - ) => GConstraintsB c f (Rec (Other b (P0 X)) (b' X)) - (Rec (b (P0 f)) (b' f)) - (Rec (b (P0 (Dict c `Product` f))) - (b' (Dict c `Product` f))) where - gbaddDicts - = Rec . K1 . baddDicts . unK1 . unRec - {-# INLINE gbaddDicts #-} - - - -instance GAllBC (Rec a a) where - type GAllB c (Rec a a) = () - -instance GConstraintsB c f (Rec a a) - (Rec a a) - (Rec a a) where - gbaddDicts = id - {-# INLINE gbaddDicts #-} - - --- ============================================================================ --- ## Identifying recursive usages of the barbie-type ## --- --- ============================================================================ - -data Self (b :: (k -> *) -> *) (f :: k -> *) -data Other (b :: (k -> *) -> *) (f :: k -> *) - --- | We use type-families to generically compute @'AllB' c b@. Intuitively, if --- @b' f@ occurs inside @b f@, then we should just add @AllB b' c@ to --- @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 `AllB b f` to break the recursion. Our trick will be to use a type --- family to inspect @RepN (b f)@ and distinguish recursive usages from --- non-recursive ones, tagging them with different types, so we can distinguish --- them in the instances. -type family TagSelf (b :: (k -> *) -> *) (repbf :: * -> *) :: * -> * where - TagSelf b (M1 mt m s) - = M1 mt m (TagSelf b s) - - TagSelf b (l :+: r) - = TagSelf b l :+: TagSelf b r - - TagSelf b (l :*: r) - = TagSelf b l :*: TagSelf b r - - TagSelf b (Rec (b f) (b g)) - = Rec (Self b f) (b g) - - TagSelf (b :: (k -> *) -> *) (Rec (b' f) ((b'' :: (k -> *) -> *) g)) - = Rec (Other b' f) (b'' g) - - TagSelf b (Rec p a) - = Rec p a - - TagSelf b U1 - = U1 - - TagSelf b V1 - = V1 - - --- -------------------------------- --- 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 #-} diff --git a/src/Data/Barbie/Internal/Dicts.hs b/src/Data/Barbie/Internal/Dicts.hs deleted file mode 100644 --- a/src/Data/Barbie/Internal/Dicts.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} -module Data.Barbie.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 -> '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 diff --git a/src/Data/Barbie/Internal/Functor.hs b/src/Data/Barbie/Internal/Functor.hs deleted file mode 100644 --- a/src/Data/Barbie/Internal/Functor.hs +++ /dev/null @@ -1,153 +0,0 @@ -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -module Data.Barbie.Internal.Functor - ( FunctorB(..) - - , GFunctorB(..) - , gbmapDefault - , CanDeriveFunctorB - ) - -where - -import Data.Functor.Compose (Compose (..)) -import Data.Functor.Const (Const (..)) -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 - = ( GenericN (b f) - , GenericN (b g) - , GFunctorB f g (RepN (b f)) (RepN (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 - = toN . gbmap f . fromN -{-# INLINE gbmapDefault #-} - - -class GFunctorB f g repbf repbg where - gbmap :: (forall a . f a -> g a) -> repbf x -> repbg x - - --- ---------------------------------- --- Trivial cases --- ---------------------------------- - -instance GFunctorB f g bf bg => GFunctorB f g (M1 i c bf) (M1 i c bg) where - gbmap h = M1 . gbmap h . unM1 - {-# INLINE gbmap #-} - -instance GFunctorB f g V1 V1 where - gbmap _ _ = undefined - -instance GFunctorB f g U1 U1 where - gbmap _ = id - {-# INLINE gbmap #-} - -instance(GFunctorB f g l l', GFunctorB f g r r') => GFunctorB f g (l :*: r) (l' :*: r') where - gbmap h (l :*: r) = (gbmap h l) :*: gbmap h r - {-# INLINE gbmap #-} - -instance(GFunctorB f g l l', GFunctorB f g r r') => GFunctorB f g (l :+: r) (l' :+: r') where - gbmap h = \case - L1 l -> L1 (gbmap h l) - R1 r -> R1 (gbmap h r) - {-# INLINE gbmap #-} - - --- -------------------------------- --- The interesting cases --- -------------------------------- - -type P0 = Param 0 - -instance GFunctorB f g (Rec (P0 f a) (f a)) - (Rec (P0 g a) (g a)) where - gbmap h (Rec (K1 fa)) = Rec (K1 (h fa)) - {-# INLINE gbmap #-} - -instance - ( SameOrParam b b' - , FunctorB b' - ) => GFunctorB f g (Rec (b (P0 f)) (b' f)) - (Rec (b (P0 g)) (b' g)) where - gbmap h (Rec (K1 bf)) = Rec (K1 (bmap h bf)) - {-# INLINE gbmap #-} - -instance - ( SameOrParam h h' - , SameOrParam b b' - , Functor h' - , FunctorB b' - ) => GFunctorB f g (Rec (h (b (P0 f))) (h' (b' f))) - (Rec (h (b (P0 g))) (h' (b' g))) where - gbmap h (Rec (K1 hbf)) = Rec (K1 (fmap (bmap h) hbf)) - {-# INLINE gbmap #-} - -instance GFunctorB f g (Rec x x) (Rec x x) where - gbmap _ = id - {-# INLINE gbmap #-} - - --- -------------------------------- --- 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 #-} diff --git a/src/Data/Barbie/Internal/Instances.hs b/src/Data/Barbie/Internal/Instances.hs deleted file mode 100644 --- a/src/Data/Barbie/Internal/Instances.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -module Data.Barbie.Internal.Instances ( Barbie(..) ) - -where - -import Data.Barbie.Internal.Constraints -import Data.Barbie.Internal.Dicts -import Data.Barbie.Internal.Functor -import Data.Barbie.Internal.Traversable -import Data.Barbie.Internal.Product -import Data.Barbie.Internal.ProductC - -import Data.Kind (Type) -import Data.Semigroup (Semigroup, (<>)) - --- | A wrapper for Barbie-types, providing useful instances. -newtype Barbie (b :: (k -> Type) -> Type) f - = Barbie { getBarbie :: b f } - deriving (FunctorB, ProductB, ProductBC) - --- 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 (ProductBC b, AllBF Semigroup f b) => Semigroup (Barbie b f) where - (<>) = bzipWith3 mk bdicts - where - mk :: Dict (ClassF Semigroup f) a -> f a -> f a -> f a - mk = requiringDict (<>) - -instance (ProductBC b, AllBF Semigroup f b, AllBF Monoid f b) => Monoid (Barbie b f) where - mempty = bmempty - mappend = (<>) diff --git a/src/Data/Barbie/Internal/Product.hs b/src/Data/Barbie/Internal/Product.hs --- a/src/Data/Barbie/Internal/Product.hs +++ b/src/Data/Barbie/Internal/Product.hs @@ -2,21 +2,21 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans -Wno-deprecations #-} module Data.Barbie.Internal.Product ( ProductB(buniq, bprod) - , bzip, bunzip, bzipWith, bzipWith3, bzipWith4 - , (/*/), (/*) - , CanDeriveProductB - , GProductB(..) , gbprodDefault, gbuniqDefault + , GProductB(..) ) where -import Data.Barbie.Internal.Functor (FunctorB (..)) +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.Prod import Data.Functor.Product (Product (..)) import Data.Kind (Type) import Data.Proxy (Proxy (..)) @@ -24,45 +24,9 @@ import Data.Generics.GenericN --- | Barbie-types that can form products, subject to the laws: --- --- @ --- 'bmap' (\\('Pair' a _) -> a) . 'uncurry' 'bprod' = 'fst' --- 'bmap' (\\('Pair' _ b) -> b) . 'uncurry' 'bprod' = 'snd' --- @ --- --- Notice that because of the laws, having an internal product structure is not --- enough to have a lawful instance. E.g. --- --- @ --- data Ok f = Ok {o1 :: f 'String', o2 :: f 'Int'} --- data Bad f = Bad{b1 :: f 'String', hiddenFromArg: 'Int'} -- no lawful instance --- @ --- --- Intuitively, the laws for this class require that `b` hides no structure --- from its argument @f@. Because of this, if we are given any: --- --- @ --- x :: forall a . f a --- @ --- --- then this determines a unique value of type @b f@, witnessed by the 'buniq' --- method. --- For example: --- --- @ --- 'buniq' x = Ok {o1 = x, o2 = x} --- @ --- --- Formally, 'buniq' should satisfy: --- --- @ --- 'const' ('buniq' x) = 'bmap' ('const' x) --- @ --- --- There is a default implementation of 'bprod' and 'buniq' for 'Generic' types, --- so instances can derived automatically. -class FunctorB b => ProductB (b :: (k -> Type) -> Type) where +{-# DEPRECATED ProductB "Use ApplicativeB" #-} +{-# DEPRECATED buniq "Use bpure" #-} +class App.ApplicativeB b => ProductB (b :: (k -> Type) -> Type) where bprod :: b f -> b g -> b (f `Product` g) buniq :: (forall a . f a) -> b f @@ -74,48 +38,7 @@ buniq = gbuniqDefault --- | An alias of 'bprod', since this is like a 'zip' for Barbie-types. -bzip :: ProductB b => b f -> b g -> b (f `Product` g) -bzip = bprod --- | An equivalent of 'unzip' for Barbie-types. -bunzip :: ProductB b => b (f `Product` g) -> (b f, b g) -bunzip bfg = (bmap (\(Pair a _) -> a) bfg, bmap (\(Pair _ b) -> b) bfg) - --- | An equivalent of 'Data.List.zipWith' for Barbie-types. -bzipWith :: ProductB b => (forall a. f a -> g a -> h a) -> b f -> b g -> b h -bzipWith f bf bg - = bmap (\(Pair fa ga) -> f fa ga) (bf `bprod` bg) - --- | An equivalent of 'Data.List.zipWith3' for Barbie-types. -bzipWith3 - :: ProductB b - => (forall a. f a -> g a -> h a -> i a) - -> b f -> b g -> b h -> b i -bzipWith3 f bf bg bh - = bmap (\(Pair (Pair fa ga) ha) -> f fa ga ha) - (bf `bprod` bg `bprod` bh) - - --- | An equivalent of 'Data.List.zipWith4' for Barbie-types. -bzipWith4 - :: ProductB b - => (forall a. f a -> g a -> h a -> i a -> j a) - -> b f -> b g -> b h -> b i -> b j -bzipWith4 f bf bg bh bi - = bmap (\(Pair (Pair (Pair fa ga) ha) ia) -> f fa ga ha ia) - (bf `bprod` bg `bprod` bh `bprod` bi) - - --- | @'CanDeriveProductB' B f g@ is in practice a predicate about @B@ only. --- Intuitively, it says that the following holds, for any arbitrary @f@: --- --- * There is an instance of @'Generic' (B f)@. --- --- * @B@ has only one constructor (that is, it is not a sum-type). --- --- * Every field of @B f@ is of the form @f a@, for some type @a@. --- In other words, @B@ has no "hidden" structure. type CanDeriveProductB b f g = ( GenericN (b f) , GenericN (b g) @@ -123,32 +46,15 @@ , 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 --- | 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 /*/ +instance ProductB Unit where --- | Similar to '/*/' but one of the sides is already a @'Prod' fs@. --- --- Note that '/*', '/*/' and '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 `uncurryn` on an n-ary function. E.g. --- --- @ --- f :: f a -> g a -> h a -> i a --- --- 'bmap' ('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 /* +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 @@ -160,18 +66,18 @@ . CanDeriveProductB b f g => b f -> b g -> b (f `Product` g) gbprodDefault l r - = toN $ gbprod @f @g (fromN l) (fromN 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 @f @f @_ @(RepN (b f)) @(RepN (b (f `Product` f))) x) + = toN $ gbuniq (Proxy @f) (Proxy @(RepN (b f))) (Proxy @(RepN (b (f `Product` f)))) x {-# INLINE gbuniqDefault #-} class GProductB (f :: k -> *) (g :: k -> *) repbf repbg repbfg where - gbprod :: repbf x -> repbg x -> repbfg x + gbprod :: Proxy f -> Proxy g -> repbf x -> repbg x -> repbfg x - gbuniq :: (forall a . f a) -> repbf x + gbuniq :: (f ~ g, repbf ~ repbg) => Proxy f -> Proxy repbf -> Proxy repbfg -> (forall a . f a) -> repbf x -- ---------------------------------- -- Trivial cases @@ -180,18 +86,18 @@ instance GProductB f g repf repg repfg => GProductB f g (M1 i c repf) (M1 i c repg) (M1 i c repfg) where - gbprod (M1 l) (M1 r) = M1 (gbprod @f @g l r) + gbprod pf pg (M1 l) (M1 r) = M1 (gbprod pf pg l r) {-# INLINE gbprod #-} - gbuniq x = M1 (gbuniq @f @g @repf @repg @repfg x) + 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 + gbprod _ _ U1 U1 = U1 {-# INLINE gbprod #-} - gbuniq _ = U1 + gbuniq _ _ _ _ = U1 {-# INLINE gbuniq #-} instance @@ -200,45 +106,44 @@ ) => GProductB f g (lf :*: rf) (lg :*: rg) (lfg :*: rfg) where - gbprod (l1 :*: l2) (r1 :*: r2) + gbprod pf pg (l1 :*: l2) (r1 :*: r2) = (l1 `lprod` r1) :*: (l2 `rprod` r2) where - lprod = gbprod @f @g - rprod = gbprod @f @g + lprod = gbprod pf pg + rprod = gbprod pf pg {-# INLINE gbprod #-} - gbuniq x = (gbuniq @f @g @lf @lg @lfg x :*: gbuniq @f @g @rf @rg @rfg x) + 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) (f a)) - (Rec (P0 g a) (g a)) - (Rec (P0 (f `Product` g) a) ((f `Product` g) a)) where - gbprod (Rec (K1 fa)) (Rec (K1 ga)) +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) + gbuniq _ _ _ x = Rec (K1 x) {-# INLINE gbuniq #-} +-- b' is b, maybe with 'Param' annotations instance - ( SameOrParam b b' - , 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)) + ( 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)) + gbuniq _ _ _ x = Rec (K1 (buniq x)) {-# INLINE gbuniq #-} diff --git a/src/Data/Barbie/Internal/ProductC.hs b/src/Data/Barbie/Internal/ProductC.hs --- a/src/Data/Barbie/Internal/ProductC.hs +++ b/src/Data/Barbie/Internal/ProductC.hs @@ -2,99 +2,63 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-deprecations #-} module Data.Barbie.Internal.ProductC ( ProductBC(..) , buniqC - , bmempty , CanDeriveProductBC - , GAllB + , GAll , GProductBC(..) , gbdictsDefault - - -- DEPRECATED STUFF - , ProofB - , bproof ) where -import Data.Barbie.Internal.Constraints -import Data.Barbie.Internal.Dicts (ClassF, Dict (..), requiringDict) -import Data.Barbie.Internal.Functor (bmap) -import Data.Barbie.Internal.Product (ProductB (..)) -import Data.Kind (Type) +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.Proxy (Proxy (..)) +import Data.Kind(Type) +import Data.Proxy(Proxy (..)) --- | Every type @b@ that is an instance of both 'ProductB' and --- 'ConstraintsB' can be made an instance of 'ProductBC' --- as well. --- --- Intuitively, in addition to 'buniq' from 'ProductB', one --- can define 'buniqC' that takes into account constraints: --- --- @ --- 'buniq' :: (forall a . f a) -> b f --- 'buniqC' :: 'AllB' c b => (forall a . c a => f a) -> b f --- @ --- --- For technical reasons, 'buniqC' is not currently provided --- as a method of this class and is instead defined in terms --- 'bdicts', which is similar to 'baddDicts' but can produce the --- instance dictionaries out-of-the-blue. 'bdicts' could also be --- defined in terms of 'buniqC', so they are essentially equivalent. --- --- @ --- 'bdicts' :: forall c b . 'AllB' c b => b ('Dict' c) --- 'bdicts' = 'buniqC' ('Dict' @c) --- @ --- --- --- There is a default implementation for 'Generic' types, so --- instances can derived automatically. class (ConstraintsB b, ProductB b) => ProductBC (b :: (k -> Type) -> Type) where bdicts :: AllB c b => b (Dict c) default bdicts :: (CanDeriveProductBC c b, AllB c b) => b (Dict c) bdicts = gbdictsDefault --- | Every type that admits a generic instance of 'ProductB' and --- 'ConstraintsB', has a generic instance of 'ProductBC' as well. + type CanDeriveProductBC c b = ( GenericN (b (Dict c)) - , AllB c b ~ GAllB c (GAllBRep b) - , GProductBC c (GAllBRep b) (RepN (b (Dict c))) + , AllB c b ~ GAll 0 c (GAllRepB b) + , GProductBC c (GAllRepB b) (RepN (b (Dict c))) ) --- | Like 'buniq' but a constraint is allowed to be required on --- each element of @b@. +{-# DEPRECATED buniqC "Use bpureC instead" #-} buniqC :: forall c f b . (AllB c b, ProductBC b) => (forall a . c a => f a) -> b f buniqC x = bmap (requiringDict @c x) bdicts --- | Builds a @b f@, by applying 'mempty' on every field of @b@. -bmempty :: forall f b . (AllBF Monoid f b, ProductBC b) => b f -bmempty - = buniqC @(ClassF Monoid f) mempty - - -{-# DEPRECATED bproof "Renamed to bdicts" #-} -bproof :: forall b c . (ProductBC b, AllB c b) => b (Dict c) -bproof = bdicts +instance ProductBC b => ProductBC (Barbie b) where + bdicts = Barbie bdicts -{-# DEPRECATED ProofB "Class was renamed to ProductBC" #-} -type ProofB b = ProductBC b +instance ProductBC Unit where + bdicts = Unit -- =============================================================== -- Generic derivations -- =============================================================== --- | Default implementation of 'bproof' based on 'Generic'. +-- | Default implementation of 'bdicts' based on 'Generic'. gbdictsDefault :: forall b c . ( CanDeriveProductBC c b @@ -102,12 +66,12 @@ ) => b (Dict c) gbdictsDefault - = toN $ gbdicts @c @(GAllBRep b) + = toN $ gbdicts @c @(GAllRepB b) {-# INLINE gbdictsDefault #-} class GProductBC c repbx repbd where - gbdicts :: GAllB c repbx => repbd x + gbdicts :: GAll 0 c repbx => repbd x -- ---------------------------------- -- Trivial cases @@ -136,27 +100,26 @@ type P0 = Param 0 -instance GProductBC c (Rec (P0 X a) (X a)) - (Rec (P0 (Dict c) a) (Dict c a)) where +instance 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 (Rec (Self b (P0 X)) (b X)) - (Rec (b (P0 (Dict c))) + ) => GProductBC c (Rec (Self b' (P0 X)) (b X)) + (Rec (b' (P0 (Dict c))) (b (Dict c))) where gbdicts = Rec $ K1 $ bdicts @_ @b instance - ( SameOrParam b b' - , ProductBC b' - , AllB c b' - ) => GProductBC c (Rec (Other b (P0 X)) (b' X)) - (Rec (b (P0 (Dict c))) - (b' (Dict c))) where - gbdicts = Rec $ K1 $ bdicts @_ @b' + ( ProductBC b + , AllB c b + ) => GProductBC c (Rec (Other b' (P0 X)) (b X)) + (Rec (b' (P0 (Dict c))) + (b (Dict c))) where + gbdicts = Rec $ K1 $ bdicts @_ @b -- -------------------------------- diff --git a/src/Data/Barbie/Internal/Traversable.hs b/src/Data/Barbie/Internal/Traversable.hs deleted file mode 100644 --- a/src/Data/Barbie/Internal/Traversable.hs +++ /dev/null @@ -1,237 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Barbie.Internal.Traversable ----------------------------------------------------------------------------- -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -module Data.Barbie.Internal.Traversable - ( TraversableB(..) - , btraverse_ - , bsequence - , bsequence' - , bfoldMap - - , CanDeriveTraversableB - , GTraversableB(..) - , gbtraverseDefault - ) - -where - -import Data.Barbie.Internal.Functor (FunctorB (..)) - -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.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 t => (forall a . f a -> t (g a)) -> b f -> t (b g) - - default btraverse - :: ( Applicative t, CanDeriveTraversableB b f g) - => (forall a . f a -> t (g a)) -> b f -> t (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 t) => (forall a. f a -> t c) -> b f -> t () -btraverse_ f - = void . btraverse (fmap (const $ Const ()) . f) - - --- | Evaluate each action in the structure from left to right, --- and collect the results. -bsequence :: (Applicative f, TraversableB b) => b (Compose f g) -> f (b g) -bsequence - = btraverse getCompose - --- | A version of 'bsequence' with @g@ specialized to 'Identity'. -bsequence' :: (Applicative f, TraversableB b) => b f -> f (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 'Data.Barbie.Internal.Functor.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 - = ( GenericN (b f) - , GenericN (b g) - , GTraversableB f g (RepN (b f)) (RepN (b g)) - ) - --- | Default implementation of 'btraverse' based on 'Generic'. -gbtraverseDefault - :: forall b f g t - . (Applicative t, CanDeriveTraversableB b f g) - => (forall a . f a -> t (g a)) - -> b f -> t (b g) -gbtraverseDefault h - = fmap toN . gbtraverse h . fromN -{-# INLINE gbtraverseDefault #-} - - -class GTraversableB f g repbf repbg where - gbtraverse - :: Applicative t => (forall a . f a -> t (g a)) -> repbf x -> t (repbg x) - --- ---------------------------------- --- Trivial cases --- ---------------------------------- - -instance GTraversableB f g bf bg => GTraversableB f g (M1 i c bf) (M1 i c bg) where - gbtraverse h = fmap M1 . gbtraverse h . unM1 - {-# INLINE gbtraverse #-} - -instance GTraversableB f g V1 V1 where - gbtraverse _ _ = undefined - {-# INLINE gbtraverse #-} - -instance GTraversableB f g U1 U1 where - gbtraverse _ = pure - {-# INLINE gbtraverse #-} - -instance (GTraversableB f g l l', GTraversableB f g r r') => GTraversableB f g (l :*: r) (l' :*: r') where - gbtraverse h (l :*: r) = (:*:) <$> gbtraverse h l <*> gbtraverse h r - {-# INLINE gbtraverse #-} - -instance (GTraversableB f g l l', GTraversableB f g r r') => GTraversableB f g (l :+: r) (l' :+: r') where - gbtraverse h = \case - L1 l -> L1 <$> gbtraverse h l - R1 r -> R1 <$> gbtraverse h r - {-# INLINE gbtraverse #-} - - --- -------------------------------- --- The interesting cases --- -------------------------------- - -type P0 = Param 0 - -instance GTraversableB f g (Rec (P0 f a) (f a)) - (Rec (P0 g a) (g a)) where - gbtraverse h = fmap (Rec . K1) . h . unK1 . unRec - {-# INLINE gbtraverse #-} - -instance - ( SameOrParam b b' - , TraversableB b' - ) => GTraversableB f g (Rec (b (P0 f)) (b' f)) - (Rec (b (P0 g)) (b' g)) where - gbtraverse h - = fmap (Rec . K1) . btraverse h . unK1 . unRec - {-# INLINE gbtraverse #-} - -instance - ( SameOrParam h h' - , SameOrParam b b' - , Traversable h' - , TraversableB b' - ) => GTraversableB f g (Rec (h (b (P0 f))) (h' (b' f))) - (Rec (h (b (P0 g))) (h' (b' g))) where - gbtraverse h - = fmap (Rec . K1) . traverse (btraverse h) . unK1 . unRec - {-# INLINE gbtraverse #-} - - -instance GTraversableB f g (Rec a a) (Rec a a) where - gbtraverse _ = pure - {-# INLINE gbtraverse #-} - - - - --- 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 (<*>) #-} - -type Wr = St - -execWr :: Monoid w => Wr w a -> w -execWr - = snd . runSt mempty - -tell :: Monoid w => w -> Wr w () -tell w - = St (\s -> ((), s `mappend` w)) - - --- 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 #-} diff --git a/src/Data/Barbie/Internal/Wear.hs b/src/Data/Barbie/Internal/Wear.hs deleted file mode 100644 --- a/src/Data/Barbie/Internal/Wear.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -module Data.Barbie.Internal.Wear - ( Wear, Bare, Covered - ) - -where - -import GHC.TypeLits (ErrorMessage (..), TypeError) - -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 t _ _ = TypeError ( 'Text "`Wear` should only be used with " - ':<>: 'Text "`Bare` or `Covered`." - ':$$: 'Text "`" ':<>: 'ShowType t ':<>: 'Text "`" - ':<>: 'Text " is not allowed in this context." - ) diff --git a/src/Data/Barbie/Trivial.hs b/src/Data/Barbie/Trivial.hs deleted file mode 100644 --- a/src/Data/Barbie/Trivial.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE PolyKinds #-} -module Data.Barbie.Trivial - ( Void - , Unit (..) - ) - -where - -import Data.Barbie.Internal.Constraints(ConstraintsB(..)) -import Data.Barbie.Internal.Functor(FunctorB(..)) -import Data.Barbie.Internal.Product(ProductB(..)) -import Data.Barbie.Internal.ProductC(ProductBC(..)) -import Data.Barbie.Internal.Traversable(TraversableB(..)) - -import Data.Data (Data(..)) -import Data.Kind (Type) -import Data.Semigroup (Semigroup(..)) -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 TraversableB Unit -instance ProductB Unit -instance ConstraintsB Unit -instance ProductBC Unit diff --git a/src/Data/Functor/Barbie.hs b/src/Data/Functor/Barbie.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Barbie.hs @@ -0,0 +1,72 @@ +----------------------------------------------------------------------------- +-- | +-- 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' + + -- * 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.TraversableB as Trav + +import qualified Data.Generics.GenericN as GenericN diff --git a/src/Data/Functor/Prod.hs b/src/Data/Functor/Prod.hs --- a/src/Data/Functor/Prod.hs +++ b/src/Data/Functor/Prod.hs @@ -19,7 +19,8 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} module Data.Functor.Prod - ( -- * n-tuples of functors. + {-# DEPRECATED "The module is no longer part of the main api and will be removed " #-} + ( -- * n-tuples of functors. Prod(Unit, Cons) , zeroTuple , oneTuple diff --git a/src/Data/Functor/Transformer.hs b/src/Data/Functor/Transformer.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Transformer.hs @@ -0,0 +1,52 @@ +----------------------------------------------------------------------------- +-- | +-- 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' + + -- * 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.FunctorT as Func +import qualified Barbies.Internal.MonadT as Mon +import qualified Barbies.Internal.TraversableT as Trav + +import qualified Data.Generics.GenericN as GenericsN diff --git a/src/Data/Generics/GenericN.hs b/src/Data/Generics/GenericN.hs --- a/src/Data/Generics/GenericN.hs +++ b/src/Data/Generics/GenericN.hs @@ -22,23 +22,32 @@ module Data.Generics.GenericN ( Param - , SameOrParam + , 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 Param (n :: Nat) (original :: k -> k') (a :: k) +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 @@ -77,12 +86,23 @@ 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 --- | @'SameOrParam' a b@ holds iff @a ~ b@ or @'Param' n a ~ b@. --- It is useful when defining generic instances and one don't --- want to differentiate the case of a parameter-usage from --- the usage of a constant. -class SameOrParam (a :: k) (b :: k) -instance SameOrParam a a -instance SameOrParam (Param n a) a -instance SameOrParam a (Param n a) +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 #-} diff --git a/test-legacy/Legacy/Clothes.hs b/test-legacy/Legacy/Clothes.hs new file mode 100644 --- /dev/null +++ b/test-legacy/Legacy/Clothes.hs @@ -0,0 +1,189 @@ +{-# 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>" diff --git a/test-legacy/Legacy/Spec.hs b/test-legacy/Legacy/Spec.hs new file mode 100644 --- /dev/null +++ b/test-legacy/Legacy/Spec.hs @@ -0,0 +1,204 @@ +import Test.Tasty (defaultMain, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +import qualified Legacy.Spec.Bare as Bare +import qualified Legacy.Spec.Constraints as Constraints +import qualified Legacy.Spec.Functor as Functor +import qualified Legacy.Spec.Product as Product +import qualified Legacy.Spec.Traversable as Traversable +import qualified Legacy.Spec.Wrapper as Wrapper + +import Legacy.TestBarbies +import Legacy.TestBarbiesW + +import Data.Barbie (bfoldMap, bmapC, btraverseC, buniqC) +import Data.Barbie.Bare (Covered) +import Data.Functor.Const (Const (..)) +import Data.Functor.Identity (Identity (..)) +import Data.Monoid (Sum (..)) + +main :: IO () +main + = defaultMain $ + testGroup "Tests" + [ testGroup "Functor Laws" + [ Functor.laws @Record0 + , Functor.laws @Record1 + , Functor.laws @Record3 + + , Functor.laws @Record1S + , Functor.laws @Record3S + + , Functor.laws @(Record1W Covered) + , Functor.laws @(Record3W Covered) + + , Functor.laws @(Record1WS Covered) + , Functor.laws @(Record3WS Covered) + + , Functor.laws @Ignore1 + + , Functor.laws @Sum3 + , Functor.laws @SumRec + + , Functor.laws @(Sum3W Covered) + , Functor.laws @(SumRecW Covered) + + , Functor.laws @CompositeRecord + , Functor.laws @NestedF + + , Functor.laws @(CompositeRecordW Covered) + ] + + , testGroup "Traversable Laws" + [ Traversable.laws @Record0 + , Traversable.laws @Record1 + , Traversable.laws @Record3 + + , Traversable.laws @Record1S + , Traversable.laws @Record3S + + , Traversable.laws @(Record1W Covered) + , Traversable.laws @(Record3W Covered) + + , Traversable.laws @(Record1WS Covered) + , Traversable.laws @(Record3WS Covered) + + , Traversable.laws @Ignore1 + + , Traversable.laws @Sum3 + , Traversable.laws @SumRec + + , Traversable.laws @(Sum3W Covered) + , Traversable.laws @(SumRecW Covered) + + , Traversable.laws @CompositeRecord + , Traversable.laws @NestedF + + , Traversable.laws @(CompositeRecordW Covered) + ] + + , testGroup "Product Laws" + [ Product.laws @Record0 + , Product.laws @Record1 + , Product.laws @Record3 + , Product.laws @CompositeRecord + + , Product.laws @Record1S + , Product.laws @Record3S + + , Product.laws @(Record1W Covered) + , Product.laws @(Record3W Covered) + , Product.laws @(CompositeRecordW Covered) + + , Product.laws @(Record1WS Covered) + , Product.laws @(Record3WS Covered) + ] + + , testGroup "Uniq Laws" + [ Product.uniqLaws @Record0 + , Product.uniqLaws @Record1 + , Product.uniqLaws @Record3 + , Product.uniqLaws @CompositeRecord + + , Product.uniqLaws @Record1S + , Product.uniqLaws @Record3S + + , Product.uniqLaws @(Record1W Covered) + , Product.uniqLaws @(Record3W Covered) + , Product.uniqLaws @(CompositeRecordW Covered) + + , Product.uniqLaws @(Record1WS Covered) + , Product.uniqLaws @(Record3WS Covered) + ] + + , testGroup "adDict projection" + [ Constraints.lawAddDictPrj @Record0 + , Constraints.lawAddDictPrj @Record1 + , Constraints.lawAddDictPrj @Record3 + + , Constraints.lawAddDictPrj @Record1S + , Constraints.lawAddDictPrj @Record3S + + , Constraints.lawAddDictPrj @(Record1W Covered) + , Constraints.lawAddDictPrj @(Record3W Covered) + + , Constraints.lawAddDictPrj @(Record1WS Covered) + , Constraints.lawAddDictPrj @(Record3WS Covered) + + , Constraints.lawAddDictPrj @Ignore1 + + , Constraints.lawAddDictPrj @Sum3 + , Constraints.lawAddDictPrj @SumRec + + , Constraints.lawAddDictPrj @(Sum3W Covered) + , Constraints.lawAddDictPrj @(SumRecW Covered) + + , Constraints.lawAddDictPrj @CompositeRecord + , Constraints.lawAddDictPrj @(CompositeRecordW Covered) + ] + + , testGroup "bdicts projection" + [ Constraints.lawDictsEquivPrj @Record0 + , Constraints.lawDictsEquivPrj @Record1 + , Constraints.lawDictsEquivPrj @Record3 + , Constraints.lawDictsEquivPrj @CompositeRecord + + , Constraints.lawDictsEquivPrj @Record1S + , Constraints.lawDictsEquivPrj @Record3S + + , Constraints.lawDictsEquivPrj @(Record1W Covered) + , Constraints.lawDictsEquivPrj @(Record3W Covered) + , Constraints.lawDictsEquivPrj @(CompositeRecordW Covered) + + , Constraints.lawDictsEquivPrj @(Record1WS Covered) + , Constraints.lawDictsEquivPrj @(Record3WS Covered) + ] + + , testGroup "Bare laws" + [ Bare.laws @Record1W + , Bare.laws @Record3W + , Bare.laws @Record1WS + , Bare.laws @Record3WS + , Bare.laws @Sum3W + , Bare.laws @SumRecW + , Bare.laws @NestedFW + ] + + , testGroup "Generic wrapper" + [ Wrapper.lawsMonoid @Record1 + , Wrapper.lawsMonoid @(Record1W Covered) + + , Wrapper.lawsMonoid @Record1S + , Wrapper.lawsMonoid @(Record1WS Covered) + + , Wrapper.lawsMonoid @Record3 + , Wrapper.lawsMonoid @(Record3W Covered) + + , Wrapper.lawsMonoid @Record3S + , Wrapper.lawsMonoid @(Record3WS Covered) + ] + + , testGroup "bfoldMap" + [ testCase "Record3" $ do + let b = Record3 (Const "tic") (Const "tac") (Const "toe") + bfoldMap getConst b @?= "tictactoe" + ] + , testGroup + "bmapC" + [ testCase "Record1" $ + bmapC @Num (fmap (+1)) (Record1 (Identity 0)) + @?= Record1 (Identity 1) + ] + , testGroup + "btraverseC" + [ testCase "Record1" $ + btraverseC @Num (\inner -> (Sum @Int 1, fmap (+ 1) inner)) (Record1 (Identity 0)) + @?= (Sum 1, Record1 (Identity 1)) + ] + , testGroup + "buniqC" + [ testCase "Record1" $ + buniqC @Num (Identity (fromIntegral (42 :: Int))) + @?= Record1 (Identity 42) + ] + ] diff --git a/test-legacy/Legacy/Spec/Bare.hs b/test-legacy/Legacy/Spec/Bare.hs new file mode 100644 --- /dev/null +++ b/test-legacy/Legacy/Spec/Bare.hs @@ -0,0 +1,30 @@ +{-# 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) + ] diff --git a/test-legacy/Legacy/Spec/Constraints.hs b/test-legacy/Legacy/Spec/Constraints.hs new file mode 100644 --- /dev/null +++ b/test-legacy/Legacy/Spec/Constraints.hs @@ -0,0 +1,49 @@ +{-# 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 diff --git a/test-legacy/Legacy/Spec/Functor.hs b/test-legacy/Legacy/Spec/Functor.hs new file mode 100644 --- /dev/null +++ b/test-legacy/Legacy/Spec/Functor.hs @@ -0,0 +1,32 @@ +{-# 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) + ] diff --git a/test-legacy/Legacy/Spec/Product.hs b/test-legacy/Legacy/Spec/Product.hs new file mode 100644 --- /dev/null +++ b/test-legacy/Legacy/Spec/Product.hs @@ -0,0 +1,45 @@ +{-# 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 diff --git a/test-legacy/Legacy/Spec/Traversable.hs b/test-legacy/Legacy/Spec/Traversable.hs new file mode 100644 --- /dev/null +++ b/test-legacy/Legacy/Spec/Traversable.hs @@ -0,0 +1,44 @@ +{-# 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) + ] diff --git a/test-legacy/Legacy/Spec/Wrapper.hs b/test-legacy/Legacy/Spec/Wrapper.hs new file mode 100644 --- /dev/null +++ b/test-legacy/Legacy/Spec/Wrapper.hs @@ -0,0 +1,37 @@ +{-# 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 diff --git a/test-legacy/Legacy/TestBarbies.hs b/test-legacy/Legacy/TestBarbies.hs new file mode 100644 --- /dev/null +++ b/test-legacy/Legacy/TestBarbies.hs @@ -0,0 +1,304 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# 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.Typeable +import GHC.Generics +import Test.Tasty.QuickCheck + +---------------------------------------------------- +-- Product Barbies +---------------------------------------------------- + +data Record0 (f :: * -> *) + = 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 :: * -> *) + = 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 :: * -> *) + = 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 :: * -> *) + = 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 diff --git a/test-legacy/Legacy/TestBarbiesW.hs b/test-legacy/Legacy/TestBarbiesW.hs new file mode 100644 --- /dev/null +++ b/test-legacy/Legacy/TestBarbiesW.hs @@ -0,0 +1,322 @@ +{-# OPTIONS_GHC -O0 #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# 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.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 :: * -> *) + = 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 :: * -> *) + = 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) diff --git a/test/Barbies.hs b/test/Barbies.hs deleted file mode 100644 --- a/test/Barbies.hs +++ /dev/null @@ -1,304 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -module Barbies - ( Void - - , Record0(..) - , Record1(..) - , Record3(..) - - , Record1S(..) - , Record3S(..) - - , Ignore1(..) - - , Sum3(..) - - , CompositeRecord(..) - , SumRec(..) - , InfRec(..) - - , NestedF(..) - - , HKB(..) - ) - -where - -import Data.Barbie - -import Data.Typeable -import GHC.Generics -import Test.Tasty.QuickCheck - ----------------------------------------------------- --- Product Barbies ----------------------------------------------------- - -data Record0 (f :: * -> *) - = 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 :: * -> *) - = 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 :: * -> *) - = 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 :: * -> *) - = 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 diff --git a/test/BarbiesW.hs b/test/BarbiesW.hs deleted file mode 100644 --- a/test/BarbiesW.hs +++ /dev/null @@ -1,322 +0,0 @@ -{-# OPTIONS_GHC -O0 #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -module BarbiesW - ( Record1W(..) - , Record3W(..) - - , Record1WS(..) - , Record3WS(..) - - , Sum3W(..) - - , CompositeRecordW(..) - , SumRecW(..) - , InfRecW(..) - - , NestedFW(..) - ) - -where - -import Data.Barbie -import Data.Barbie.Bare - -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 :: * -> *) - = 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 :: * -> *) - = 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) diff --git a/test/Clothes.hs b/test/Clothes.hs --- a/test/Clothes.hs +++ b/test/Clothes.hs @@ -6,6 +6,7 @@ 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 @@ -17,43 +18,112 @@ data F a = F [a] deriving(Eq, Show, Typeable) +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) +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) +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 = F <$> arbitrary + arbitrary + = scale (`div` 2) $ + F <$> arbitrary instance Arbitrary a => Arbitrary (G a) where - arbitrary = oneof - [ pure NoG - , G1 <$> arbitrary - , Gn <$> arbitrary - ] + arbitrary + = scale (`div` 2) $ + 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 - ] + arbitrary + = scale (`div` 2) $ + 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 - ] + 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)} @@ -82,8 +152,9 @@ instance (ArbitraryF f, ArbitraryF g) => Arbitrary (NatTransf f g) where arbitrary - = do fromList <- arbitraryf - pure (fromList . flattenf) + = scale (`div` 2) $ + do fromList <- arbitraryf + pure (fromList . flattenf) class ArbitraryF f where diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -4,18 +4,22 @@ import qualified Spec.Bare as Bare import qualified Spec.Constraints as Constraints import qualified Spec.Functor as Functor -import qualified Spec.Product as Product +import qualified Spec.Applicative as Applicative import qualified Spec.Traversable as Traversable import qualified Spec.Wrapper as Wrapper -import Barbies -import BarbiesW +import TestBarbies +import TestBarbiesW +import qualified TestBiBarbies as Bi -import Data.Barbie (bfoldMap, bmapC, btraverseC, buniqC) -import Data.Barbie.Bare (Covered) +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 @@ -45,8 +49,26 @@ , 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) ] , testGroup "Traversable Laws" @@ -73,45 +95,64 @@ , Traversable.laws @CompositeRecord , Traversable.laws @NestedF + , Traversable.laws @Nested2F , Traversable.laws @(CompositeRecordW Covered) - ] + , Traversable.laws @(NestedFW Covered) + , Traversable.laws @(Nested2FW Covered) - , testGroup "Product Laws" - [ Product.laws @Record0 - , Product.laws @Record1 - , Product.laws @Record3 - , Product.laws @CompositeRecord + , Traversable.laws @(ParF Maybe) - , 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) + , 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) ] - , testGroup "Uniq Laws" - [ Product.uniqLaws @Record0 - , Product.uniqLaws @Record1 - , Product.uniqLaws @Record3 - , Product.uniqLaws @CompositeRecord + , testGroup "Applicative laws" + [ Applicative.laws @Record0 + , Applicative.laws @Record1 + , Applicative.laws @Record3 + , Applicative.laws @CompositeRecord + , Applicative.laws @NestedF + , Applicative.laws @Nested2F - , Product.uniqLaws @Record1S - , Product.uniqLaws @Record3S + , Applicative.laws @Record1S + , Applicative.laws @Record3S - , Product.uniqLaws @(Record1W Covered) - , Product.uniqLaws @(Record3W Covered) - , Product.uniqLaws @(CompositeRecordW Covered) + , Applicative.laws @(Record1W Covered) + , Applicative.laws @(Record3W Covered) + , Applicative.laws @(CompositeRecordW Covered) + , Applicative.laws @(NestedFW Covered) + , Applicative.laws @(Nested2FW Covered) - , Product.uniqLaws @(Record1WS Covered) - , Product.uniqLaws @(Record3WS 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 ())) ()) ] - , testGroup "adDict projection" + , testGroup "addDict projection" [ Constraints.lawAddDictPrj @Record0 , Constraints.lawAddDictPrj @Record1 , Constraints.lawAddDictPrj @Record3 @@ -137,23 +178,6 @@ , 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 @@ -180,7 +204,7 @@ , testGroup "bfoldMap" [ testCase "Record3" $ do - let b = Record3 (Const "tic") (Const "tac") (Const "toe") + let b = Record3 (Const "tic") (Const "tac") (Const "toe") Nothing bfoldMap getConst b @?= "tictactoe" ] , testGroup @@ -196,10 +220,45 @@ @?= (Sum 1, Record1 (Identity 1)) ] , testGroup - "buniqC" + "bpureC" [ testCase "Record1" $ - buniqC @Num (Identity (fromIntegral (42 :: Int))) + bpureC @Num (Identity (fromIntegral (42 :: Int))) @?= Record1 (Identity 42) ] + , 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) + ] ] - diff --git a/test/Spec/Applicative.hs b/test/Spec/Applicative.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Applicative.hs @@ -0,0 +1,55 @@ +{-# 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 + ] diff --git a/test/Spec/Bare.hs b/test/Spec/Bare.hs --- a/test/Spec/Bare.hs +++ b/test/Spec/Bare.hs @@ -3,7 +3,7 @@ where -import Data.Barbie.Bare (BareB(..), Covered) +import Barbies.Bare (BareB(..), Covered) import Data.Functor.Identity import Data.Typeable (Typeable, typeRep, Proxy(..)) diff --git a/test/Spec/Constraints.hs b/test/Spec/Constraints.hs --- a/test/Spec/Constraints.hs +++ b/test/Spec/Constraints.hs @@ -1,14 +1,13 @@ {-# LANGUAGE AllowAmbiguousTypes #-} module Spec.Constraints ( lawAddDictPrj - , lawDictsEquivPrj ) where import Clothes(F) -import Data.Barbie(bmap, ConstraintsB(..), AllBF, ProductBC(..)) -import Data.Barbie.Constraints(ClassF, Dict) +import Barbies.Constraints(ClassF, Dict) +import Data.Functor.Barbie(bmap, ConstraintsB(..), AllBF) import Data.Functor.Product (Product(Pair)) import Data.Typeable(Typeable, Proxy(..), typeRep) @@ -31,19 +30,3 @@ 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 diff --git a/test/Spec/Functor.hs b/test/Spec/Functor.hs --- a/test/Spec/Functor.hs +++ b/test/Spec/Functor.hs @@ -5,7 +5,7 @@ import Clothes (F, H, FG(..), GH(..), NatTransf(..)) -import Data.Barbie (FunctorB(..)) +import Data.Functor.Barbie (FunctorB(..)) import Data.Typeable (Typeable, typeRep, Proxy(..)) diff --git a/test/Spec/Product.hs b/test/Spec/Product.hs deleted file mode 100644 --- a/test/Spec/Product.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -module Spec.Product ( laws, uniqLaws ) - -where - -import 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 diff --git a/test/Spec/Traversable.hs b/test/Spec/Traversable.hs --- a/test/Spec/Traversable.hs +++ b/test/Spec/Traversable.hs @@ -5,7 +5,7 @@ import Clothes (F, G, H, FG(..), GH(..), NatTransf(..)) -import Data.Barbie (TraversableB(..)) +import Data.Functor.Barbie (TraversableB(..)) import Data.Functor.Compose (Compose(..)) import Data.Functor.Identity (Identity(..)) diff --git a/test/Spec/Wrapper.hs b/test/Spec/Wrapper.hs --- a/test/Spec/Wrapper.hs +++ b/test/Spec/Wrapper.hs @@ -6,9 +6,7 @@ where -import Data.Barbie (AllBF, Barbie(..), ProductBC) - -import Data.Semigroup (Semigroup, (<>)) +import Barbies (AllBF, ApplicativeB, Barbie(..), ConstraintsB) import Test.Tasty(testGroup, TestTree) import Test.Tasty.QuickCheck(Arbitrary(..), testProperty) @@ -16,7 +14,8 @@ lawsMonoid :: forall b . ( Arbitrary (b []), Eq (b []), Show (b []) - , ProductBC b + , ApplicativeB b + , ConstraintsB b , AllBF Semigroup [] b , AllBF Monoid [] b ) diff --git a/test/TestBarbies.hs b/test/TestBarbies.hs new file mode 100644 --- /dev/null +++ b/test/TestBarbies.hs @@ -0,0 +1,346 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# 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.Typeable +import GHC.Generics +import Test.Tasty.QuickCheck + +---------------------------------------------------- +-- Product Barbies +---------------------------------------------------- + +data Record0 (f :: * -> *) + = Record0 + deriving + ( Generic, Typeable + , Eq, Show + ) + +instance FunctorB 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 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 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 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 :: * -> *) + = 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 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 <*> 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 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 :: * -> *) + = ParB (b f) + deriving (Generic, Typeable) + +instance FunctorB b => FunctorB (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 :: * -> *) + = 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) +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 diff --git a/test/TestBarbiesW.hs b/test/TestBarbiesW.hs new file mode 100644 --- /dev/null +++ b/test/TestBarbiesW.hs @@ -0,0 +1,338 @@ +{-# OPTIONS_GHC -O0 #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# 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.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 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 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 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 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 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 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 :: * -> *) + = 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 :: * -> *) + = 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 TraversableB (ParXW a Covered) +instance ApplicativeB (ParXW a Covered) +instance ConstraintsB (ParXW a Covered) diff --git a/test/TestBiBarbies.hs b/test/TestBiBarbies.hs new file mode 100644 --- /dev/null +++ b/test/TestBiBarbies.hs @@ -0,0 +1,364 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# 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(..) + ) + +where + +import Barbies +import qualified TestBarbies + +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 -> *) (x :: kr) + = Record0 + deriving + ( Generic, Typeable + , Eq, Show + ) + +instance FunctorT 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 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 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 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 :: * -> *) (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 -> *) (x :: kx) + = ParB (b f x) + deriving (Generic, Typeable) + +instance FunctorT b => FunctorT (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 -> *) (x :: kx) + = ParBH (h (b f x)) + deriving (Generic, Typeable) + +instance (Functor h, FunctorT b) => FunctorT (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 Record3' = TestBarbies.Record3 + +data NestedB f g + = NestedB + { nb_1 :: g Int + , nb_2 :: f (g Bool) + , nb_3 :: f (Record3' g) + , nb_4 :: Record3' g + } + deriving (Generic, Typeable) + +instance FunctorT NestedB +instance TraversableT NestedB +instance Functor f => FunctorB (NestedB f) +instance Applicative f => ApplicativeB (NestedB f) +instance Traversable f => TraversableB (NestedB f) + + +deriving instance (Show (f (g Bool)), AllBF Show g Record3', Show (f (Record3' g))) => Show (NestedB f g) +deriving instance (Eq (f (g Bool)), AllBF Eq g Record3', Eq (f (Record3' g))) => Eq (NestedB f g) + + +instance (Arbitrary (f (g Bool)), AllBF Arbitrary g Record3', Arbitrary (f (Record3' g))) => Arbitrary (NestedB f g) where + arbitrary + = NestedB <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary