diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/barbies.cabal b/barbies.cabal --- a/barbies.cabal +++ b/barbies.cabal @@ -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 diff --git a/src/Data/Barbie.hs b/src/Data/Barbie.hs --- a/src/Data/Barbie.hs +++ b/src/Data/Barbie.hs @@ -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(..)) diff --git a/src/Data/Barbie/Bare.hs b/src/Data/Barbie/Bare.hs new file mode 100644 --- /dev/null +++ b/src/Data/Barbie/Bare.hs @@ -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 + ) diff --git a/src/Data/Barbie/Constraints.hs b/src/Data/Barbie/Constraints.hs --- a/src/Data/Barbie/Constraints.hs +++ b/src/Data/Barbie/Constraints.hs @@ -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 diff --git a/src/Data/Barbie/Container.hs b/src/Data/Barbie/Container.hs --- a/src/Data/Barbie/Container.hs +++ b/src/Data/Barbie/Container.hs @@ -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) diff --git a/src/Data/Barbie/Internal.hs b/src/Data/Barbie/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Barbie/Internal.hs @@ -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) diff --git a/src/Data/Barbie/Internal/Bare.hs b/src/Data/Barbie/Internal/Bare.hs --- a/src/Data/Barbie/Internal/Bare.hs +++ b/src/Data/Barbie/Internal/Bare.hs @@ -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 diff --git a/src/Data/Barbie/Internal/Classification.hs b/src/Data/Barbie/Internal/Classification.hs deleted file mode 100644 --- a/src/Data/Barbie/Internal/Classification.hs +++ /dev/null @@ -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))) diff --git a/src/Data/Barbie/Internal/Constraints.hs b/src/Data/Barbie/Internal/Constraints.hs --- a/src/Data/Barbie/Internal/Constraints.hs +++ b/src/Data/Barbie/Internal/Constraints.hs @@ -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 diff --git a/src/Data/Barbie/Internal/Dicts.hs b/src/Data/Barbie/Internal/Dicts.hs --- a/src/Data/Barbie/Internal/Dicts.hs +++ b/src/Data/Barbie/Internal/Dicts.hs @@ -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 +-- 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 diff --git a/src/Data/Barbie/Internal/Functor.hs b/src/Data/Barbie/Internal/Functor.hs --- a/src/Data/Barbie/Internal/Functor.hs +++ b/src/Data/Barbie/Internal/Functor.hs @@ -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 diff --git a/src/Data/Barbie/Internal/Generics.hs b/src/Data/Barbie/Internal/Generics.hs deleted file mode 100644 --- a/src/Data/Barbie/Internal/Generics.hs +++ /dev/null @@ -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 diff --git a/src/Data/Barbie/Internal/Instances.hs b/src/Data/Barbie/Internal/Instances.hs --- a/src/Data/Barbie/Internal/Instances.hs +++ b/src/Data/Barbie/Internal/Instances.hs @@ -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 = (<>) diff --git a/src/Data/Barbie/Internal/Product.hs b/src/Data/Barbie/Internal/Product.hs --- a/src/Data/Barbie/Internal/Product.hs +++ b/src/Data/Barbie/Internal/Product.hs @@ -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)) diff --git a/src/Data/Barbie/Internal/ProductC.hs b/src/Data/Barbie/Internal/ProductC.hs new file mode 100644 --- /dev/null +++ b/src/Data/Barbie/Internal/ProductC.hs @@ -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' diff --git a/src/Data/Barbie/Internal/ProofB.hs b/src/Data/Barbie/Internal/ProofB.hs deleted file mode 100644 --- a/src/Data/Barbie/Internal/ProofB.hs +++ /dev/null @@ -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 diff --git a/src/Data/Barbie/Internal/Tags.hs b/src/Data/Barbie/Internal/Tags.hs deleted file mode 100644 --- a/src/Data/Barbie/Internal/Tags.hs +++ /dev/null @@ -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 diff --git a/src/Data/Barbie/Internal/Traversable.hs b/src/Data/Barbie/Internal/Traversable.hs --- a/src/Data/Barbie/Internal/Traversable.hs +++ b/src/Data/Barbie/Internal/Traversable.hs @@ -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)) diff --git a/src/Data/Barbie/Internal/Wear.hs b/src/Data/Barbie/Internal/Wear.hs --- a/src/Data/Barbie/Internal/Wear.hs +++ b/src/Data/Barbie/Internal/Wear.hs @@ -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 diff --git a/src/Data/Barbie/Trivial.hs b/src/Data/Barbie/Trivial.hs --- a/src/Data/Barbie/Trivial.hs +++ b/src/Data/Barbie/Trivial.hs @@ -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 diff --git a/src/Data/Functor/Prod.hs b/src/Data/Functor/Prod.hs --- a/src/Data/Functor/Prod.hs +++ b/src/Data/Functor/Prod.hs @@ -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) diff --git a/src/Data/Generics/GenericN.hs b/src/Data/Generics/GenericN.hs new file mode 100644 --- /dev/null +++ b/src/Data/Generics/GenericN.hs @@ -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) diff --git a/test/Barbies.hs b/test/Barbies.hs --- a/test/Barbies.hs +++ b/test/Barbies.hs @@ -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) diff --git a/test/BarbiesW.hs b/test/BarbiesW.hs new file mode 100644 --- /dev/null +++ b/test/BarbiesW.hs @@ -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) diff --git a/test/Clothes.hs b/test/Clothes.hs --- a/test/Clothes.hs +++ b/test/Clothes.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE Rank2Types #-} module Clothes where diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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" ] ] diff --git a/test/Spec/Bare.hs b/test/Spec/Bare.hs --- a/test/Spec/Bare.hs +++ b/test/Spec/Bare.hs @@ -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 -> diff --git a/test/Spec/Constraints.hs b/test/Spec/Constraints.hs --- a/test/Spec/Constraints.hs +++ b/test/Spec/Constraints.hs @@ -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 diff --git a/test/Spec/Functor.hs b/test/Spec/Functor.hs --- a/test/Spec/Functor.hs +++ b/test/Spec/Functor.hs @@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} module Spec.Functor ( laws ) where diff --git a/test/Spec/Product.hs b/test/Spec/Product.hs --- a/test/Spec/Product.hs +++ b/test/Spec/Product.hs @@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} module Spec.Product ( laws, uniqLaws ) where diff --git a/test/Spec/Traversable.hs b/test/Spec/Traversable.hs --- a/test/Spec/Traversable.hs +++ b/test/Spec/Traversable.hs @@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} module Spec.Traversable ( laws ) where diff --git a/test/Spec/Wrapper.hs b/test/Spec/Wrapper.hs --- a/test/Spec/Wrapper.hs +++ b/test/Spec/Wrapper.hs @@ -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