barbies 0.1.4.0 → 1.0.0.0

raw patch · 33 files changed

+1585/−1320 lines, 33 filesdep +tasty-hunitPVP ok

version bump matches the API change (PVP)

Dependencies added: tasty-hunit

API changes (from Hackage documentation)

Files

• ChangeLog.md +36/−5
• barbies.cabal +40/−10
• src/Data/Barbie.hs +40/−42
• src/Data/Barbie/Bare.hs +55/−0
• src/Data/Barbie/Constraints.hs +15/−7
• src/Data/Barbie/Container.hs +1/−3
• src/Data/Barbie/Internal.hs +51/−0
• src/Data/Barbie/Internal/Bare.hs +76/−130
• src/Data/Barbie/Internal/Classification.hs +0/−46
• src/Data/Barbie/Internal/Constraints.hs +236/−156
• src/Data/Barbie/Internal/Dicts.hs +38/−21
• src/Data/Barbie/Internal/Functor.hs +54/−65
• src/Data/Barbie/Internal/Generics.hs +0/−113
• src/Data/Barbie/Internal/Instances.hs +9/−15
• src/Data/Barbie/Internal/Product.hs +89/−86
• src/Data/Barbie/Internal/ProductC.hs +154/−0
• src/Data/Barbie/Internal/ProofB.hs +0/−157
• src/Data/Barbie/Internal/Tags.hs +0/−32
• src/Data/Barbie/Internal/Traversable.hs +115/−70
• src/Data/Barbie/Internal/Wear.hs +17/−18
• src/Data/Barbie/Trivial.hs +2/−10
• src/Data/Functor/Prod.hs +0/−6
• src/Data/Generics/GenericN.hs +88/−0
• test/Barbies.hs +56/−238
• test/BarbiesW.hs +322/−0
• test/Clothes.hs +0/−3
• test/Spec.hs +69/−59
• test/Spec/Bare.hs +4/−5
• test/Spec/Constraints.hs +14/−15
• test/Spec/Functor.hs +0/−1
• test/Spec/Product.hs +0/−1
• test/Spec/Traversable.hs +0/−1
• test/Spec/Wrapper.hs +4/−5

@@ -1,11 +1,43 @@ # Changelog for barbies +## 1.0.0.0+  - Replaced `ConstraintsOf` in `ConstraintsB` by `AllB`, which allows+    constraints to be given on `a` instead of on `f a`. The `ClassF`+    class lets us specify constraints on `f a` by doing `AllB (ClassF c f) b`.+    `ConstraintsOf` becomes then a type alias. Credit goes to Csongor Kiss.++  - `ConstraintsOf` was ultimately deprecated in favour of `AllBF`, which+    is shorter and more consistent with `AllB`.++  - Renamed `ConstraintsB(adjProof)` to `ConstraintsB(baddDicts)`.++  - Renamed `ProofB(bproof)` to `ProductBC(bdicts)`.++  - Changed the way `Wear` works: now wear-types need to have an extra+    type parameter that controls whether they are `Bare` or `Covered`. This+    let us remove all the "magic" that was involved, in the sense that+    one couldn't have instances of `FunctorB`, etc, for wear-types wihtout+    using `unsafeCoerce` (this was true also for handwritten instances).++  - Added `bsequence'`, a frequent specialisation of `bsequence`.++  - Added `bfoldMap`.++  - Added `buniqC` and `bmempty`.++  - Improved the internal instance derivation mechanism. We no longer+    need `unsafeCoerce` and the code should be in general indistinguishible+    from hand-written instances (not currently verified).++  - Fixed support for barbie-types that have additional type parameters (#5).+ ## 0.1.4.0-  - Add btraverse_-  - Add the trivial Void and Unit barbies+  - Added `btraverse_` +  - Added the trivial `Void` and `Unit` barbies+ ## 0.1.3.1-  - Fix issue on Barbie-types with strictness annotations.+  - Fixed issue on Barbie-types with strictness annotations.  ## 0.1.3.0   - Use both `Monoid` and `Semigroup` as constraints for the `Monoid` instance,@@ -15,11 +47,10 @@   - Use `Monoid` and not `Semigroup` as constraints for the `Monoid` instance  ## 0.1.1.0-  - Add `instance Semigroup (Barbie b)` to go along the `Monoid` instance+  - Added `instance Semigroup (Barbie b)` to go along the `Monoid` instance  ## 0.1.0.1   - Works under GHC 8.0.2, but notice one needs to use empty instance     declarations, because ghc chokes on `deriving` clauses.-  ## 0.1.0.0 - Initial release

@@ -1,5 +1,5 @@ name:           barbies-version:        0.1.4.0+version:        1.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@@ -25,26 +25,27 @@    exposed-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.ProofB+      Data.Barbie.Internal.ProductC       Data.Barbie.Internal.Traversable--  other-modules:-      Data.Barbie.Internal.Classification-      Data.Barbie.Internal.Dicts-      Data.Barbie.Internal.Generics-      Data.Barbie.Internal.Instances-      Data.Barbie.Internal.Tags       Data.Barbie.Internal.Wear       Data.Barbie.Trivial +      Data.Generics.GenericN+   hs-source-dirs:       src @@ -55,7 +56,24 @@   ghc-options: -Wall -Wnoncanonical-monoid-instances    default-language: Haskell2010-+  default-extensions:+      ConstraintKinds+    , DataKinds+    , DefaultSignatures+    , DeriveGeneric+    , DeriveDataTypeable+    , EmptyCase+    , ExplicitForAll+    , FlexibleContexts+    , FlexibleInstances+    , KindSignatures+    , LambdaCase+    , MultiParamTypeClasses+    , Rank2Types+    , ScopedTypeVariables+    , StandaloneDeriving+    , TypeApplications+    , TypeOperators  test-suite barbies-test   type: exitcode-stdio-1.0@@ -64,6 +82,7 @@    other-modules:       Barbies+      BarbiesW       Clothes       Spec.Bare       Spec.Constraints@@ -82,6 +101,17 @@     , base >=4.7 && <5     , QuickCheck     , tasty+    , tasty-hunit     , tasty-quickcheck    default-language: Haskell2010+  default-extensions:+    DeriveDataTypeable+    DeriveGeneric+    KindSignatures+    LambdaCase+    Rank2Types+    ScopedTypeVariables+    StandaloneDeriving+    TypeApplications+    TypeOperators

