barbies 1.1.3.0 → 2.0.0.0

raw patch · 72 files changed

+6768/−2431 lines, 72 filesdep +transformersdep −bifunctorsdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: transformers

Dependencies removed: bifunctors

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• ChangeLog.md +24/−1
• README.md +15/−5
• barbies.cabal +99/−22
• src/Barbies.hs +285/−0
• src/Barbies/Bare.hs +53/−0
• src/Barbies/Bi.hs +203/−0
• src/Barbies/Constraints.hs +21/−0
• src/Barbies/Generics/Applicative.hs +130/−0
• src/Barbies/Generics/Bare.hs +82/−0
• src/Barbies/Generics/Constraints.hs +183/−0
• src/Barbies/Generics/Functor.hs +91/−0
• src/Barbies/Generics/Traversable.hs +90/−0
• src/Barbies/Internal.hs +70/−0
• src/Barbies/Internal/ApplicativeB.hs +287/−0
• src/Barbies/Internal/ApplicativeT.hs +300/−0
• src/Barbies/Internal/BareB.hs +117/−0
• src/Barbies/Internal/ConstraintsB.hs +330/−0
• src/Barbies/Internal/ConstraintsT.hs +283/−0
• src/Barbies/Internal/Containers.hs +85/−0
• src/Barbies/Internal/Dicts.hs +56/−0
• src/Barbies/Internal/FunctorB.hs +138/−0
• src/Barbies/Internal/FunctorT.hs +196/−0
• src/Barbies/Internal/MonadT.hs +156/−0
• src/Barbies/Internal/TraversableB.hs +184/−0
• src/Barbies/Internal/TraversableT.hs +233/−0
• src/Barbies/Internal/Trivial.hs +63/−0
• src/Barbies/Internal/Wear.hs +43/−0
• src/Barbies/Internal/Wrappers.hs +40/−0
• src/Barbies/Internal/Writer.hs +43/−0
• src/Data/Barbie.hs +57/−82
• src/Data/Barbie/Bare.hs +8/−49
• src/Data/Barbie/Constraints.hs +3/−31
• src/Data/Barbie/Container.hs +0/−59
• src/Data/Barbie/Internal.hs +0/−51
• src/Data/Barbie/Internal/Bare.hs +0/−159
• src/Data/Barbie/Internal/Constraints.hs +0/−390
• src/Data/Barbie/Internal/Dicts.hs +0/−56
• src/Data/Barbie/Internal/Functor.hs +0/−153
• src/Data/Barbie/Internal/Instances.hs +0/−41
• src/Data/Barbie/Internal/Product.hs +40/−135
• src/Data/Barbie/Internal/ProductC.hs +32/−69
• src/Data/Barbie/Internal/Traversable.hs +0/−237
• src/Data/Barbie/Internal/Wear.hs +0/−41
• src/Data/Barbie/Trivial.hs +0/−67
• src/Data/Functor/Barbie.hs +72/−0
• src/Data/Functor/Prod.hs +2/−1
• src/Data/Functor/Transformer.hs +52/−0
• src/Data/Generics/GenericN.hs +30/−10
• test-legacy/Legacy/Clothes.hs +189/−0
• test-legacy/Legacy/Spec.hs +204/−0
• test-legacy/Legacy/Spec/Bare.hs +30/−0
• test-legacy/Legacy/Spec/Constraints.hs +49/−0
• test-legacy/Legacy/Spec/Functor.hs +32/−0
• test-legacy/Legacy/Spec/Product.hs +45/−0
• test-legacy/Legacy/Spec/Traversable.hs +44/−0
• test-legacy/Legacy/Spec/Wrapper.hs +37/−0
• test-legacy/Legacy/TestBarbies.hs +304/−0
• test-legacy/Legacy/TestBarbiesW.hs +322/−0
• test/Barbies.hs +0/−304
• test/BarbiesW.hs +0/−322
• test/Clothes.hs +93/−22
• test/Spec.hs +112/−53
• test/Spec/Applicative.hs +55/−0
• test/Spec/Bare.hs +1/−1
• test/Spec/Constraints.hs +2/−19
• test/Spec/Functor.hs +1/−1
• test/Spec/Product.hs +0/−45
• test/Spec/Traversable.hs +1/−1
• test/Spec/Wrapper.hs +3/−4
• test/TestBarbies.hs +346/−0
• test/TestBarbiesW.hs +338/−0
• test/TestBiBarbies.hs +364/−0

@@ -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. 

@@ -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

@@ -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

@@ -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 <https://reasonablypolymorphic.com/blog/higher-kinded-data/ HKD>).+-- 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,+     --   <https://james-iry.blogspot.com/2009/05/brief-incomplete-and-mostly-wrong.html a monad is just a monoid in the category of endofunctors>,+     --   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:+     --   <https://hackage.haskell.org/package/transformers transformers>.+     --   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

@@ -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+  )

@@ -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

@@ -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

@@ -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 -----------------------------------------------

@@ -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 #-}

@@ -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

@@ -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 --------------------------

@@ -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 -----------------------------------------------

@@ -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

@@ -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+--  <http://www.soi.city.ac.uk/~ross/papers/Applicative.html Applicative Programming with Effects>.+--+-- 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 #-}

@@ -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+--  <http://www.soi.city.ac.uk/~ross/papers/Applicative.html Applicative Programming with Effects>.+--+-- 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 #-}

@@ -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 #-}

@@ -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 #-}

@@ -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 #-}

@@ -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 ----------------------------------------------------------

@@ -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+--   <http://hackage.haskell.org/package/constraints constraints> 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

@@ -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 #-}

@@ -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 #-}

@@ -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 <https://hackage.haskell.org.package/mmorph mmorph>'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+--   <https://personal.cis.strath.ac.uk/conor.mcbride/Kleisli.pdf Kleisli arrows of outrageous fortune>.+--+--   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 #-}

@@ -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 #-}

@@ -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 #-}

@@ -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

@@ -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."+                               )

@@ -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 = (<>)

@@ -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))

@@ -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 /*

@@ -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

@@ -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

@@ -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)--

@@ -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)

@@ -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 #-}

@@ -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 #-}

@@ -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---   <http://hackage.haskell.org/package/constraints constraints> 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

@@ -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 #-}

@@ -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 = (<>)

@@ -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 #-}  

@@ -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   -- --------------------------------

@@ -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 #-}

@@ -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."-                               )

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 #-}

@@ -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 _ = "<natural-transformation :: F -> G>"++instance Show GH+  where show _ = "<natural-transformation :: G -> H>"++instance Show HI+  where show _ = "<natural-transformation :: H -> I>"

@@ -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)+          ]+        ]

@@ -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)+      ]

@@ -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

@@ -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)+      ]

@@ -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

@@ -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)+      ]

@@ -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

@@ -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

@@ -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)