@@ -30,38 +30,17 @@ --       } --   deriving --     ( 'GHC.Generics.Generic'---     , 'FunctorB', 'TraversableB', 'ProductB', 'ConstraintsB', 'ProofB'+--     , 'FunctorB', 'TraversableB', 'ProductB', 'ConstraintsB', 'ProductBC' --     ) ----- deriving instance 'ConstraintsOf' 'Show' f Barbie => 'Show' (Barbie f)--- deriving instance 'ConstraintsOf' 'Eq'   f Barbie => 'Eq'   (Barbie f)+-- 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 feels lik a second-class record type, where one needs to--- unpack values in each field. For those cases, we can leverage on--- closed type-families ang get the best of both worlds:------ @--- data 'Bare'------ type family 'Wear' f a where---   'Wear' 'Bare' a = a---   'Wear' f      a = f a------ data SignUpForm f---   = SignUpForm'---       { username  :: 'Wear' f 'String',---       , password  :: 'Wear' f 'String'---       , mailingOk :: 'Wear' f 'Boolean'---       }---   deriving ( ..., 'BareB')------ type SignUpRaw  = SignUpForm 'Maybe'--- type SignUpData = SignUpForm 'Bare'------ formData = SignUpForm "jbond" "shaken007" False :: SignUpData--- @+-- 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.   ----------------------------------------------------------------------------@@ -72,24 +51,27 @@      -- * Traversable   , TraversableB(btraverse)+    -- ** Utility functions   , btraverse_-  , bsequence+  , bfoldMap+  , bsequence, bsequence'      -- * Product   , ProductB(buniq, bprod)-  , (/*/), (/*)+    -- ** Utility functions   , bzip, bunzip, bzipWith, bzipWith3, bzipWith4+    -- ** Applicative-like interface+  , (/*/), (/*) -    -- * Bare values-  , Wear-  , Bare-  , BareB(bstrip, bcover)-  , bstripFrom-  , bcoverWith+    -- * Constraints and instance dictionaries+  , ConstraintsB(AllB, baddDicts)+  , AllBF -    -- * Constraints and proofs of instance-  , ConstraintsB(ConstraintsOf, adjProof)-  , ProofB(bproof)+    -- * Products and constaints+  , ProductBC(bdicts)+    -- ** Utility functions+  , buniqC+  , bmempty      -- * Wrapper   , Barbie(..)@@ -97,19 +79,35 @@     -- * Trivial Barbies   , Void   , Unit (..)++    -- * Generic derivations+  , Rec(..)++    -- * Deprecations+  , Deprecated.ConstraintsOf+  , Deprecated.adjProof+  , Deprecated.ProofB+  , Deprecated.bproof   )  where -import Data.Barbie.Internal.Bare(Bare, BareB(..), bstripFrom, bcoverWith, Wear)-import Data.Barbie.Internal.Constraints(ConstraintsB(..))+import Data.Barbie.Internal.Constraints(ConstraintsB(..), AllBF)+import qualified Data.Barbie.Internal.Constraints as Deprecated+ import Data.Barbie.Internal.Functor(FunctorB(..)) import Data.Barbie.Internal.Instances(Barbie(..))-import Data.Barbie.Internal.ProofB(ProofB(..)) import Data.Barbie.Internal.Product   ( ProductB(..)   , bzip, bunzip, bzipWith, bzipWith3, bzipWith4   , (/*/), (/*)   )-import Data.Barbie.Internal.Traversable(TraversableB(..), bsequence, btraverse_)+import Data.Barbie.Internal.ProductC(ProductBC(..), buniqC, bmempty)+import qualified Data.Barbie.Internal.ProductC as Deprecated+import Data.Barbie.Internal.Traversable+  ( TraversableB(..)+  , bsequence, bsequence'+  , bfoldMap, btraverse_+  ) import Data.Barbie.Trivial(Void, Unit(..))+import Data.Generics.GenericN (Rec(..))

@@ -0,0 +1,55 @@+-----------------------------------------------------------------------------+-- |+-- 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+  ( -- * Bare values+    Wear+  , Bare+  , Covered++    -- * Covering and stripping+  , BareB(bstrip, bcover)+  , bstripFrom+  , bcoverWith++  ) where++import Data.Barbie.Internal.Bare+  ( Wear, Bare, Covered+  , BareB(..)+  , bstripFrom, bcoverWith+  )

@@ -23,18 +23,26 @@ -- This module adds support to overcome this problem. ---------------------------------------------------------------------------- module Data.Barbie.Constraints-  ( -- * Proof of instance-    DictOf(..)-  , packDict+  ( -- * Instance dictionaries+    Dict(..)   , requiringDict -    -- * Retrieving proofs-  , ConstraintsB(ConstraintsOf)-  , ProofB(..)+    -- * Retrieving dictionaries+  , ConstraintsB(..)+  , ProductBC(..)++  , AllBF+  , ClassF+  , ClassFG++    -- * Deprecated+  , ConstraintsOf+  , adjProof+  , ProofB   )  where  import Data.Barbie.Internal.Constraints import Data.Barbie.Internal.Dicts-import Data.Barbie.Internal.ProofB+import Data.Barbie.Internal.ProductC

@@ -6,8 +6,6 @@ -- @('Const' a)@ . The 'Container' wrapper gives us the expected -- instances for a container type. -----------------------------------------------------------------------------{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} module Data.Barbie.Container   (@@ -54,7 +52,7 @@     l <*> r       = Container $ bmap (uncurryn appConst) (getContainer l /*/ getContainer r)       where-        appConst :: Const (a -> b) x -> Const a x -> Const b x+        appConst :: Const (a -> a') x -> Const a x -> Const a' x         appConst (Const f) (Const a)           = Const (f a) 

@@ -0,0 +1,51 @@+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,35 +1,24 @@-{-# LANGUAGE ConstraintKinds    #-}-{-# LANGUAGE DefaultSignatures  #-}-{-# LANGUAGE FlexibleContexts   #-}-{-# LANGUAGE FlexibleInstances  #-}-{-# LANGUAGE LambdaCase         #-}-{-# LANGUAGE Rank2Types         #-} {-# LANGUAGE TypeFamilies       #-}-{-# LANGUAGE TypeApplications   #-}-{-# LANGUAGE TypeOperators      #-} module Data.Barbie.Internal.Bare-  ( Wear, Bare+  ( Wear, Bare, Covered   , BareB(..)   , bstripFrom, bcoverWith -  , Gbstrip(..)+  , GBareB(..)   , gbstripDefault   , gbcoverDefault -  , CanDeriveGenericInstance-  , CanDeriveGenericInstance'+  , CanDeriveBareB   )  where  import Data.Barbie.Internal.Functor (FunctorB(..))-import Data.Barbie.Internal.Generics-import Data.Barbie.Internal.Tags (I, B)-import Data.Barbie.Internal.Wear+import Data.Barbie.Internal.Wear(Bare, Covered, Wear) import Data.Functor.Identity (Identity(..)) -import GHC.Generics-import Unsafe.Coerce (unsafeCoerce)+import Data.Coerce (coerce)+import Data.Generics.GenericN   -- | Class of Barbie-types defined using 'Wear' and can therefore@@ -39,175 +28,132 @@ -- 'bcover' . 'bstrip' = 'id' -- 'bstrip' . 'bcover' = 'id' -- @-class FunctorB b => BareB b where-    bstrip :: b Identity -> b Bare-    bcover :: b Bare -> b Identity+class FunctorB (b Covered) => BareB b where+    bstrip :: b Covered Identity -> b Bare Identity+    bcover :: b Bare Identity -> b Covered Identity -    default bstrip :: CanDeriveGenericInstance b => b Identity -> b Bare+    default bstrip :: CanDeriveBareB b => b Covered Identity -> b Bare Identity     bstrip = gbstripDefault -    default bcover :: CanDeriveGenericInstance' b => b Bare -> b Identity+    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 f -> b Bare+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 -> b f+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 CanDeriveGenericInstance b-  = ( Generic (b (Target I))-    , Generic (b (Target B))-    , Gbstrip (Rep (b (Target I)))-    , Rep (b (Target B)) ~ Repl (Target I) (Target B) (Rep (b (Target I)))-    )--type CanDeriveGenericInstance' b-  = ( Generic (b (Target I))-    , Generic (b (Target B))-    , Gbcover (Rep (b (Target B)))-    , Rep (b (Target I)) ~ Repl (Target B) (Target I) (Rep (b (Target B)))+type CanDeriveBareB b+  = ( GenericN (b Bare Identity)+    , GenericN (b Covered Identity)+    , GBareB (RepN (b Covered Identity)) (RepN (b Bare Identity))     ) ---- | Default implementatio of 'bstrip' based on 'Generic'.-gbstripDefault :: CanDeriveGenericInstance b => b Identity -> b Bare-gbstripDefault b-  = unsafeUntargetBarbie @B $ to $ gbstrip $ from (unsafeTargetBarbie @I b)---- | Default implementatio of 'bstrip' based on 'Generic'.-gbcoverDefault :: CanDeriveGenericInstance' b => b Bare -> b Identity-gbcoverDefault b-  = unsafeUntargetBarbie @I $ to $ gbcover $ from (unsafeTargetBarbie @B b)---unsafeTargetBare :: a -> Target (W B) a-unsafeTargetBare = unsafeCoerce+-- | Default implementation of 'bstrip' based on 'Generic'.+gbstripDefault :: CanDeriveBareB b => b Covered Identity -> b Bare Identity+gbstripDefault+  = toN . gbstrip . fromN+{-# INLINE gbstripDefault #-} -unsafeUntargetBare :: Target (W B) a -> a-unsafeUntargetBare = unsafeCoerce+-- | Default implementation of 'bstrip' based on 'Generic'.+gbcoverDefault :: CanDeriveBareB b => b Bare Identity -> b Covered Identity+gbcoverDefault+  = toN . gbcover . fromN+{-# INLINE gbcoverDefault #-}  -class Gbstrip rep where-  gbstrip :: rep x -> Repl (Target I) (Target B) rep x--class Gbcover rep where-  gbcover :: rep x -> Repl (Target B) (Target I) rep x+class GBareB repbi repbb where+  gbstrip :: repbi x -> repbb x+  gbcover :: repbb x -> repbi x  -- ---------------------------------- -- Trivial cases -- ---------------------------------- -instance Gbstrip x => Gbstrip (M1 i c x) where+instance GBareB repbi repbb => GBareB (M1 i k repbi) (M1 i k repbb) where+  gbstrip = M1 . gbstrip . unM1   {-# INLINE gbstrip #-}-  gbstrip (M1 x) = M1 (gbstrip x) -instance Gbstrip V1 where-  gbstrip _ = undefined+  gbcover = M1 . gbcover . unM1+  {-# INLINE gbcover #-} -instance Gbstrip U1 where-  {-# INLINE gbstrip #-}-  gbstrip u1 = u1 -instance (Gbstrip l, Gbstrip r) => Gbstrip (l :*: r) where-  {-# INLINE gbstrip #-}-  gbstrip (l :*: r)-    = (gbstrip l) :*: gbstrip r+instance GBareB V1 V1 where+  gbstrip _ = undefined+  gbcover _ = undefined -instance (Gbstrip l, Gbstrip r) => Gbstrip (l :+: r) where+instance GBareB U1 U1 where+  gbstrip = id   {-# INLINE gbstrip #-}-  gbstrip = \case-    L1 l -> L1 (gbstrip l)-    R1 r -> R1 (gbstrip r) --instance Gbcover x => Gbcover (M1 i c x) where+  gbcover = id   {-# INLINE gbcover #-}-  gbcover (M1 x) = M1 (gbcover x) -instance Gbcover V1 where-  gbcover _ = undefined -instance Gbcover U1 where-  {-# INLINE gbcover #-}-  gbcover u1 = u1+instance (GBareB l l', GBareB r r') => GBareB (l :*: r) (l' :*: r') where+  gbstrip (l :*: r) = (gbstrip l) :*: gbstrip r+  {-# INLINE gbstrip #-} -instance (Gbcover l, Gbcover r) => Gbcover (l :*: r) where+  gbcover (l :*: r) = (gbcover l) :*: gbcover r   {-# INLINE gbcover #-}-  gbcover (l :*: r)-    = (gbcover l) :*: gbcover r -instance (Gbcover l, Gbcover r) => Gbcover (l :+: r) where-  {-# 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 (gbstrip)--- --------------------------------+-- -- --------------------------------+-- -- The interesting cases+-- -- -------------------------------- +type P = Param 0 -instance {-# OVERLAPPING #-} Gbstrip (K1 R (Target (W I) a)) where+instance GBareB (Rec (P Identity a) (Identity a)) (Rec a a) where+  gbstrip = coerce   {-# INLINE gbstrip #-}-  gbstrip (K1 ia)-    = K1 $ unsafeTargetBare $ runIdentity $ unsafeUntarget @(W I) ia -instance {-# OVERLAPPING #-} BareB b => Gbstrip (K1 R (b (Target I))) where-  {-# INLINE gbstrip #-}-  gbstrip (K1 bf)-    = K1 $ unsafeTargetBarbie @B $ bstrip $ unsafeUntargetBarbie @I bf--instance {-# OVERLAPPING #-}-  ( Functor h-  , BareB b-  , Repl (Target I) (Target B) (K1 R (h (b (Target I))))  -- shouldn't be-      ~ (K1 R (h (b (Target B))))  -- necessary but ghc chokes otherwise-  )-   => Gbstrip (K1 R (h (b (Target I)))) where-  {-# INLINE gbstrip #-}-  gbstrip (K1 hbf)-    = K1 (fmap (unsafeTargetBarbie @B . bstrip . unsafeUntargetBarbie @I) hbf)+  gbcover = coerce+  {-# INLINE gbcover #-}  -instance (K1 i c) ~ Repl (Target I) (Target B) (K1 i c) => Gbstrip (K1 i c) where+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 #-}-  gbstrip k1 = k1 +  gbcover = Rec . K1 .  bcover . unK1 . unRec+  {-# INLINE gbcover #-} --- ----------------------------------- The interesting cases (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 #-} -instance {-# OVERLAPPING #-} Gbcover (K1 R (Target (W B) a)) where+  gbcover = Rec . K1 . fmap bcover . unK1 . unRec   {-# INLINE gbcover #-}-  gbcover (K1 a)-    = K1 $ unsafeTarget @(W I) $ Identity $ unsafeUntargetBare a -instance {-# OVERLAPPING #-} BareB b => Gbcover (K1 R (b (Target B))) where-  {-# INLINE gbcover #-}-  gbcover (K1 bf)-    = K1 $ unsafeTargetBarbie @I $ bcover $ unsafeUntargetBarbie @B bf -instance {-# OVERLAPPING #-}-  ( Functor h-  , BareB b-  , Repl (Target B) (Target I) (K1 R (h (b (Target B))))  -- shouldn't be-      ~ (K1 R (h (b (Target I))))  -- necessary but ghc chokes otherwise-  )-   => Gbcover (K1 R (h (b (Target B)))) where-  {-# INLINE gbcover #-}-  gbcover (K1 hbb)-    = K1 (fmap (unsafeTargetBarbie @I . bcover . unsafeUntargetBarbie @B) hbb)+instance repbi ~ repbb => GBareB (Rec repbi repbi) (Rec repbb repbb) where+  gbstrip = id+  {-# INLINE gbstrip #-} -instance (K1 i c) ~ Repl (Target B) (Target I) (K1 i c) => Gbcover (K1 i c) where+  gbcover = id   {-# INLINE gbcover #-}-  gbcover k1 = k1

@@ -1,46 +0,0 @@-{-# LANGUAGE DataKinds            #-}-{-# LANGUAGE TypeFamilies         #-}-{-# LANGUAGE TypeOperators        #-}-{-# LANGUAGE UndecidableInstances #-}-module Data.Barbie.Internal.Classification-  ( BarbieType(..)-  , GClassifyBarbie-  , ClassifyBarbie-  )--where--import Data.Barbie.Internal.Generics(Target, RecUsage(..), NonRec(..), RecRep, W)-import Data.Barbie.Internal.Tags(F)--import GHC.Generics--data BarbieType-  = NoBarbie      -- ^ The parameter is never used.-  | WearBarbie    -- ^ The parameter is used, and always under a 'Wear'.-  | NonWearBarbie -- ^ The parameter is used, never under a 'Wear'.-  | MixedBarbie   -- ^ THe parameter is used, sometimes under a 'Wear', somtimes not.--type family MergeBarbieType l r where-  MergeBarbieType 'NoBarbie r = r-  MergeBarbieType l 'NoBarbie = l--  MergeBarbieType 'MixedBarbie _ = 'MixedBarbie-  MergeBarbieType _ 'MixedBarbie = 'MixedBarbie--  MergeBarbieType x x = x-  MergeBarbieType _l _r = 'MixedBarbie--type family GClassifyBarbie rep where-  GClassifyBarbie (M1 _i _c x) = GClassifyBarbie x-  GClassifyBarbie V1 = 'NoBarbie-  GClassifyBarbie U1 = 'NoBarbie-  GClassifyBarbie (l :*: r) = MergeBarbieType (GClassifyBarbie l) (GClassifyBarbie r)-  GClassifyBarbie (l :+: r) = MergeBarbieType (GClassifyBarbie l) (GClassifyBarbie r)-  GClassifyBarbie (K1 R (NonRec (Target (W F) a))) = 'WearBarbie-  GClassifyBarbie (K1 R (NonRec (Target F a))) = 'NonWearBarbie-  GClassifyBarbie (K1 R (NonRec (b (Target F)))) = GClassifyBarbie (Rep (b (Target F)))-  GClassifyBarbie (K1 R (RecUsage (b (Target F)))) = 'NoBarbie -- break recursion-  GClassifyBarbie (K1 _i _c) = 'NoBarbie--type ClassifyBarbie b = GClassifyBarbie (RecRep (b (Target F)))

@@ -1,47 +1,36 @@-{-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE DefaultSignatures     #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE LambdaCase            #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE AllowAmbiguousTypes   #-} {-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-} {-# LANGUAGE UndecidableInstances  #-} module Data.Barbie.Internal.Constraints   ( ConstraintsB(..)+  , AllBF -  , CanDeriveGenericInstance-  , ConstraintsOfMatchesGenericDeriv-  , GConstraintsOf-  , GAdjProof-  , gadjProofDefault+  , CanDeriveConstraintsB+  , GAllBC(..)+  , GAllBRep, X+  , TagSelf, Self, Other+  , GConstraintsB(..)+  , gbaddDictsDefault -  , ConstraintByType+    -- DEPRECATED STUFF+  , adjProof+  , ConstraintsOf   )  where -import Data.Barbie.Internal.Classification (BarbieType(..), ClassifyBarbie, GClassifyBarbie)-import Data.Barbie.Internal.Dicts(DictOf(..), packDict)+import Data.Barbie.Internal.Dicts(ClassF, Dict(..)) import Data.Barbie.Internal.Functor(FunctorB(..))-import Data.Barbie.Internal.Generics-import Data.Barbie.Internal.Tags(F, PxF)-import Data.Barbie.Internal.Wear(Wear)  import Data.Functor.Product(Product(..)) import Data.Kind(Constraint) -import Data.Proxy--import GHC.Generics+import Data.Generics.GenericN   -- | Instances of this class provide means to talk about constraints,---   both at compile-time, using 'ConstraintsOf' and at run-time,---   in the form of class instance dictionaries, via 'adjProof'.+--   both at compile-time, using 'AllB', and at run-time, in the form+--   of 'Dict', via 'baddDicts'. -- --   A manual definition would look like this: --@@ -49,62 +38,87 @@ -- data T f = A (f 'Int') (f 'String') | B (f 'Bool') (f 'Int') -- -- instance 'ConstraintsB' T where---   type 'ConstraintsOf' c f T---     = (c (f 'Int'), c (f 'String'), c (f 'Bool'))+--   type 'AllB' c T = (c 'Int', c 'String', c 'Bool') -----   adjProof t = case t of---     A x y -> A ('Pair' ('packDict' x) ('packDict' y))---     B z w -> B ('Pair' ('packDict' z) ('packDict' w))+--   '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) -- @ ----- There is a default implementation of 'ConstraintsOf' for+-- 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+-- derive instance 'Generic' (T f) -- instance 'ConstraintsB' T -- @ class FunctorB b => ConstraintsB b where-  -- | @'ConstraintsOf' c f b@ should contain a constraint @c (f x)@-  --  for each @f x@ occurring in @b@. E.g.:+  -- | @'AllB' c b@ should contain a constraint @c a@ for each+  --   @a@ occurring under an @f@ in @b f@. E.g.:   --   -- @-  -- 'ConstraintsOf' 'Show' f Barbie = ('Show' (f 'String'), 'Show' (f 'Int'))+  -- 'AllB' 'Show' Barbie ~ ('Show' 'String', 'Show' 'Int')   -- @-  type ConstraintsOf (c :: * -> Constraint) (f :: * -> *) b :: Constraint-  type ConstraintsOf c f b = GConstraintsOf c f (RecRep (b (Target F)))+  --+  -- For requiring constraints of the form @c (f a)@, use 'AllBF'.+  type AllB (c :: * -> Constraint) b :: Constraint+  type AllB c b = GAllB c (GAllBRep b) -  -- | Adjoint a proof-of-instance to a barbie-type.-  adjProof-    :: forall c f-    .  ConstraintsOf c f b-    => b f -> b (Product (DictOf c f) f)+  baddDicts :: forall c f.  AllB c b => b f -> b (Dict c `Product` f) -  default adjProof+  default baddDicts     :: forall c f-    .  ( CanDeriveGenericInstance b-       , ConstraintsOfMatchesGenericDeriv c f b-       , ConstraintsOf c f b+    .  ( CanDeriveConstraintsB c b f+       , AllB c b        )-    => b f -> b (Product (DictOf c f) f)-  adjProof = gadjProofDefault+    => b f -> b (Dict c `Product` f)+  baddDicts = gbaddDictsDefault --- | Intuivively, the requirements to have @'ConstraintsB' B@ derived are:------     * There is an instance of @'Generic' (B f)@ for every @f@+-- | Similar to 'AllB' but will put the functor argument @f@+--   between the constraint @c@ and the type @a@. For example: -----     * If @f@ is used as argument to some type in the definition of @B@, it---       is only on a Barbie-type with a 'ConstraintsB' instance.-type CanDeriveGenericInstance b-  = ( Generic (b (Target F))-    , Generic (b (Target PxF))-    , GAdjProof (ClassifyBarbie b) b (RecRep (b (Target F)))-    , Rep (b (Target PxF)) ~ Repl' (Target F) (Target PxF) (RecRep (b (Target F)))-    )+--   @+--   '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 -type ConstraintsOfMatchesGenericDeriv c f b-  = ( ConstraintsOf c f b ~ GConstraintsOf c f (RecRep (b (Target F)))-    , ConstraintsOf c f b ~ ConstraintByType (ClassifyBarbie b) c f (RecRep (b (Target F)))++{-# 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)))     )  @@ -112,123 +126,189 @@ --  Generic derivations -- =============================================================== -type family ConstraintByType bt (c :: * -> Constraint) (f :: * -> *) r :: Constraint where-  ConstraintByType bt c f (M1 _i _c x) = ConstraintByType bt c f x-  ConstraintByType bt c f V1 = ()-  ConstraintByType bt c f U1 = ()-  ConstraintByType bt c f (l :*: r) = (ConstraintByType bt c f l, ConstraintByType bt c f r)-  ConstraintByType bt c f (l :+: r) = (ConstraintByType bt c f l, ConstraintByType bt c f r)-  ConstraintByType 'WearBarbie c f (K1 R (NonRec (Target (W F) a))) = (c (Wear f a), Wear f a ~ f a)-  ConstraintByType 'NonWearBarbie c f (K1 R (NonRec (Target F a))) = c (f a)-  ConstraintByType bt c f (K1 R (NonRec (b (Target F)))) = ConstraintsOf c f b-  ConstraintByType bt c f (K1 R (RecUsage (b (Target F)))) = () -- break recursion-  ConstraintByType bt c f (K1 _i _c) = ()--type GConstraintsOf c f r-  = ConstraintByType (GClassifyBarbie r) c f r----- | Default implementation of 'adjProof' based on 'Generic'.-gadjProofDefault+-- | Default implementation of 'baddDicts' based on 'Generic'.+gbaddDictsDefault   :: forall b c f-  . ( CanDeriveGenericInstance b-    , ConstraintsOfMatchesGenericDeriv c f b-    , ConstraintsOf c f b+  . ( CanDeriveConstraintsB c b f+    , AllB c b     )-  => b f -> b (Product (DictOf c f) f)-gadjProofDefault b-  = unsafeUntargetBarbie @PxF $ to $-      gadjProof pcbf pbt $ fromWithRecAnn (unsafeTargetBarbie @F b)-  where-    pcbf = Proxy :: Proxy (c (b f))-    pbt  = Proxy :: Proxy (ClassifyBarbie b)-+  => b f -> b (Dict c `Product` f)+gbaddDictsDefault+  = toN . gbaddDicts @c @f @(GAllBRep b) . fromN+{-# INLINE gbaddDictsDefault #-} -class GAdjProof (bt :: BarbieType) b rep where+class GAllBC (repbf :: * -> *) where+  type GAllB (c :: * -> Constraint) repbf :: Constraint -  gadjProof-    :: ( ConstraintByType bt c f rep-       , GConstraintsOf c f (RecRep (b (Target F))) -- for the recursive case!-       )-    => Proxy (c (b f))-    -> Proxy bt-    -> rep x-    -> Repl' (Target F) (Target PxF) rep x+class GAllBC repbx => GConstraintsB c (f :: * -> *) repbx repbf repbdf where+  gbaddDicts :: GAllB c repbx => repbf x -> repbdf x   -- ---------------------------------- -- Trivial cases -- ---------------------------------- -instance GAdjProof bt b x => GAdjProof bt b (M1 _i _c x) where-  {-# INLINE gadjProof #-}-  gadjProof pcbf pbt (M1 x)-    = M1 (gadjProof pcbf pbt x)+instance GAllBC repbf => GAllBC (M1 i k repbf) where+  type GAllB c (M1 i k repbf) = GAllB c repbf -instance GAdjProof bt b V1 where-  gadjProof _ _ _ = undefined+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 GAdjProof bt b U1 where-  {-# INLINE gadjProof #-}-  gadjProof _ _ u1 = u1 -instance (GAdjProof bt b l, GAdjProof bt b r) => GAdjProof bt b (l :*: r) where-  {-# INLINE gadjProof #-}-  gadjProof pcbf pbt (l :*: r)-    = (gadjProof pcbf pbt l) :*: (gadjProof pcbf pbt r) -instance (GAdjProof bt b l, GAdjProof bt b r) => GAdjProof bt b (l :+: r) where-  {-# INLINE gadjProof #-}-  gadjProof pcbf pbt = \case-    L1 l -> L1 (gadjProof pcbf pbt l)-    R1 r -> R1 (gadjProof pcbf pbt r)+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 -- -------------------------------- -instance {-# OVERLAPPING #-} GAdjProof 'WearBarbie b (K1 R (NonRec (Target (W F) a))) where-  {-# INLINE gadjProof #-}-  gadjProof pcbf _ (K1 (NonRec fa))-    = K1 $ unsafeTarget @(W PxF) (Pair (mkProof pcbf) $ unsafeUntarget @(W F) fa)-    where-      mkProof :: (c (f a), Wear f a ~ f a) => Proxy (c (b f)) -> DictOf c f a-      mkProof _ = packDict+type P0 = Param 0  -instance {-# OVERLAPPING #-} GAdjProof 'NonWearBarbie b (K1 R (NonRec (Target F a))) where-  {-# INLINE gadjProof #-}-  gadjProof pcbf _ (K1 (NonRec fa))-    = K1 $ unsafeTarget @PxF (Pair (mkProof pcbf) $ unsafeUntarget @F fa)-    where-      mkProof :: c (f a) => Proxy (c (b f)) -> DictOf c f a-      mkProof _ = packDict+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 {-# OVERLAPPING #-}-  ( CanDeriveGenericInstance b-  , bt ~ ClassifyBarbie b-  )-    => GAdjProof bt b (K1 R (RecUsage (b (Target F)))) where-  {-# INLINE gadjProof #-}-  gadjProof pcbf pbt (K1 (RecUsage bf))-    = K1 $ to $ gadjProof pcbf pbt $ fromWithRecAnn bf -instance {-# OVERLAPPING #-}-  ConstraintsB b'-    => GAdjProof bt b (K1 R (NonRec (b' (Target F)))) where-  {-# INLINE gadjProof #-}-  gadjProof pcbf _ (K1 (NonRec bf))-    = K1 $ unsafeTargetBarbie @PxF $ adjProof' pcbf $ unsafeUntargetBarbie @F bf-    where-      adjProof'-        :: ConstraintsOf c f b'-        => Proxy (c (b f)) -> b' f -> b' (Product (DictOf c f) f)-      adjProof' _ = adjProof +instance GAllBC (Rec (Self b (P0 X)) (b X)) where+   type GAllB c (Rec (Self b (P0 X)) (b X)) = ()+ instance-  (K1 i a) ~ Repl' (Target F) (Target PxF) (K1 i (NonRec a))-    => GAdjProof bt b (K1 i (NonRec a)) where-  {-# INLINE gadjProof #-}-  gadjProof _ _ (K1 (NonRec a)) = K1 a+  ( 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 :: (* -> *) -> *) (f :: * -> *)+data Other (b :: (* -> *) -> *) (f :: * -> *)++-- | 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 :: (* -> *) -> *) (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 (Rec (b' f) (b'' (g :: * -> *)))+    = Rec (Other b' f) (b'' g)++  TagSelf b (Rec p a)+    = Rec p a++  TagSelf b U1+    = U1++  TagSelf b V1+    = V1

@@ -1,38 +1,55 @@-{-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE GADTs                 #-}-{-# LANGUAGE KindSignatures        #-}-{-# LANGUAGE Rank2Types            #-}-{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE GADTs                   #-}+{-# LANGUAGE TypeFamilies            #-}+{-# LANGUAGE UndecidableInstances    #-}+{-# LANGUAGE UndecidableSuperClasses #-} module Data.Barbie.Internal.Dicts-  ( DictOf(..)-  , packDict+  ( Dict(..)   , requiringDict++  , ClassF+  , ClassFG   )  where  import Data.Functor.Classes(Show1(..)) --- | @'DictOf' c f a@ is evidence that there exists an instance---   of @c (f a)@.-data DictOf c f a where-  PackedDict :: c (f a) => DictOf c f a +-- | @'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 (DictOf c f a) where+instance Eq (Dict c a) where   _ == _ = True -instance Show (DictOf c f a) where-  showsPrec _ PackedDict = showString "PackedDict"+instance Show (Dict c a) where+  showsPrec _ Dict = showString "Dict" -instance Show1 (DictOf c f) where+instance Show1 (Dict c)  where   liftShowsPrec _ _ = showsPrec --- | Pack the dictionary associated with an instance.-packDict :: c (f a) => DictOf c f a-packDict = PackedDict- -- | Turn a constrained-function into an unconstrained one --   that uses the packed instance dictionary instead.-requiringDict :: (c (f a) => r) -> (DictOf c f a -> r)-requiringDict r = \PackedDict -> r+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 :: * -> '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,26 +1,15 @@-{-# LANGUAGE ConstraintKinds     #-}-{-# LANGUAGE DefaultSignatures   #-}-{-# LANGUAGE DeriveGeneric       #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE FlexibleInstances   #-}-{-# LANGUAGE LambdaCase          #-}-{-# LANGUAGE Rank2Types          #-}-{-# LANGUAGE TypeApplications    #-} {-# LANGUAGE TypeFamilies        #-}-{-# LANGUAGE TypeOperators       #-} module Data.Barbie.Internal.Functor   ( FunctorB(..) -  , GFunctorB+  , GFunctorB(..)   , gbmapDefault-  , CanDeriveGenericInstance+  , CanDeriveFunctorB   )  where -import Data.Barbie.Internal.Generics-import Data.Barbie.Internal.Tags (F,G)-import GHC.Generics+import Data.Generics.GenericN  -- | Barbie-types that can be mapped over. Instances of 'FunctorB' should --   satisfy the following laws:@@ -36,96 +25,96 @@   bmap :: (forall a . f a -> g a) -> b f -> b g    default bmap-    :: CanDeriveGenericInstance b+    :: forall f g+    .  CanDeriveFunctorB b f g     => (forall a . f a -> g a) -> b f -> b g   bmap = gbmapDefault --- | Intuivively, the requirements to have @'FunctorB' B@ derived are:+-- | @'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)@ for every @f@+--     * There is an instance of @'Generic' (B f)@. -----     * If @f@ is used as argument to some type in the definition of @B@, it---       is only on a Barbie-type with a 'FunctorB' instance.+--     * @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. -----     * Recursive usages of @B f@ are allowed to appear as argument to a---       'Functor' (e.g. @'Maybe' (B f)')-type CanDeriveGenericInstance b-  = ( Generic (b (Target F))-    , Generic (b (Target G))-    , GFunctorB (Rep (b (Target F)))-    , Rep (b (Target G)) ~ Repl (Target F) (Target G) (Rep (b (Target F)))+--     * @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-  :: CanDeriveGenericInstance b+  :: CanDeriveFunctorB b f g   => (forall a . f a -> g a) -> b f -> b g-gbmapDefault f b-  = unsafeUntargetBarbie @G $ to $ gbmap f $ from (unsafeTargetBarbie @F b)+gbmapDefault f+  = toN . gbmap f . fromN+{-# INLINE gbmapDefault #-}  -class GFunctorB b where-  gbmap :: (forall a . f a -> g a) -> b x -> Repl (Target F) (Target G) b x+class GFunctorB f g repbf repbg where+  gbmap :: (forall a . f a -> g a) -> repbf x -> repbg x   -- ---------------------------------- -- Trivial cases -- ---------------------------------- -instance GFunctorB x => GFunctorB (M1 i c x) where+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 #-}-  gbmap f (M1 x) = M1 (gbmap f x) -instance GFunctorB V1 where+instance GFunctorB f g V1 V1 where   gbmap _ _ = undefined -instance GFunctorB U1 where+instance GFunctorB f g U1 U1 where+  gbmap _ = id   {-# INLINE gbmap #-}-  gbmap _ u1 = u1 -instance (GFunctorB l, GFunctorB r) => GFunctorB (l :*: r) where+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 #-}-  gbmap f (l :*: r)-    = (gbmap f l) :*: gbmap f r -instance (GFunctorB l, GFunctorB r) => GFunctorB (l :+: r) where+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 #-}-  gbmap f = \case-    L1 l -> L1 (gbmap f l)-    R1 r -> R1 (gbmap f r)   -- -------------------------------- -- The interesting cases -- -------------------------------- -instance {-# OVERLAPPING #-} GFunctorB (K1 R (Target (W F) a)) where-  {-# INLINE gbmap #-}-  gbmap f (K1 fa)-    = K1 $ unsafeTarget @(W G) (f $ unsafeUntarget @(W F) fa)+type P0 = Param 0 -instance {-# OVERLAPPING #-} GFunctorB (K1 R (Target F a)) where+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 #-}-  gbmap f (K1 fa)-    = K1 $ unsafeTarget @G (f $ unsafeUntarget @F fa) -instance {-# OVERLAPPING #-} FunctorB b => GFunctorB (K1 R (b (Target F))) where+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 #-}-  gbmap f (K1 bf)-    = K1 $ bmap (unsafeTarget @G . f . unsafeUntarget @F) bf -instance {-# OVERLAPPING #-}-  ( Functor h-  , FunctorB b-  , Repl (Target F) (Target G) (K1 R (h (b (Target F)))) -- shouldn't be-      ~ (K1 R (h (b (Target G))))  -- necessary but ghc chokes otherwise-  )-  => GFunctorB (K1 R (h (b (Target F)))) where+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 #-}-  gbmap f (K1 hbf)-    = K1 (fmap (unsafeTargetBarbie @G . bmap f . unsafeUntargetBarbie @F) hbf) -instance (K1 i c) ~ Repl (Target F) (Target G) (K1 i c) => GFunctorB (K1 i c) where+instance GFunctorB f g (Rec x x) (Rec x x) where+  gbmap _ = id   {-# INLINE gbmap #-}-  gbmap _ k1 = k1

@@ -1,113 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Barbie.Internal.Functor------ GHC is at the momemt unable to derive @'Generic1' b@ for a Barbie-type--- @b@. Instead, we use a trick by which we use the uninhabited type--- 'Target' to identify the point where an 'f' occurs. That is, we coerce--- a @b f@ into a @b 'Target'@, operate on the representation of this type,--- and finally coerce back to the desired type.------------------------------------------------------------------------------{-# LANGUAGE ExplicitForAll #-}-{-# LANGUAGE TypeFamilies  #-}-{-# LANGUAGE TypeOperators #-}-module Data.Barbie.Internal.Generics-  ( Target (..)-  , unsafeTargetBarbie-  , unsafeUntarget-  , unsafeTarget-  , unsafeUntargetBarbie--  , W--  , Repl, Repl'--  , RecRep-  , RecUsage(..), NonRec(..)-  , AnnRec, DeannRec-  , toWithRecAnn-  , fromWithRecAnn--  )--where--import GHC.Generics-import Unsafe.Coerce (unsafeCoerce)---- | We use 'Target' to identify the position in---   in the generic representation where @f@ is used.---   This is a hack to overcome the fact that 'Generic1'---   does not currently work on a type @T f@ whenever---   if 'f' is applied in 'T', which are all the interesting---   cases!-data Target (f :: * -> *) a-  = Target (f a)--unsafeTargetBarbie :: forall t b f . b f -> b (Target t)-unsafeTargetBarbie = unsafeCoerce--unsafeUntarget :: forall t f a . Target t a -> f a-unsafeUntarget = unsafeCoerce--unsafeTarget :: forall t f a . f a -> Target t a-unsafeTarget = unsafeCoerce--unsafeUntargetBarbie :: forall t b f . b (Target t) -> b f-unsafeUntargetBarbie = unsafeCoerce--type family Repl f g rep where-    Repl f g (M1 i c x)       = M1 i c (Repl f g x)-    Repl f g V1               = V1-    Repl f g U1               = U1-    Repl (Target f) (Target g) (K1 i (Target (W f) a)) = K1 i (Target (W g) a)-    Repl f g (K1 i (f a))     = K1 i (g a)-    Repl f g (K1 i (b f))     = K1 i (b g)-    Repl f g (K1 i (h (b f))) = K1 i (h (b g))-    Repl f g (K1 i c)         = K1 i c-    Repl f g (l :+: r)        = (Repl f g l) :+: (Repl f g r)-    Repl f g (l :*: r)        = (Repl f g l) :*: (Repl f g r)----- | We use 'RecUsage' to identify the position in the---   generic representation where the barbie type is used---   recursively.-newtype RecUsage a-  = RecUsage a--newtype NonRec a-  = NonRec a--type family AnnRec a rep where-  AnnRec a (M1 i c x)  = M1  i c (AnnRec a x)-  AnnRec a V1          = V1-  AnnRec a U1          = U1-  AnnRec a (K1 i a)    = K1 i (RecUsage a)-  AnnRec a (K1 i a')   = K1 i (NonRec a')-  AnnRec a (l :*: r)   = AnnRec a l :*: AnnRec a r-  AnnRec a (l :+: r)   = AnnRec a l :+: AnnRec a r--type family DeannRec rep where-  DeannRec (M1 i c x)          = M1  i c (DeannRec x)-  DeannRec V1                  = V1-  DeannRec U1                  = U1-  DeannRec (K1 i (RecUsage a)) = K1 i a-  DeannRec (K1 i (NonRec a))   = K1 i a-  DeannRec (l :*: r)           = DeannRec l :*: DeannRec r-  DeannRec (l :+: r)           = DeannRec l :+: DeannRec r--fromWithRecAnn :: Generic a => a -> RecRep a x-fromWithRecAnn = unsafeCoerce . from--toWithRecAnn :: Generic a => RecRep a x -> a-toWithRecAnn = to . unsafeCoerce--type RecRep a = AnnRec a (Rep a)--type Repl' f g rep-  = Repl f g (DeannRec rep)----- | We use 'W' to identify usagaes of 'Wear' in the generic---   representation of a barbie-type.-data W (f :: * -> *) a

@@ -1,45 +1,39 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures             #-} {-# LANGUAGE TypeFamilies               #-} {-# LANGUAGE UndecidableInstances       #-} module Data.Barbie.Internal.Instances ( Barbie(..) )  where -import Data.Barbie.Internal.Bare 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.ProofB+import Data.Barbie.Internal.ProductC  import Data.Semigroup (Semigroup, (<>))  -- | A wrapper for Barbie-types, providing useful instances. newtype Barbie b (f :: * -> *)   = Barbie { getBarbie :: b f }-  deriving (FunctorB, ProductB, BareB, ProofB)+  deriving (FunctorB, ProductB, ProductBC)  -- Need to derive it manually to make GHC 8.0.2 happy instance ConstraintsB b => ConstraintsB (Barbie b) where-  type ConstraintsOf c f (Barbie b) = ConstraintsOf c f b-  adjProof = Barbie . adjProof . getBarbie+  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 (ProofB b, ConstraintsOf Semigroup f b) => Semigroup (Barbie b f) where-  (<>) = bzipWith3 mk bproof+instance (ProductBC b, AllBF Semigroup f b) => Semigroup (Barbie b f) where+  (<>) = bzipWith3 mk bdicts     where-      mk :: DictOf Semigroup f a -> f a -> f a -> f a+      mk :: Dict (ClassF Semigroup f) a -> f a -> f a -> f a       mk = requiringDict (<>) -instance (ProofB b, ConstraintsOf Semigroup f b, ConstraintsOf Monoid f b) => Monoid (Barbie b f) where-  mempty = bmap mk bproof-    where-      mk :: DictOf Monoid f a -> f a-      mk = requiringDict mempty-+instance (ProductBC b, AllBF Semigroup f b, AllBF Monoid f b) => Monoid (Barbie b f) where+  mempty  = bmempty   mappend = (<>)

@@ -1,78 +1,82 @@-{-# LANGUAGE ConstraintKinds      #-}-{-# LANGUAGE DataKinds            #-}-{-# LANGUAGE DefaultSignatures    #-}-{-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE Rank2Types           #-}+{-# LANGUAGE AllowAmbiguousTypes  #-} {-# LANGUAGE TypeFamilies         #-}-{-# LANGUAGE TypeOperators        #-}-{-# LANGUAGE TypeApplications     #-} {-# LANGUAGE UndecidableInstances #-} module Data.Barbie.Internal.Product   ( ProductB(buniq, bprod)   , bzip, bunzip, bzipWith, bzipWith3, bzipWith4   , (/*/), (/*) -  , CanDeriveGenericInstance, CanDeriveGenericInstance'-  , GProductB+  , CanDeriveProductB+  , GProductB(..)   , gbprodDefault, gbuniqDefault   )  where  import Data.Barbie.Internal.Functor(FunctorB(..))-import Data.Barbie.Internal.Generics-import Data.Barbie.Internal.Tags(F, G, FxG)+ import Data.Functor.Product (Product(..)) import Data.Functor.Prod -import GHC.Generics+import Data.Generics.GenericN   -- | Barbie-types that can form products, subject to the laws: -- -- @--- 'bmap' \('Pair' a _) . 'uncurry' . 'bprod' = 'fst'--- 'bmap' \('Pair' _ b) . 'uncurry' . 'bprod' = 'snd'+-- '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'}        -- has an instance+-- 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, any @x :: forall a . f a@--- determines a unique value of @b f@, witnessed by the 'buniq' method.--- Formally:+-- 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 where-  bprod :: b f -> b g -> b (Product f g)+  bprod :: b f -> b g -> b (f `Product` g)    buniq :: (forall a . f a) -> b f -  default bprod :: CanDeriveGenericInstance b => b f -> b g -> b (Product f g)+  default bprod :: CanDeriveProductB b f g => b f -> b g -> b (f `Product` g)   bprod = gbprodDefault -  default buniq :: CanDeriveGenericInstance' b => (forall a . f a) -> b f+  default buniq :: CanDeriveProductB b f f => (forall a . f a) -> b f   buniq = gbuniqDefault   -- | An alias of 'bprod', since this is like a 'zip' for Barbie-types.-bzip :: ProductB b => b f -> b g -> b (Product f g)+bzip :: ProductB b => b f -> b g -> b (f `Product` g) bzip = bprod  -- | An equivalent of 'unzip' for Barbie-types.-bunzip :: ProductB b => b (Product f g) -> (b f, b g)+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.@@ -99,28 +103,23 @@   = bmap (\(Pair (Pair (Pair fa ga) ha) ia) -> f fa ga ha ia)          (bf `bprod` bg `bprod` bh `bprod` bi) --- | The requirements to to derive @'ProductB' (B f)@ are more strict than those for---   'FunctorB' or 'TraversableB'. Intuitively, we need:++-- | @'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)@ for every @f@+--     * There is an instance of @'Generic' (B f)@. -----     * @B@ has only one constructor.+--     * @B@ has only one constructor (that is, it is not a sum-type). -----     * Every field of @B@' constructor is of the form 'f t'. That is, @B@ has no---       hidden structure.-type CanDeriveGenericInstance b-  = ( Generic (b (Target F))-    , Generic (b (Target G))-    , Generic (b (Target FxG))-    , GProductB (Rep (b (Target F)))-    , Rep (b (Target G)) ~ Repl (Target F) (Target G) (Rep (b (Target F)))-    , Rep (b (Target FxG)) ~ Repl (Target F) (Target FxG) (Rep (b (Target F)))+--     * 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)+    , GenericN (b (f `Product` g))+    , GProductB f g (RepN (b f)) (RepN (b g)) (RepN (b (f `Product` g)))     ) -type CanDeriveGenericInstance' b-  = ( Generic (b (Target F))-    , GProductB (Rep (b (Target F)))-    )  -- | Like 'bprod', but returns a binary 'Prod', instead of 'Product', which --   composes better.@@ -132,7 +131,7 @@   = 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'.+-- | 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@@ -154,83 +153,87 @@  -- | Default implementation of 'bprod' based on 'Generic'. gbprodDefault-  :: CanDeriveGenericInstance b-  => b f -> b g -> b (Product f g)+  :: forall b f g+  .  CanDeriveProductB b f g+  => b f -> b g -> b (f `Product` g) gbprodDefault l r-  = let l' = from (unsafeTargetBarbie @F l)-        r' = from (unsafeTargetBarbie @G r)-     in unsafeUntargetBarbie @FxG $ to (gbprod l' r')+  = toN $ gbprod @f @g (fromN l) (fromN r)+{-# INLINE gbprodDefault #-} -gbuniqDefault-  :: CanDeriveGenericInstance' b-  => (forall a . f a) -> b f+gbuniqDefault:: forall b f . CanDeriveProductB b f f => (forall a . f a) -> b f gbuniqDefault x-  = unsafeUntargetBarbie @F $ to (gbuniq x)+  = toN (gbuniq @f @f @_ @(RepN (b f)) @(RepN (b (f `Product` f))) x)+{-# INLINE gbuniqDefault #-} -class GProductB b where-  gbprod-    :: b x-    -> Repl (Target F) (Target G) b x-    -> Repl (Target F) (Target FxG) b x+class GProductB (f :: * -> *) (g :: * -> *) repbf repbg repbfg where+  gbprod :: repbf x -> repbg x -> repbfg x -  gbuniq-    :: (forall a . f a) -> b x+  gbuniq :: (forall a . f a) -> repbf x  -- ---------------------------------- -- Trivial cases -- ---------------------------------- -instance GProductB x => GProductB (M1 i c x) where+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)   {-# INLINE gbprod #-}-  gbprod (M1 l) (M1 r) = M1 (gbprod l r) +  gbuniq x = M1 (gbuniq @f @g @repf @repg @repfg x)   {-# INLINE gbuniq #-}-  gbuniq x = M1 (gbuniq x) -instance GProductB U1 where-  {-# INLINE gbprod #-}++instance GProductB f g U1 U1 U1 where   gbprod U1 U1 = U1+  {-# INLINE gbprod #-} -  {-# INLINE gbuniq #-}   gbuniq _ = U1+  {-# INLINE gbuniq #-} -instance(GProductB l, GProductB r) => GProductB (l :*: r) where-  {-# INLINE gbprod #-}+instance+  ( GProductB f g lf lg lfg+  , GProductB f g rf rg rfg+  ) => GProductB f g (lf  :*: rf)+                     (lg  :*: rg)+                     (lfg :*: rfg) where   gbprod (l1 :*: l2) (r1 :*: r2)-    = (l1 `gbprod` r1) :*: (l2 `gbprod` r2)+    = (l1 `lprod` r1) :*: (l2 `rprod` r2)+    where+      lprod = gbprod @f @g+      rprod = gbprod @f @g+  {-# INLINE gbprod #-} +  gbuniq x = (gbuniq @f @g @lf @lg @lfg x :*: gbuniq @f @g @rf @rg @rfg x)   {-# INLINE gbuniq #-}-  gbuniq x = (gbuniq x :*: gbuniq x)   -- -------------------------------- -- The interesting cases -- -------------------------------- -instance {-# OVERLAPPING #-} GProductB (K1 R (Target (W F) a)) where-  {-# INLINE gbprod #-}-  gbprod (K1 fa) (K1 ga)-    = let fxga = Pair (unsafeUntarget @(W F) fa) (unsafeUntarget @(W G) ga)-      in K1 (unsafeTarget @(W FxG) fxga)--  {-# INLINE gbuniq #-}-  gbuniq x = K1 (unsafeTarget @(W F) x)+type P0 = Param 0 -instance {-# OVERLAPPING #-} GProductB (K1 R (Target F a)) where+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))+    = Rec (K1 (Pair fa ga))   {-# INLINE gbprod #-}-  gbprod (K1 fa) (K1 ga)-    = let fxga = Pair (unsafeUntarget @F fa) (unsafeUntarget @G ga)-      in K1 (unsafeTarget @FxG fxga) +  gbuniq x = Rec (K1 x)   {-# INLINE gbuniq #-}-  gbuniq x = K1 (unsafeTarget @F x)  -instance {-# OVERLAPPING #-} ProductB b => GProductB (K1 R (b (Target F))) where+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))+    = Rec (K1 (bf `bprod` bg))   {-# INLINE gbprod #-}-  gbprod (K1 bf) (K1 bg)-    = let bfxg = unsafeUntargetBarbie @F bf `bprod` unsafeUntargetBarbie @G bg-      in K1 (unsafeTargetBarbie @FxG bfxg) +  gbuniq x = Rec (K1 (buniq x))   {-# INLINE gbuniq #-}-  gbuniq x = K1 (unsafeTargetBarbie @F (buniq x))

@@ -0,0 +1,154 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}+module Data.Barbie.Internal.ProductC+  ( ProductBC(..)+  , buniqC+  , bmempty++  , CanDeriveProductBC+  , GAllB+  , 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.Generics.GenericN++-- | 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 where+  bdicts :: AllB c b => b (Dict c)++  default bdicts :: (CanDeriveProductBC c b, AllB c b) => b (Dict c)+  bdicts = gbdictsDefault++-- | Every type that admits a generic instance of 'ProductB' and+--   'ConstraintsB', has a generic instance of 'ProductBC' as well.+type CanDeriveProductBC c b+  = ( GenericN (b (Dict c))+    , AllB c b ~ GAllB c (GAllBRep b)+    , GProductBC c (GAllBRep b) (RepN (b (Dict c)))+    )++-- | Like 'buniq' but a constraint is allowed to be required on+--   each element of @b@.+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++{-# DEPRECATED ProofB "Class was renamed to ProductBC" #-}+type ProofB b = ProductBC b+++-- ===============================================================+--  Generic derivations+-- ===============================================================++-- | Default implementation of 'bproof' based on 'Generic'.+gbdictsDefault+  :: forall b c+  .  ( CanDeriveProductBC c b+     , AllB c b+     )+  => b (Dict c)+gbdictsDefault+  = toN $ gbdicts @c @(GAllBRep b)+{-# INLINE gbdictsDefault #-}+++class GProductBC c repbx repbd where+  gbdicts :: GAllB c repbx => repbd x++-- ----------------------------------+-- Trivial cases+-- ----------------------------------++instance GProductBC c repbx repbd => GProductBC c (M1 i k repbx) (M1 i k repbd) where+  gbdicts = M1 (gbdicts @c @repbx)+  {-# INLINE gbdicts #-}++instance GProductBC c U1 U1 where+  gbdicts = U1+  {-# INLINE gbdicts #-}++instance+  ( GProductBC c lx ld+  , GProductBC c rx rd+  ) => GProductBC c (lx :*: rx)+                    (ld :*: rd) where+  gbdicts = gbdicts @c @lx @ld :*: gbdicts @c @rx @rd+  {-# INLINE gbdicts #-}+++-- --------------------------------+-- The interesting cases+-- --------------------------------++type P0 = Param 0++instance GProductBC c (Rec (P0 X a) (X a))+                      (Rec (P0 (Dict c) a) (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)))+                              (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'

@@ -1,157 +0,0 @@-{-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE DefaultSignatures     #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE KindSignatures        #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeApplications      #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE UndecidableInstances  #-}-module Data.Barbie.Internal.ProofB-  ( ProofB(..)--  , CanDeriveGenericInstance, ConstraintsOfMatchesGenericDeriv-  , GConstraintsOf-  , GProof-  , gbproofDefault-  )--where--import Data.Barbie.Internal.Classification (BarbieType(..), ClassifyBarbie)-import Data.Barbie.Internal.Dicts(DictOf(..), packDict)-import Data.Barbie.Internal.Generics-import Data.Barbie.Internal.Constraints hiding (CanDeriveGenericInstance, ConstraintsOfMatchesGenericDeriv)-import Data.Barbie.Internal.Product(ProductB(..))-import Data.Barbie.Internal.Tags(P, F)-import Data.Barbie.Internal.Wear(Wear)--import Data.Proxy--import GHC.Generics---- | Barbie-types with products have a canonical proof of instance.------ There is a default 'bproof' implementation for 'Generic' types, so--- instances can derived automatically.-class (ConstraintsB b, ProductB b) => ProofB b where-  bproof :: ConstraintsOf c f b => b (DictOf c f)--  default bproof-    :: ( CanDeriveGenericInstance b-       , ConstraintsOfMatchesGenericDeriv c f b-       , ConstraintsOf c f b-       )-    => b (DictOf c f)-  bproof = gbproofDefault---- | Every type that admits a generic instance of 'ProductB' and---   'ConstraintsB', has a generic instance of 'ProofB' as well.-type CanDeriveGenericInstance b-  = ( Generic (b (Target P))-    , GProof (ClassifyBarbie b) b (RecRep (b (Target F)))-    , Rep (b (Target P)) ~ Repl' (Target F) (Target P) (RecRep (b (Target F)))-    )--type ConstraintsOfMatchesGenericDeriv c f b-  = ( ConstraintsOf c f b ~ GConstraintsOf c f (RecRep (b (Target F)))-    , ConstraintsOf c f b ~ ConstraintByType (ClassifyBarbie b) c f (RecRep (b (Target F)))-    )---- ===============================================================---  Generic derivations--- ===============================================================---- | Default implementation of 'bproof' based on 'Generic'.-gbproofDefault-  :: forall b c f-  .  ( CanDeriveGenericInstance b-     , ConstraintsOfMatchesGenericDeriv c f b-     , ConstraintsOf c f b-     )-  => b (DictOf c f)-gbproofDefault-  = unsafeUntargetBarbie @P $ to $ gbproof pcbf pbt pb-  where-    pcbf = Proxy :: Proxy (c (b f))-    pbt  = Proxy :: Proxy (ClassifyBarbie b)-    pb   = Proxy :: Proxy (RecRep (b (Target F)) x)----class GProof (bt :: BarbieType) b rep where-  gbproof-    :: ( ConstraintByType bt c f rep-       , GConstraintsOf c f (RecRep (b (Target F))) -- for the recursive case!-       )-    => Proxy (c (b f))-    -> Proxy bt-    -> Proxy (rep x)-    -> Repl' (Target F) (Target P) rep x----- ------------------------------------- Trivial cases--- ------------------------------------instance GProof bt b x => GProof bt b (M1 _i _c x) where-  {-# INLINE gbproof #-}-  gbproof pcbf pbt pm1-    = M1 (gbproof pcbf pbt (unM1 <$> pm1))--instance GProof bt b U1 where-  {-# INLINE gbproof #-}-  gbproof _ _ _ = U1--instance (GProof bt b l, GProof bt b r) => GProof bt b (l :*: r) where-  {-# INLINE gbproof #-}-  gbproof pcbf pbt pp-    =-    gbproof pcbf pbt (left <$> pp) :*: gbproof pcbf pbt (right <$> pp)-    where-      left  (l :*: _) = l-      right (_ :*: r) = r----- ----------------------------------- The interesting cases--- ----------------------------------instance {-# OVERLAPPING #-} GProof 'WearBarbie b (K1 R (NonRec (Target (W F) a))) where-  {-# INLINE gbproof #-}-  gbproof pcbf _ _-    = K1 $ unsafeTarget @(W P) (mkProof pcbf)-    where-      mkProof :: (c (f a), Wear f a ~ f a) => Proxy (c (b f)) -> DictOf c f a-      mkProof _ = packDict--instance {-# OVERLAPPING #-} GProof 'NonWearBarbie b (K1 R (NonRec (Target F a))) where-  {-# INLINE gbproof #-}-  gbproof pcbf _ _-    = K1 $ unsafeTarget @P (mkProof pcbf)-    where-      mkProof :: c (f a) => Proxy (c (b f)) -> DictOf c f a-      mkProof _ = packDict--instance {-# OVERLAPPING #-}-  ( CanDeriveGenericInstance b-  , bt ~ ClassifyBarbie b-  )-    => GProof bt b (K1 R (RecUsage (b (Target F)))) where-  {-# INLINE gbproof #-}-  gbproof pcbf pbt _-    = K1 $ to $ gbproof pcbf pbt pr-      where-        pr = Proxy :: Proxy (RecRep (b (Target F)) x)--instance {-# OVERLAPPING #-}-  ProofB b' => GProof bt b (K1 R (NonRec (b' (Target F)))) where-  {-# INLINE gbproof #-}-  gbproof pcbf _ _-    = K1 $ unsafeTargetBarbie @P (proof' pcbf)-    where-      proof' :: ConstraintsOf c f b' => Proxy (c (b f)) -> b' (DictOf c f)-      proof' _ = bproof

@@ -1,32 +0,0 @@-module Data.Barbie.Internal.Tags-  ( F, G, FxG-  , P, PxF-  , I, B-  )--where---- NB. For type-safety, none of the tags defined here--- should be exported.---- | THIS SHOULD NEVER SHOW UP IN HADDOCK!-data F a---- | THIS SHOULD NEVER SHOW UP IN HADDOCK!-data G a---- | THIS SHOULD NEVER SHOW UP IN HADDOCK!-data FxG a----- | THIS SHOULD NEVER SHOW UP IN HADDOCK!-data P a---- | THIS SHOULD NEVER SHOW UP IN HADDOCK!-data PxF a---- | THIS SHOULD NEVER SHOW UP IN HADDOCK!-data I a---- | THIS SHOULD NEVER SHOW UP IN HADDOCK!-data B a

@@ -1,43 +1,37 @@ ----------------------------------------------------------------------------- -- |--- Module      :  Data.Barbie.Internal.Functor+-- Module      :  Data.Barbie.Internal.Traversable -----------------------------------------------------------------------------{-# LANGUAGE ConstraintKinds    #-}-{-# LANGUAGE DefaultSignatures  #-}-{-# LANGUAGE FlexibleContexts   #-}-{-# LANGUAGE FlexibleInstances  #-}-{-# LANGUAGE LambdaCase         #-}-{-# LANGUAGE Rank2Types         #-}-{-# LANGUAGE TypeApplications   #-} {-# LANGUAGE TypeFamilies       #-}-{-# LANGUAGE TypeOperators      #-} module Data.Barbie.Internal.Traversable   ( TraversableB(..)   , btraverse_   , bsequence+  , bsequence'+  , bfoldMap -  , CanDeriveGenericInstance-  , GTraversableB+  , CanDeriveTraversableB+  , GTraversableB(..)   , gbtraverseDefault   )  where  import Data.Barbie.Internal.Functor (FunctorB(..))-import Data.Barbie.Internal.Generics-import Data.Barbie.Internal.Tags (F,G)+ import Data.Functor (void) import Data.Functor.Compose (Compose(..)) import Data.Functor.Const (Const(..))-import GHC.Generics+import Data.Functor.Identity (Identity(..))+import Data.Generics.GenericN   -- | 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+--  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 -- @ --@@ -47,7 +41,7 @@   btraverse :: Applicative t => (forall a . f a -> t (g a)) -> b f -> t (b g)    default btraverse-    :: ( Applicative t, CanDeriveGenericInstance b)+    :: ( Applicative t, CanDeriveTraversableB b f g)     => (forall a . f a -> t (g a)) -> b f -> t (b g)   btraverse = gbtraverseDefault @@ -66,98 +60,149 @@ 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) --- | Intuivively, the requirements to have @'TraversableB' B@ derived are:++-- | 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)@ for every @f@+--     * There is an instance of @'Generic' (B f)@. -----     * If @f@ is used as argument to some type in the definition of @B@, it---       is only on a Barbie-type with a 'TraversableB' instance.+--     * @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. -----     * Recursive usages of @B f@ are allowed to appear as argument to a---       'Traversable' (e.g. @'Maybe' (B f)')-type CanDeriveGenericInstance b-  = ( Generic (b (Target F))-    , Generic (b (Target G))-    , GTraversableB (Rep (b (Target F)))-    , Rep (b (Target G)) ~ Repl (Target F) (Target G) (Rep (b (Target F)))+--     * @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-  :: ( Applicative t, CanDeriveGenericInstance b)+  :: forall b f g t+  .  (Applicative t, CanDeriveTraversableB b f g)   => (forall a . f a -> t (g a))   -> b f -> t (b g)-gbtraverseDefault f b-  = unsafeUntargetBarbie @G . to <$> gbtraverse f (from (unsafeTargetBarbie @F b))-+gbtraverseDefault h+  = fmap toN . gbtraverse h . fromN+{-# INLINE gbtraverseDefault #-}  -class GTraversableB b where+class GTraversableB f g repbf repbg where   gbtraverse-    :: Applicative t-    => (forall a . f a -> t (g a))-    -> b x -> t (Repl (Target F) (Target G) b x)+    :: Applicative t => (forall a . f a -> t (g a)) -> repbf x -> t (repbg x)  -- ---------------------------------- -- Trivial cases -- ---------------------------------- -instance GTraversableB x => GTraversableB (M1 i c x) where+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 #-}-  gbtraverse f (M1 x) = M1 <$> gbtraverse f x -instance GTraversableB V1 where-  {-# INLINE gbtraverse #-}+instance GTraversableB f g V1 V1 where   gbtraverse _ _ = undefined+  {-# INLINE gbtraverse #-} -instance GTraversableB U1 where+instance GTraversableB f g U1 U1 where+  gbtraverse _ = pure   {-# INLINE gbtraverse #-}-  gbtraverse _ u1 = pure u1 -instance (GTraversableB l, GTraversableB r) => GTraversableB (l :*: r) where+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 #-}-  gbtraverse f (l :*: r)-    = (:*:) <$> gbtraverse f l <*> gbtraverse f r -instance (GTraversableB l, GTraversableB r) => GTraversableB (l :+: r) where+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 #-}-  gbtraverse f = \case-    L1 l -> L1 <$> gbtraverse f l-    R1 r -> R1 <$> gbtraverse f r   -- -------------------------------- -- The interesting cases -- -------------------------------- -instance {-# OVERLAPPING #-} GTraversableB (K1 R (Target (W F) a)) where-  {-# INLINE gbtraverse #-}-  gbtraverse f (K1 fa)-    = K1 . unsafeTarget @(W G) <$> f (unsafeUntarget @(W F) fa)+type P0 = Param 0 -instance {-# OVERLAPPING #-} GTraversableB (K1 R (Target F a)) where+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 #-}-  gbtraverse f (K1 fa)-    = K1 . unsafeTarget @G <$> f (unsafeUntarget @F fa) -instance {-# OVERLAPPING #-} TraversableB b => GTraversableB (K1 R (b (Target F))) where+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 #-}-  gbtraverse f (K1 bf)-    = K1 <$> btraverse (fmap (unsafeTarget @G) . f . unsafeUntarget @F) bf -instance {-# OVERLAPPING #-}-  ( Traversable h-  , TraversableB b-  , Repl (Target F) (Target G) (K1 R (h (b (Target F)))) -- shouldn't be-      ~ (K1 R (h (b (Target G))))  -- necessary but ghc chokes otherwise-  )-  => GTraversableB (K1 R (h (b (Target F)))) where+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 #-}-  gbtraverse f (K1 hbf)-    = K1 <$> traverse (fmap (unsafeTargetBarbie @G) . btraverse f . unsafeUntargetBarbie @F) hbf  -instance (K1 i c) ~ Repl (Target F) (Target G) (K1 i c) => GTraversableB (K1 i c) where+instance GTraversableB f g (Rec a a) (Rec a a) where+  gbtraverse _ = pure   {-# INLINE gbtraverse #-}-  gbtraverse _ k1 = pure k1+++++-- 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,34 +1,33 @@-{-# LANGUAGE TypeFamilies       #-}+{-# LANGUAGE TypeFamilies #-} module Data.Barbie.Internal.Wear-  ( Bare, Wear+  ( Wear, Bare, Covered   )  where --import Data.Barbie.Internal.Generics(Target, W)+data Bare+data Covered  -- | The 'Wear' type-function allows one to define a Barbie-type as -- -- @--- data B f---   = B { f1 :: 'Wear' f 'Int'---       , f2 :: 'Wear' f 'Bool'+-- data B t f+--   = B { f1 :: 'Wear' t f 'Int'+--       , f2 :: 'Wear' t f 'Bool' --       } -- @ ----- This way, one can use 'Bare' as a phantom that denotes no functor--- around the typw:+-- 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'+-- B { f1 :: 5, f2 = 'True' } :: B 'Bare' f -- @-type family Wear f a where-  Wear Bare a = a-  Wear (Target f) a = Target (W f) a-  Wear f    a = f a----- | 'Bare' is the only type such that @'Wear' 'Bare' a ~ a'@.-data Bare a+type family Wear t f a where+  Wear Bare    f a = a+  Wear Covered f a = f a

@@ -1,8 +1,3 @@-{-# LANGUAGE EmptyCase            #-}-{-# LANGUAGE DeriveGeneric        #-}-{-# LANGUAGE DeriveDataTypeable   #-}-{-# LANGUAGE KindSignatures       #-}-{-# LANGUAGE StandaloneDeriving   #-} module Data.Barbie.Trivial   ( Void   , Unit (..)@@ -10,11 +5,10 @@  where -import Data.Barbie.Internal.Bare(BareB(..)) import Data.Barbie.Internal.Constraints(ConstraintsB(..)) import Data.Barbie.Internal.Functor(FunctorB(..))-import Data.Barbie.Internal.ProofB(ProofB(..)) import Data.Barbie.Internal.Product(ProductB(..))+import Data.Barbie.Internal.ProductC(ProductBC(..)) import Data.Barbie.Internal.Traversable(TraversableB(..))  import Data.Data (Data(..))@@ -47,7 +41,6 @@ instance FunctorB Void instance TraversableB Void instance ConstraintsB Void-instance BareB Void   -- | A barbie type without structure.@@ -69,5 +62,4 @@ instance TraversableB Unit instance ProductB Unit instance ConstraintsB Unit-instance ProofB Unit-instance BareB Unit+instance ProductBC Unit

@@ -15,15 +15,9 @@ --     ⋮ -- @ -----------------------------------------------------------------------------{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-} module Data.Functor.Prod   ( -- * n-tuples of functors.     Prod(Unit, Cons)

@@ -0,0 +1,88 @@+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE InstanceSigs         #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}++--------------------------------------------------------------------------------+-- |+-- Module      : Data.Generics.GenericN+-- Copyright   : (C) 2018 Csongor Kiss+-- License     : BSD3+-- Stability   : experimental+-- Portability : non-portable+--+-- Generic representation of types with multiple parameters+--+--------------------------------------------------------------------------------++module Data.Generics.GenericN+  ( Param+  , SameOrParam+  , Rec (Rec, unRec)+  , GenericN (..)+  , module GHC.Generics+  ) where++import Data.Kind+import GHC.Generics+import GHC.TypeLits+import Data.Coerce++data Param (n :: Nat) (original :: k' -> k'') (a :: k)++type family Indexed (t :: k) (i :: Nat) :: k where+  Indexed (t a) i = Indexed t (i + 1) (Param i a)+  Indexed t _     = t++newtype Rec (p :: Type) a x = Rec { unRec :: K1 R a x }++type family Zip (a :: Type -> Type) (b :: Type -> Type) :: Type -> Type where+  Zip (M1 mt m s) (M1 mt m t)+    = M1 mt m (Zip s t)+  Zip (l :+: r) (l' :+: r')+    = Zip l l' :+: Zip r r'+  Zip (l :*: r) (l' :*: r')+    = Zip l l' :*: Zip r r'+  Zip (Rec0 p) (Rec0 a)+    = Rec p a+  Zip U1 U1+    = U1+  Zip V1 V1+    = V1+++class+  ( Coercible (Rep a) (RepN a)+  , Generic a+  ) => GenericN (a :: Type) where+  type family RepN (a :: Type) :: Type -> Type+  type instance RepN a = Zip (Rep (Indexed a 0)) (Rep a)+  toN :: RepN a x -> a+  fromN :: a -> RepN a x++instance+  ( Coercible (Rep a) (RepN a)+  , Generic a+  ) => GenericN a where+  toN :: forall x. RepN a x -> a+  toN   = coerce (to :: Rep a x -> a)+  {-# INLINE toN #-}++  fromN :: forall x. a -> RepN a x+  fromN = coerce (from :: a -> Rep a x)+  {-# INLINE fromN #-}+++-- | @'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)

@@ -1,8 +1,4 @@ {-# LANGUAGE DeriveAnyClass       #-}-{-# LANGUAGE DeriveGeneric        #-}-{-# LANGUAGE DeriveDataTypeable   #-}-{-# LANGUAGE KindSignatures       #-}-{-# LANGUAGE StandaloneDeriving   #-} {-# LANGUAGE TypeFamilies         #-} {-# LANGUAGE UndecidableInstances #-} module Barbies@@ -15,26 +11,15 @@   , Record1S(..)   , Record3S(..) -  , Record1W(..)-  , Record3W(..)--  , Record1WS(..)-  , Record3WS(..)-   , Ignore1(..)    , Sum3(..)-  , Sum3W(..)    , CompositeRecord(..)-  , CompositeRecordW(..)   , SumRec(..)-  , SumRecW(..)   , InfRec(..)-  , InfRecW(..)    , NestedF(..)-  , NestedFW(..)   )  where@@ -60,8 +45,7 @@ instance TraversableB Record0 instance ProductB Record0 instance ConstraintsB Record0-instance ProofB Record0-instance BareB Record0+instance ProductBC Record0  instance Arbitrary (Record0 f) where arbitrary = pure Record0 @@ -75,12 +59,12 @@ instance TraversableB Record1 instance ProductB Record1 instance ConstraintsB Record1-instance ProofB Record1+instance ProductBC Record1 -deriving instance ConstraintsOf Show f Record1 => Show (Record1 f)-deriving instance ConstraintsOf Eq   f Record1 => Eq   (Record1 f)+deriving instance AllBF Show f Record1 => Show (Record1 f)+deriving instance AllBF Eq   f Record1 => Eq   (Record1 f) -instance ConstraintsOf Arbitrary f Record1 => Arbitrary (Record1 f) where+instance AllBF Arbitrary f Record1 => Arbitrary (Record1 f) where   arbitrary = Record1 <$> arbitrary  @@ -93,55 +77,15 @@ instance TraversableB Record1S instance ProductB Record1S instance ConstraintsB Record1S-instance ProofB Record1S+instance ProductBC Record1S -deriving instance ConstraintsOf Show f Record1S => Show (Record1S f)-deriving instance ConstraintsOf Eq   f Record1S => Eq   (Record1S f)+deriving instance AllBF Show f Record1S => Show (Record1S f)+deriving instance AllBF Eq   f Record1S => Eq   (Record1S f) -instance ConstraintsOf Arbitrary f Record1S => Arbitrary (Record1S f) where+instance AllBF Arbitrary f Record1S => Arbitrary (Record1S f) where   arbitrary = Record1S <$> arbitrary  -data Record1W f-  = Record1W { rec1w_f1 :: Wear f Int }-  deriving (Generic, Typeable)---instance FunctorB Record1W-instance TraversableB Record1W-instance ProductB Record1W-instance ConstraintsB Record1W-instance ProofB Record1W-instance BareB Record1W---deriving instance ConstraintsOf Show f Record1W => Show (Record1W f)-deriving instance ConstraintsOf Eq   f Record1W => Eq   (Record1W f)--instance ConstraintsOf Arbitrary f Record1W => Arbitrary (Record1W f) where-  arbitrary = Record1W <$> arbitrary---data Record1WS f-  = Record1WS { rec1ws_f1 :: !(Wear f Int) }-  deriving (Generic, Typeable)---instance FunctorB Record1WS-instance TraversableB Record1WS-instance ProductB Record1WS-instance ConstraintsB Record1WS-instance ProofB Record1WS-instance BareB Record1WS---deriving instance ConstraintsOf Show f Record1WS => Show (Record1WS f)-deriving instance ConstraintsOf Eq   f Record1WS => Eq   (Record1WS f)--instance ConstraintsOf Arbitrary f Record1WS => Arbitrary (Record1WS f) where-  arbitrary = Record1WS <$> arbitrary-- data Record3 f   = Record3       { rec3_f1 :: f Int@@ -155,12 +99,12 @@ instance TraversableB Record3 instance ProductB Record3 instance ConstraintsB Record3-instance ProofB Record3+instance ProductBC Record3 -deriving instance ConstraintsOf Show f Record3 => Show (Record3 f)-deriving instance ConstraintsOf Eq   f Record3 => Eq   (Record3 f)+deriving instance AllBF Show f Record3 => Show (Record3 f)+deriving instance AllBF Eq   f Record3 => Eq   (Record3 f) -instance ConstraintsOf Arbitrary f Record3 => Arbitrary (Record3 f) where+instance AllBF Arbitrary f Record3 => Arbitrary (Record3 f) where   arbitrary = Record3 <$> arbitrary <*> arbitrary <*> arbitrary  data Record3S f@@ -176,64 +120,14 @@ instance TraversableB Record3S instance ProductB Record3S instance ConstraintsB Record3S-instance ProofB Record3S+instance ProductBC Record3S -deriving instance ConstraintsOf Show f Record3S => Show (Record3S f)-deriving instance ConstraintsOf Eq   f Record3S => Eq   (Record3S f)+deriving instance AllBF Show f Record3S => Show (Record3S f)+deriving instance AllBF Eq   f Record3S => Eq   (Record3S f) -instance ConstraintsOf Arbitrary f Record3S => Arbitrary (Record3S f) where+instance AllBF Arbitrary f Record3S => Arbitrary (Record3S f) where   arbitrary = Record3S <$> arbitrary <*> arbitrary <*> arbitrary --data Record3W f-  = Record3W-      { rec3w_f1 :: Wear f Int-      , rec3w_f2 :: Wear f Bool-      , rec3w_f3 :: Wear f Char-      }-  deriving (Generic, Typeable)---instance FunctorB Record3W-instance TraversableB Record3W-instance ProductB Record3W-instance ConstraintsB Record3W-instance ProofB Record3W--instance BareB Record3W--deriving instance ConstraintsOf Show f Record3W => Show (Record3W f)-deriving instance ConstraintsOf Eq   f Record3W => Eq   (Record3W f)--instance ConstraintsOf Arbitrary f Record3W => Arbitrary (Record3W f) where-  arbitrary = Record3W <$> arbitrary <*> arbitrary <*> arbitrary---data Record3WS f-  = Record3WS-      { rec3ws_f1 :: !(Wear f Int)-      , rec3ws_f2 :: !(Wear f Bool)-      , rec3ws_f3 :: !(Wear f Char)-      }-  deriving (Generic, Typeable)---instance FunctorB Record3WS-instance TraversableB Record3WS-instance ProductB Record3WS-instance ConstraintsB Record3WS-instance ProofB Record3WS--instance BareB Record3WS--deriving instance ConstraintsOf Show f Record3WS => Show (Record3WS f)-deriving instance ConstraintsOf Eq   f Record3WS => Eq   (Record3WS f)--instance ConstraintsOf Arbitrary f Record3WS => Arbitrary (Record3WS f) where-  arbitrary = Record3WS <$> arbitrary <*> arbitrary <*> arbitrary--- ----------------------------------------------------- -- Bad products -----------------------------------------------------@@ -263,10 +157,10 @@ instance TraversableB Sum3 instance ConstraintsB Sum3 -deriving instance ConstraintsOf Show f Sum3 => Show (Sum3 f)-deriving instance ConstraintsOf Eq   f Sum3 => Eq   (Sum3 f)+deriving instance AllBF Show f Sum3 => Show (Sum3 f)+deriving instance AllBF Eq   f Sum3 => Eq   (Sum3 f) -instance ConstraintsOf Arbitrary f Sum3 => Arbitrary (Sum3 f) where+instance AllBF Arbitrary f Sum3 => Arbitrary (Sum3 f) where   arbitrary     = oneof         [ pure Sum3_0@@ -274,29 +168,6 @@         , Sum3_2 <$> arbitrary <*> arbitrary         ] -data Sum3W f-  = Sum3W_0-  | Sum3W_1 (Wear f Int)-  | Sum3W_2 (Wear f Int) (Wear f Bool)-  deriving (Generic, Typeable)--instance FunctorB Sum3W-instance TraversableB Sum3W-instance ConstraintsB Sum3W-instance BareB Sum3W--deriving instance ConstraintsOf Show f Sum3W => Show (Sum3W f)-deriving instance ConstraintsOf Eq   f Sum3W => Eq   (Sum3W f)--instance ConstraintsOf Arbitrary f Sum3W => Arbitrary (Sum3W f) where-  arbitrary-    = oneof-        [ pure Sum3W_0-        , Sum3W_1 <$> arbitrary-        , Sum3W_2 <$> arbitrary <*> arbitrary-        ]-- ----------------------------------------------------- -- Composite and recursive -----------------------------------------------------@@ -314,39 +185,15 @@ instance TraversableB CompositeRecord instance ProductB CompositeRecord instance ConstraintsB CompositeRecord-instance ProofB CompositeRecord+instance ProductBC CompositeRecord -deriving instance ConstraintsOf Show f CompositeRecord => Show (CompositeRecord f)-deriving instance ConstraintsOf Eq   f CompositeRecord => Eq   (CompositeRecord f)+deriving instance AllBF Show f CompositeRecord => Show (CompositeRecord f)+deriving instance AllBF Eq   f CompositeRecord => Eq   (CompositeRecord f) -instance ConstraintsOf Arbitrary f CompositeRecord => Arbitrary (CompositeRecord f) where+instance AllBF Arbitrary f CompositeRecord => Arbitrary (CompositeRecord f) where   arbitrary     = CompositeRecord <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -data CompositeRecordW f-  = CompositeRecordW-      { crecw_f1 :: Wear f Int-      , crecw_F2 :: Wear f Bool-      , crecw_f3 :: Record3W f-      , crecw_f4 :: Record1W f-      }-  deriving (Generic, Typeable)--instance FunctorB CompositeRecordW-instance TraversableB CompositeRecordW-instance ProductB CompositeRecordW-instance ConstraintsB CompositeRecordW-instance ProofB CompositeRecordW-instance BareB CompositeRecordW--deriving instance ConstraintsOf Show f CompositeRecordW => Show (CompositeRecordW f)-deriving instance ConstraintsOf Eq   f CompositeRecordW => Eq   (CompositeRecordW f)--instance ConstraintsOf Arbitrary f CompositeRecordW => Arbitrary (CompositeRecordW f) where-  arbitrary-    = CompositeRecordW <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary-- data SumRec f   = SumRec_0   | SumRec_1 (f Int)@@ -357,10 +204,10 @@ instance TraversableB SumRec instance ConstraintsB SumRec -deriving instance ConstraintsOf Show f SumRec => Show (SumRec f)-deriving instance ConstraintsOf Eq   f SumRec => Eq   (SumRec f)+deriving instance AllBF Show f SumRec => Show (SumRec f)+deriving instance AllBF Eq   f SumRec => Eq   (SumRec f) -instance ConstraintsOf Arbitrary f SumRec => Arbitrary (SumRec f) where+instance AllBF Arbitrary f SumRec => Arbitrary (SumRec f) where   arbitrary     = oneof         [ pure SumRec_0@@ -368,29 +215,6 @@         , SumRec_2 <$> arbitrary <*> arbitrary         ] -data SumRecW f-  = SumRecW_0-  | SumRecW_1 (Wear f Int)-  | SumRecW_2 (Wear f Int) (SumRecW f)-  deriving (Generic, Typeable)--instance FunctorB SumRecW-instance TraversableB SumRecW-instance ConstraintsB SumRecW-instance BareB SumRecW--deriving instance ConstraintsOf Show f SumRecW => Show (SumRecW f)-deriving instance ConstraintsOf Eq   f SumRecW => Eq   (SumRecW f)--instance ConstraintsOf Arbitrary f SumRecW => Arbitrary (SumRecW f) where-  arbitrary-    = oneof-        [ pure SumRecW_0-        , SumRecW_1 <$> arbitrary-        , SumRecW_2 <$> arbitrary <*> arbitrary-        ]-- data InfRec f   = InfRec { ir_1 :: f Int, ir_2 :: InfRec f }   deriving (Generic, Typeable)@@ -399,26 +223,10 @@ instance TraversableB InfRec instance ProductB InfRec instance ConstraintsB InfRec-instance ProofB InfRec--deriving instance ConstraintsOf Show f InfRec => Show (InfRec f)-deriving instance ConstraintsOf Eq   f InfRec => Eq   (InfRec f)--data InfRecW f-  = InfRecW { irw_1 :: Wear f Int, irw_2 :: InfRecW f }-  deriving (Generic, Typeable)---instance FunctorB InfRecW-instance TraversableB InfRecW-instance ProductB InfRecW-instance ConstraintsB InfRecW-instance ProofB InfRecW-instance BareB InfRecW--deriving instance ConstraintsOf Show f InfRecW => Show (InfRecW f)-deriving instance ConstraintsOf Eq   f InfRecW => Eq   (InfRecW f)+instance ProductBC InfRec +deriving instance AllBF Show f InfRec => Show (InfRec f)+deriving instance AllBF Eq   f InfRec => Eq   (InfRec f)  ----------------------------------------------------- -- Nested under functors@@ -439,28 +247,38 @@ 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), ConstraintsOf Arbitrary f Record3, ConstraintsOf Arbitrary f Sum3) => Arbitrary (NestedF f) where+instance (Arbitrary (f Int), AllBF Arbitrary f Record3, AllBF Arbitrary f Sum3) => Arbitrary (NestedF f) where   arbitrary = NestedF <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary  -data NestedFW f-  = NestedFW-      { npfw_1 :: Wear f Int-      , npfw_2 :: [Record3W f]-      , npfw_3 :: Maybe (Sum3W f)-      , npfw_4 :: Maybe (NestedFW f)-      }++-----------------------------------------------------+-- 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 FunctorB NestedFW-instance TraversableB NestedFW-instance BareB NestedFW--- instance  ConstraintsB NetedFW+instance (Functor h, FunctorB b) => FunctorB (ParBH h b)+instance (Traversable h, TraversableB b) => TraversableB (ParBH h b) -deriving instance (Wear f Int ~ f Int, Show (f Int), Show (Record3W f), Show (Sum3W f)) => Show (NestedFW f)-deriving instance (Wear f Int ~ f Int, Eq   (f Int), Eq   (Record3W f), Eq   (Sum3W f)) => Eq   (NestedFW f)+data ParX a f+  = ParX (f a)+  deriving (Generic, Typeable) -instance (Wear f Int ~ f Int, Wear f Bool ~ f Bool, Wear f Char ~ f Char, Arbitrary (f Int), Arbitrary (f Bool), Arbitrary (f Char)) => Arbitrary (NestedFW f) where-  arbitrary = NestedFW <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+instance FunctorB (ParX a)+instance TraversableB (ParX a)+instance ProductB (ParX a)+instance ConstraintsB (ParX a)+instance ProductBC (ParX a)

@@ -0,0 +1,322 @@+{-# OPTIONS_GHC -O0 #-}+{-# LANGUAGE DeriveAnyClass       #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-}+module BarbiesW+  ( Record1W(..)+  , Record3W(..)++  , Record1WS(..)+  , Record3WS(..)++  , Sum3W(..)++  , CompositeRecordW(..)+  , SumRecW(..)+  , InfRecW(..)++  , NestedFW(..)+  )++where++import Data.Barbie+import Data.Barbie.Bare++import Data.Typeable+import GHC.Generics+import Test.Tasty.QuickCheck++----------------------------------------------------+-- Product Barbies+----------------------------------------------------++data Record1W t f+  = Record1W { rec1w_f1 :: Wear t f Int }+  deriving (Generic, Typeable)+++instance FunctorB (Record1W Bare)+instance FunctorB (Record1W Covered)+instance TraversableB (Record1W Covered)+instance ProductB (Record1W Covered)+instance ConstraintsB (Record1W Bare)+instance ConstraintsB (Record1W Covered)+instance ProductBC (Record1W Covered)+instance BareB Record1W+++deriving instance AllB  Show   (Record1W Bare)    => Show (Record1W Bare f)+deriving instance AllB  Eq     (Record1W Bare)    => Eq   (Record1W Bare f)+deriving instance AllBF Show f (Record1W Covered) => Show (Record1W Covered f)+deriving instance AllBF Eq   f (Record1W Covered) => Eq   (Record1W Covered f)++instance AllBF Arbitrary f (Record1W Covered) => Arbitrary (Record1W Covered f) where+  arbitrary = Record1W <$> arbitrary+++data Record1WS t f+  = Record1WS { rec1ws_f1 :: !(Wear t f Int) }+  deriving (Generic, Typeable)+++instance FunctorB (Record1WS Bare)+instance FunctorB (Record1WS Covered)+instance TraversableB (Record1WS Covered)+instance ProductB (Record1WS Covered)+instance ConstraintsB (Record1WS Bare)+instance ConstraintsB (Record1WS Covered)+instance ProductBC (Record1WS Covered)+instance BareB Record1WS+++deriving instance AllB  Show   (Record1WS Bare)    => Show (Record1WS Bare f)+deriving instance AllB  Eq     (Record1WS Bare)    => Eq   (Record1WS Bare f)+deriving instance AllBF Show f (Record1WS Covered) => Show (Record1WS Covered f)+deriving instance AllBF Eq   f (Record1WS Covered) => Eq   (Record1WS Covered f)++instance AllBF Arbitrary f (Record1WS Covered) => Arbitrary (Record1WS Covered f) where+  arbitrary = Record1WS <$> arbitrary++data Record3W t f+  = Record3W+      { rec3w_f1 :: Wear t f Int+      , rec3w_f2 :: Wear t f Bool+      , rec3w_f3 :: Wear t f Char+      }+  deriving (Generic, Typeable)+++instance FunctorB (Record3W Bare)+instance FunctorB (Record3W Covered)+instance TraversableB (Record3W Covered)+instance ProductB (Record3W Covered)+instance ConstraintsB (Record3W Bare)+instance ConstraintsB (Record3W Covered)+instance ProductBC (Record3W Covered)++instance BareB Record3W++deriving instance AllB  Show   (Record3W Bare)    => Show (Record3W Bare f)+deriving instance AllB  Eq     (Record3W Bare)    => Eq   (Record3W Bare f)+deriving instance AllBF Show f (Record3W Covered) => Show (Record3W Covered f)+deriving instance AllBF Eq   f (Record3W Covered) => Eq   (Record3W Covered f)++instance AllBF Arbitrary f (Record3W Covered) => Arbitrary (Record3W Covered f) where+  arbitrary = Record3W <$> arbitrary <*> arbitrary <*> arbitrary+++data Record3WS t f+  = Record3WS+      { rec3ws_f1 :: !(Wear t f Int)+      , rec3ws_f2 :: !(Wear t f Bool)+      , rec3ws_f3 :: !(Wear t f Char)+      }+  deriving (Generic, Typeable)+++instance FunctorB (Record3WS Bare)+instance FunctorB (Record3WS Covered)+instance TraversableB (Record3WS Covered)+instance ProductB (Record3WS Covered)+instance ConstraintsB (Record3WS Bare)+instance ConstraintsB (Record3WS Covered)+instance ProductBC (Record3WS Covered)+instance BareB Record3WS++deriving instance AllB  Show   (Record3WS Bare)    => Show (Record3WS Bare f)+deriving instance AllB  Eq     (Record3WS Bare)    => Eq   (Record3WS Bare f)+deriving instance AllBF Show f (Record3WS Covered) => Show (Record3WS Covered f)+deriving instance AllBF Eq   f (Record3WS Covered) => Eq   (Record3WS Covered f)++instance AllBF Arbitrary f (Record3WS Covered) => Arbitrary (Record3WS Covered f) where+  arbitrary = Record3WS <$> arbitrary <*> arbitrary <*> arbitrary+++----------------------------------------------------+-- Sum Barbies+----------------------------------------------------++data Sum3W t f+  = Sum3W_0+  | Sum3W_1 (Wear t f Int)+  | Sum3W_2 (Wear t f Int) (Wear t f Bool)+  deriving (Generic, Typeable)++instance FunctorB (Sum3W Bare)+instance FunctorB (Sum3W Covered)+instance TraversableB (Sum3W Covered)+instance ConstraintsB (Sum3W Bare)+instance ConstraintsB (Sum3W Covered)+instance BareB Sum3W++deriving instance AllB  Show   (Sum3W Bare)    => Show (Sum3W Bare f)+deriving instance AllB  Eq     (Sum3W Bare)    => Eq   (Sum3W Bare f)+deriving instance AllBF Show f (Sum3W Covered) => Show (Sum3W Covered f)+deriving instance AllBF Eq   f (Sum3W Covered) => Eq   (Sum3W Covered f)++instance AllBF Arbitrary f (Sum3W Covered) => Arbitrary (Sum3W Covered f) where+  arbitrary+    = oneof+        [ pure Sum3W_0+        , Sum3W_1 <$> arbitrary+        , Sum3W_2 <$> arbitrary <*> arbitrary+        ]+++-----------------------------------------------------+-- Composite and recursive+-----------------------------------------------------+++data CompositeRecordW t f+  = CompositeRecordW+      { crecw_f1 :: Wear t f Int+      , crecw_F2 :: Wear t f Bool+      , crecw_f3 :: Record3W t f+      , crecw_f4 :: Record1W t f+      }+  deriving (Generic, Typeable)++instance FunctorB (CompositeRecordW Bare)+instance FunctorB (CompositeRecordW Covered)+instance TraversableB (CompositeRecordW Covered)+instance ProductB (CompositeRecordW Covered)+instance ConstraintsB (CompositeRecordW Bare)+instance ConstraintsB (CompositeRecordW Covered)+instance ProductBC (CompositeRecordW Covered)+instance BareB CompositeRecordW++deriving instance AllB  Show   (CompositeRecordW Bare)    => Show (CompositeRecordW Bare f)+deriving instance AllB  Eq     (CompositeRecordW Bare)    => Eq   (CompositeRecordW Bare f)+deriving instance AllBF Show f (CompositeRecordW Covered) => Show (CompositeRecordW Covered f)+deriving instance AllBF Eq   f (CompositeRecordW Covered) => Eq   (CompositeRecordW Covered f)++instance AllBF Arbitrary f (CompositeRecordW Covered) => Arbitrary (CompositeRecordW Covered f) where+  arbitrary+    = CompositeRecordW <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+++data SumRecW t f+  = SumRecW_0+  | SumRecW_1 (Wear t f Int)+  | SumRecW_2 (Wear t f Int) (SumRecW t f)+  deriving (Generic, Typeable)++instance FunctorB (SumRecW Bare)+instance FunctorB (SumRecW Covered)+instance TraversableB (SumRecW Covered)+instance ConstraintsB (SumRecW Bare)+instance ConstraintsB (SumRecW Covered)+instance BareB SumRecW++deriving instance AllB  Show   (SumRecW Bare)    => Show (SumRecW Bare f)+deriving instance AllB  Eq     (SumRecW Bare)    => Eq   (SumRecW Bare f)+deriving instance AllBF Show f (SumRecW Covered) => Show (SumRecW Covered f)+deriving instance AllBF Eq   f (SumRecW Covered) => Eq   (SumRecW Covered f)++instance AllBF Arbitrary f (SumRecW Covered) => Arbitrary (SumRecW Covered f) where+  arbitrary+    = oneof+        [ pure SumRecW_0+        , SumRecW_1 <$> arbitrary+        , SumRecW_2 <$> arbitrary <*> arbitrary+        ]++data InfRecW t f+  = InfRecW { irw_1 :: Wear t f Int, irw_2 :: InfRecW t f }+  deriving (Generic, Typeable)+++instance FunctorB (InfRecW Bare)+instance FunctorB (InfRecW Covered)+instance TraversableB (InfRecW Covered)+instance ProductB (InfRecW Covered)+instance ConstraintsB (InfRecW Bare)+instance ConstraintsB (InfRecW Covered)+instance ProductBC (InfRecW Covered)+instance BareB InfRecW++deriving instance AllB  Show   (InfRecW Bare)    => Show (InfRecW Bare f)+deriving instance AllB  Eq     (InfRecW Bare)    => Eq   (InfRecW Bare f)+deriving instance AllBF Show f (InfRecW Covered) => Show (InfRecW Covered f)+deriving instance AllBF Eq   f (InfRecW Covered) => Eq   (InfRecW Covered f)++-----------------------------------------------------+-- Nested under functors+-----------------------------------------------------++data NestedFW t f+  = NestedFW+      { npfw_1 :: Wear t f Int+      , npfw_2 :: [Record3W t f]+      , npfw_3 :: Maybe (Sum3W t f)+      , npfw_4 :: Maybe (NestedFW t f)+      }+  deriving (Generic, Typeable)++++instance FunctorB (NestedFW Bare)+instance FunctorB (NestedFW Covered)+instance TraversableB (NestedFW Covered)+instance BareB NestedFW+-- instance ConstraintsB (NestedFW Bare)+-- instance ConstraintsB (NestedFW Covered)++deriving instance Show (NestedFW Bare f)+deriving instance Eq   (NestedFW Bare f)+deriving instance (Show (f Int), Show (Record3W Covered f), Show (Sum3W Covered f)) => Show (NestedFW Covered f)+deriving instance (Eq   (f Int), Eq   (Record3W Covered f), Eq   (Sum3W Covered f)) => Eq   (NestedFW Covered f)++instance (Arbitrary (f Int), Arbitrary (f Bool), Arbitrary (f Char)) => Arbitrary (NestedFW Covered f) where+  arbitrary = NestedFW <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+++-----------------------------------------------------+-- Parametric barbies+-----------------------------------------------------++data ParBW b t (f :: * -> *)+  = ParBW (b t f)+  deriving (Generic, Typeable)++instance FunctorB (b t) => FunctorB (ParBW b t)+instance TraversableB (b t) => TraversableB (ParBW b t)+instance ProductB (b t) => ProductB (ParBW b t)+instance BareB b => BareB (ParBW b)++-- XXX GHC currently rejects deriving this one since it+-- gets stuck on the TagSelf type family and can't see this+-- is an "Other" case. It looks like a bug to me, since it+-- seems to have enough information to decide that it is the+-- `Other` case that should be picked (or in any case, I don't+-- quite see why this is not an issue when `b` doesn't have the+-- extra type parameter.+instance ConstraintsB (b t) => ConstraintsB (ParBW b t) where+  type AllB c (ParBW b t) = AllB c (b t)+  baddDicts (ParBW btf) = ParBW (baddDicts btf)++-- XXX SEE NOTE ON ConstraintsB+instance ProductBC (b t) => ProductBC (ParBW b t) where+  bdicts = ParBW bdicts++data ParBHW h b t (f :: * -> *)+  = ParBHW (h (b t f))+  deriving (Generic, Typeable)++instance (Functor h, FunctorB (b t)) => FunctorB (ParBHW h b t)+instance (Traversable h, TraversableB (b t)) => TraversableB (ParBHW h b t)+instance (Functor h, BareB b) => BareB (ParBHW h b)++data ParXW a t f+  = ParXW (Wear t f a)+  deriving (Generic, Typeable)++instance FunctorB (ParXW a Bare)+instance FunctorB (ParXW a Covered)+instance TraversableB (ParXW a Covered)+instance ProductB (ParXW a Covered)+instance ConstraintsB (ParXW a Covered)+instance ProductBC (ParXW a Covered)

@@ -1,7 +1,4 @@-{-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase                 #-}-{-# LANGUAGE Rank2Types                 #-} module Clothes  where

@@ -1,5 +1,5 @@-{-# LANGUAGE TypeApplications    #-} import Test.Tasty (defaultMain, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))  import qualified Spec.Bare as Bare import qualified Spec.Constraints as Constraints@@ -8,9 +8,13 @@ import qualified Spec.Traversable as Traversable import qualified Spec.Wrapper as Wrapper - import Barbies+import BarbiesW +import Data.Barbie (bfoldMap)+import Data.Barbie.Bare(Covered)+import Data.Functor.Const(Const(..))+ main :: IO () main   = defaultMain $@@ -23,24 +27,24 @@             , Functor.laws @Record1S             , Functor.laws @Record3S -            , Functor.laws @Record1W-            , Functor.laws @Record3W+            , Functor.laws @(Record1W Covered)+            , Functor.laws @(Record3W Covered) -            , Functor.laws @Record1WS-            , Functor.laws @Record3WS+            , Functor.laws @(Record1WS Covered)+            , Functor.laws @(Record3WS Covered)              , Functor.laws @Ignore1              , Functor.laws @Sum3             , Functor.laws @SumRec -            , Functor.laws @Sum3W-            , Functor.laws @SumRecW+            , Functor.laws @(Sum3W Covered)+            , Functor.laws @(SumRecW Covered)              , Functor.laws @CompositeRecord             , Functor.laws @NestedF -            , Functor.laws @CompositeRecordW+            , Functor.laws @(CompositeRecordW Covered)             ]          , testGroup "Traversable Laws"@@ -51,24 +55,24 @@             , Traversable.laws @Record1S             , Traversable.laws @Record3S -            , Traversable.laws @Record1W-            , Traversable.laws @Record3W+            , Traversable.laws @(Record1W Covered)+            , Traversable.laws @(Record3W Covered) -            , Traversable.laws @Record1WS-            , Traversable.laws @Record3WS+            , Traversable.laws @(Record1WS Covered)+            , Traversable.laws @(Record3WS Covered)              , Traversable.laws @Ignore1              , Traversable.laws @Sum3             , Traversable.laws @SumRec -            , Traversable.laws @Sum3W-            , Traversable.laws @SumRecW+            , Traversable.laws @(Sum3W Covered)+            , Traversable.laws @(SumRecW Covered)              , Traversable.laws @CompositeRecord             , Traversable.laws @NestedF -            , Traversable.laws @CompositeRecordW+            , Traversable.laws @(CompositeRecordW Covered)             ]          , testGroup "Product Laws"@@ -80,12 +84,12 @@             , Product.laws @Record1S             , Product.laws @Record3S -            , Product.laws @Record1W-            , Product.laws @Record3W-            , Product.laws @CompositeRecordW+            , Product.laws @(Record1W Covered)+            , Product.laws @(Record3W Covered)+            , Product.laws @(CompositeRecordW Covered) -            , Product.laws @Record1WS-            , Product.laws @Record3WS+            , Product.laws @(Record1WS Covered)+            , Product.laws @(Record3WS Covered)             ]          , testGroup "Uniq Laws"@@ -97,55 +101,55 @@             , Product.uniqLaws @Record1S             , Product.uniqLaws @Record3S -            , Product.uniqLaws @Record1W-            , Product.uniqLaws @Record3W-            , Product.uniqLaws @CompositeRecordW+            , Product.uniqLaws @(Record1W Covered)+            , Product.uniqLaws @(Record3W Covered)+            , Product.uniqLaws @(CompositeRecordW Covered) -            , Product.uniqLaws @Record1WS-            , Product.uniqLaws @Record3WS+            , Product.uniqLaws @(Record1WS Covered)+            , Product.uniqLaws @(Record3WS Covered)             ] -        , testGroup "adjProof projection"-            [ Constraints.lawAdjProofPrj @Record0-            , Constraints.lawAdjProofPrj @Record1-            , Constraints.lawAdjProofPrj @Record3+        , testGroup "adDict projection"+            [ Constraints.lawAddDictPrj @Record0+            , Constraints.lawAddDictPrj @Record1+            , Constraints.lawAddDictPrj @Record3 -            , Constraints.lawAdjProofPrj @Record1S-            , Constraints.lawAdjProofPrj @Record3S+            , Constraints.lawAddDictPrj @Record1S+            , Constraints.lawAddDictPrj @Record3S -            , Constraints.lawAdjProofPrj @Record1W-            , Constraints.lawAdjProofPrj @Record3W+            , Constraints.lawAddDictPrj @(Record1W Covered)+            , Constraints.lawAddDictPrj @(Record3W Covered) -            , Constraints.lawAdjProofPrj @Record1WS-            , Constraints.lawAdjProofPrj @Record3WS+            , Constraints.lawAddDictPrj @(Record1WS Covered)+            , Constraints.lawAddDictPrj @(Record3WS Covered) -            , Constraints.lawAdjProofPrj @Ignore1+            , Constraints.lawAddDictPrj @Ignore1 -            , Constraints.lawAdjProofPrj @Sum3-            , Constraints.lawAdjProofPrj @SumRec+            , Constraints.lawAddDictPrj @Sum3+            , Constraints.lawAddDictPrj @SumRec -            , Constraints.lawAdjProofPrj @Sum3W-            , Constraints.lawAdjProofPrj @SumRecW+            , Constraints.lawAddDictPrj @(Sum3W Covered)+            , Constraints.lawAddDictPrj @(SumRecW Covered) -            , Constraints.lawAdjProofPrj @CompositeRecord-            , Constraints.lawAdjProofPrj @CompositeRecordW+            , Constraints.lawAddDictPrj @CompositeRecord+            , Constraints.lawAddDictPrj @(CompositeRecordW Covered)             ] -        , testGroup "bproof projection"-            [ Constraints.lawProofEquivPrj @Record0-            , Constraints.lawProofEquivPrj @Record1-            , Constraints.lawProofEquivPrj @Record3-            , Constraints.lawProofEquivPrj @CompositeRecord+        , testGroup "bdicts projection"+            [ Constraints.lawDictsEquivPrj @Record0+            , Constraints.lawDictsEquivPrj @Record1+            , Constraints.lawDictsEquivPrj @Record3+            , Constraints.lawDictsEquivPrj @CompositeRecord -            , Constraints.lawProofEquivPrj @Record1S-            , Constraints.lawProofEquivPrj @Record3S+            , Constraints.lawDictsEquivPrj @Record1S+            , Constraints.lawDictsEquivPrj @Record3S -            , Constraints.lawProofEquivPrj @Record1W-            , Constraints.lawProofEquivPrj @Record3W-            , Constraints.lawProofEquivPrj @CompositeRecordW+            , Constraints.lawDictsEquivPrj @(Record1W Covered)+            , Constraints.lawDictsEquivPrj @(Record3W Covered)+            , Constraints.lawDictsEquivPrj @(CompositeRecordW Covered) -            , Constraints.lawProofEquivPrj @Record1WS-            , Constraints.lawProofEquivPrj @Record3WS+            , Constraints.lawDictsEquivPrj @(Record1WS Covered)+            , Constraints.lawDictsEquivPrj @(Record3WS Covered)             ]          , testGroup "Bare laws"@@ -160,15 +164,21 @@          , testGroup "Generic wrapper"             [ Wrapper.lawsMonoid @Record1-            , Wrapper.lawsMonoid @Record1W+            , Wrapper.lawsMonoid @(Record1W Covered)              , Wrapper.lawsMonoid @Record1S-            , Wrapper.lawsMonoid @Record1WS+            , Wrapper.lawsMonoid @(Record1WS Covered)              , Wrapper.lawsMonoid @Record3-            , Wrapper.lawsMonoid @Record3W+            , Wrapper.lawsMonoid @(Record3W Covered)              , Wrapper.lawsMonoid @Record3S-            , Wrapper.lawsMonoid @Record3WS+            , Wrapper.lawsMonoid @(Record3WS Covered)+            ]++        , testGroup "bfoldMap"+            [ testCase "Record3" $ do+                let b = Record3 (Const "tic") (Const "tac") (Const "toe")+                bfoldMap getConst b @?= "tictactoe"             ]         ]

@@ -1,10 +1,9 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE ScopedTypeVariables #-} module Spec.Bare ( laws )  where -import Data.Barbie (BareB(..))+import Data.Barbie.Bare (BareB(..), Covered) import Data.Functor.Identity  import Data.Typeable (Typeable, typeRep, Proxy(..))@@ -15,15 +14,15 @@ laws   :: forall b   . ( BareB b-    , Eq (b Identity) , Show (b Identity) , Arbitrary (b Identity)-    -- , Show (b Bare), Eq (b Bare), Arbitrary (b Bare)+    , 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 Identity)+          bcover (bstrip b) === (b :: b Covered Identity)        -- TODO: FIXME       -- , testProperty "bstrip . bcover = id" $ \b ->

@@ -1,15 +1,14 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE ScopedTypeVariables #-} module Spec.Constraints-  ( lawAdjProofPrj-  , lawProofEquivPrj+  ( lawAddDictPrj+  , lawDictsEquivPrj   )  where  import Clothes(F)-import Data.Barbie(bmap, ConstraintsB(..), ProofB(..))-import Data.Barbie.Constraints(DictOf)+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)@@ -18,33 +17,33 @@ import Test.Tasty.QuickCheck(Arbitrary(..), testProperty, (===))  -lawAdjProofPrj+lawAddDictPrj   :: forall b-  . ( ConstraintsB b, ConstraintsOf Show F b+  . ( ConstraintsB b, AllBF Show F b     , Eq (b F)     , Show (b F)     , Arbitrary (b F)     , Typeable b     )   => TestTree-lawAdjProofPrj+lawAddDictPrj   = testProperty (show (typeRep (Proxy :: Proxy b))) $ \b ->-      bmap second (adjProof b :: b (Product (DictOf Show F) F)) === b+      bmap second (baddDicts b :: b (Dict (ClassF Show F) `Product` F)) === b   where     second (Pair _ b) = b  -lawProofEquivPrj+lawDictsEquivPrj   :: forall b-  . ( ProofB b, ConstraintsOf Show F b-    , Eq (b (DictOf Show F))-    , Show (b F), Show (b (DictOf Show F))+  . ( 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-lawProofEquivPrj+lawDictsEquivPrj   = testProperty (show (typeRep (Proxy :: Proxy b))) $ \b ->-      bmap first (adjProof b :: b (Product (DictOf Show F) F)) === bproof+      bmap first (baddDicts b :: b (Dict (ClassF Show F) `Product` F)) === bdicts   where     first (Pair a _) = a

@@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE ScopedTypeVariables #-} module Spec.Functor ( laws )  where

@@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE ScopedTypeVariables #-} module Spec.Product ( laws, uniqLaws )  where

@@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE ScopedTypeVariables #-} module Spec.Traversable ( laws )  where

@@ -1,13 +1,12 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE ScopedTypeVariables #-} module Spec.Wrapper (     lawsMonoid   )  where -import Data.Barbie (Barbie(..), ConstraintsOf, ProofB)+import Data.Barbie (AllBF, Barbie(..), ProductBC)  import Data.Semigroup (Semigroup, (<>)) @@ -17,9 +16,9 @@ lawsMonoid   :: forall b   .  ( Arbitrary (b []), Eq (b []), Show (b [])-     , ProofB b-     , ConstraintsOf Semigroup [] b-     , ConstraintsOf Monoid [] b+     , ProductBC b+     , AllBF Semigroup [] b+     , AllBF Monoid [] b      )   => TestTree lawsMonoid