Hello community, here is the log from the commit of package ghc-generics-sop for openSUSE:Factory checked in at 2017-08-31 20:50:51 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-generics-sop (Old) and /work/SRC/openSUSE:Factory/.ghc-generics-sop.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-generics-sop" Thu Aug 31 20:50:51 2017 rev:9 rq:513247 version:0.3.1.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-generics-sop/ghc-generics-sop.changes 2017-06-04 01:53:23.878714201 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-generics-sop.new/ghc-generics-sop.changes 2017-08-31 20:50:51.890601144 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:08:14 UTC 2017 - psimons@suse.com + +- Update to version 0.3.1.0. + +------------------------------------------------------------------- Old: ---- generics-sop-0.2.5.0.tar.gz New: ---- generics-sop-0.3.1.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-generics-sop.spec ++++++ --- /var/tmp/diff_new_pack.aplvdM/_old 2017-08-31 20:50:53.082433845 +0200 +++ /var/tmp/diff_new_pack.aplvdM/_new 2017-08-31 20:50:53.090432723 +0200 @@ -18,7 +18,7 @@ %global pkg_name generics-sop Name: ghc-%{pkg_name} -Version: 0.2.5.0 +Version: 0.3.1.0 Release: 0 Summary: Generic Programming using True Sums of Products License: BSD-3-Clause ++++++ generics-sop-0.2.5.0.tar.gz -> generics-sop-0.3.1.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/generics-sop-0.2.5.0/CHANGELOG.md new/generics-sop-0.3.1.0/CHANGELOG.md --- old/generics-sop-0.2.5.0/CHANGELOG.md 2017-04-21 15:30:39.000000000 +0200 +++ new/generics-sop-0.3.1.0/CHANGELOG.md 2017-06-11 15:25:51.000000000 +0200 @@ -1,3 +1,54 @@ +# 0.3.1.0 (2017-06-11) + +* Add AllZip, htrans, hcoerce, hfromI, htoI. + These functions are for converting between related + structures that do not have common signatures. + + The most common application of these functions seems + to be the scenario where a datatype has components + that are all wrapped in a common type constructor + application, e.g. a datatype where every component + is a `Maybe`. Then we can use `hfromI` after `from` + to turn the generically derived `SOP` of `I`s into + an `SOP` of `Maybe`s (and back). + +* Add `IsProductType`, `IsEnumType`, `IsWrappedType` + and `IsNewtype` constraint synonyms capturing + specific classes of datypes. + +# 0.3.0.0 (2017-04-29) + +* No longer compatible with GHC 7.6, due to the lack of + support for type-level literals. + +* Support type-level metadata. This is provided by the + `Generics.SOP.Type.Metadata` module. The two modules + `Generics.SOP.Metadata` and `Generics.SOP.Type.Metadata` + export nearly the same names, so for backwards compatibility, + we keep exporting `Generics.SOP.Metadata` directly from + `Generics.SOP`, whereas `Generics.SOP.Type.Metadata` is + supposed to be imported explicitly (and qualified). + + Term-level metadata is still available, but is now usually + computed automatically from the type-level metadata which + contains the same information, using the function + `demoteDatatypeInfo`. Term-level metadata is unchanged + from generics-sop-0.2, so in most cases, even if your + code makes use of metadata, you should not need to change + anything. + + If you use TH deriving, then both type-level metadata and + term-level metadata is generated for you automatically, + for all supported GHC versions. + + If you use GGP deriving, then type-level metadata is + available if you use GHC 8.0 or newer. If you use GHC 7.x, + then GHC.Generics supports only term-level metadata, so + we cannot translate that into type-level metadata. In + this combination, you cannot use code that relies on + type-level metadata, so you should either upgrade GHC or + switch to TH-based deriving. + # 0.2.5.0 (2017-04-21) * GHC 8.2 compatibility. @@ -79,8 +130,8 @@ hcliftA' p = hcliftA (allP p) where - allP :: proxy c -> Proxy (All c) - allP _ = Proxy + allP :: proxy c -> Proxy (All c) + allP _ = Proxy * Because `All` and `All2` are now type classes, they now have superclass constraints implying that the type-level lists they @@ -99,7 +150,7 @@ For one-dimensional type-level lists, replace - SingI xs => ... + SingI xs => ... by diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/generics-sop-0.2.5.0/generics-sop.cabal new/generics-sop-0.3.1.0/generics-sop.cabal --- old/generics-sop-0.2.5.0/generics-sop.cabal 2017-04-21 15:30:39.000000000 +0200 +++ new/generics-sop-0.3.1.0/generics-sop.cabal 2017-06-11 15:25:51.000000000 +0200 @@ -1,5 +1,5 @@ name: generics-sop -version: 0.2.5.0 +version: 0.3.1.0 synopsis: Generic Programming using True Sums of Products description: A library to support the definition of generic functions. @@ -37,7 +37,7 @@ build-type: Simple cabal-version: >=1.10 extra-source-files: CHANGELOG.md -tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1, GHC == 8.0.2, GHC == 8.1.* +tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1, GHC == 8.0.2, GHC == 8.1.* source-repository head type: git @@ -48,6 +48,7 @@ Generics.SOP.GGP Generics.SOP.TH Generics.SOP.Dict + Generics.SOP.Type.Metadata -- exposed via Generics.SOP: Generics.SOP.BasicFunctors Generics.SOP.Classes @@ -58,7 +59,7 @@ Generics.SOP.NS Generics.SOP.Universe Generics.SOP.Sing - build-depends: base >= 4.6 && < 5, + build-depends: base >= 4.7 && < 5, template-haskell >= 2.8 && < 2.13, ghc-prim >= 0.3 && < 0.6, deepseq >= 1.3 && < 1.5 @@ -100,9 +101,10 @@ if impl (ghc < 7.10) other-extensions: OverlappingInstances -test-suite generic-sop-examples +test-suite generics-sop-examples type: exitcode-stdio-1.0 main-is: Example.hs + other-modules: HTransExample hs-source-dirs: test default-language: Haskell2010 ghc-options: -Wall diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/generics-sop-0.2.5.0/src/Generics/SOP/Classes.hs new/generics-sop-0.3.1.0/src/Generics/SOP/Classes.hs --- old/generics-sop-0.2.5.0/src/Generics/SOP/Classes.hs 2017-04-21 15:30:39.000000000 +0200 +++ new/generics-sop-0.3.1.0/src/Generics/SOP/Classes.hs 2017-06-11 15:25:51.000000000 +0200 @@ -39,6 +39,7 @@ , fn_2 , fn_3 , fn_4 + , Same , Prod , HAp(..) -- ** Derived functions @@ -69,6 +70,10 @@ , HApInjs(..) -- * Expanding sums to products , HExpand(..) + -- * Transformation of index lists and coercions + , HTrans(..) + , hfromI + , htoI ) where #if !(MIN_VERSION_base(4,8,0)) @@ -147,6 +152,9 @@ fn_3 f = Fn $ \x -> Fn $ \x' -> Fn $ \x'' -> f x x' x'' fn_4 f = Fn $ \x -> Fn $ \x' -> Fn $ \x'' -> Fn $ \x''' -> f x x' x'' x''' +-- | Maps a structure to the same structure. +type family Same (h :: (k1 -> *) -> (l1 -> *)) :: (k2 -> *) -> (l2 -> *) + -- | Maps a structure containing sums to the corresponding -- product structure. type family Prod (h :: (k -> *) -> (l -> *)) :: (k -> *) -> (l -> *) @@ -519,5 +527,56 @@ -- hcexpand :: (AllN (Prod h) c xs) => proxy c -> (forall x . c x => f x) -> h f xs -> Prod h f xs +-- | A class for transforming structures into related structures with +-- a different index list, as long as the index lists have the same shape +-- and the elements and interpretation functions are suitably related. +-- +-- @since 0.3.1.0 +-- +class (Same h1 ~ h2, Same h2 ~ h1) => HTrans (h1 :: (k1 -> *) -> (l1 -> *)) (h2 :: (k2 -> *) -> (l2 -> *)) where + + -- | Transform a structure into a related structure given a conversion + -- function for the elements. + -- + -- @since 0.3.1.0 + -- + htrans :: + AllZipN (Prod h1) c xs ys + => proxy c + -> (forall x y . c x y => f x -> g y) + -> h1 f xs -> h2 g ys + + -- | Coerce a structure into a representationally equal structure. + -- + -- /Examples:/ + -- + -- >>> hcoerce (I (Just LT) :* I (Just 'x') :* I (Just True) :* Nil) :: NP Maybe '[Ordering, Char, Bool] + -- Just LT :* (Just 'x' :* (Just True :* Nil)) + -- >>> hcoerce (SOP (Z (K True :* K False :* Nil))) :: SOP I '[ '[Bool, Bool], '[Bool] ] + -- SOP (Z (I True :* (I False :* Nil))) + -- + -- @since 0.3.1.0 + hcoerce :: + (AllZipN (Prod h1) (LiftedCoercible f g) xs ys, HTrans h1 h2) + => h1 f xs -> h2 g ys + +-- | Specialization of 'hcoerce'. +-- +-- @since 0.3.1.0 +-- +hfromI :: + (AllZipN (Prod h1) (LiftedCoercible I f) xs ys, HTrans h1 h2) + => h1 I xs -> h2 f ys +hfromI = hcoerce + +-- | Specialization of 'hcoerce'. +-- +-- @since 0.3.1.0 +-- +htoI :: + (AllZipN (Prod h1) (LiftedCoercible f I) xs ys, HTrans h1 h2) + => h1 f xs -> h2 I ys +htoI = hcoerce + -- $setup -- >>> import Generics.SOP diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/generics-sop-0.2.5.0/src/Generics/SOP/Constraint.hs new/generics-sop-0.3.1.0/src/Generics/SOP/Constraint.hs --- old/generics-sop-0.2.5.0/src/Generics/SOP/Constraint.hs 2017-04-21 15:30:39.000000000 +0200 +++ new/generics-sop-0.3.1.0/src/Generics/SOP/Constraint.hs 2017-06-11 15:25:51.000000000 +0200 @@ -17,7 +17,9 @@ , Constraint ) where +import Data.Coerce import GHC.Exts (Constraint) + import Generics.SOP.Sing -- | Require a constraint for every element of a list. @@ -46,9 +48,10 @@ -- | Type family used to implement 'All'. -- -type family AllF (c :: k -> Constraint) (xs :: [k]) :: Constraint -type instance AllF _c '[] = () -type instance AllF c (x ': xs) = (c x, All c xs) +type family + AllF (c :: k -> Constraint) (xs :: [k]) :: Constraint where + AllF _c '[] = () + AllF c (x ': xs) = (c x, All c xs) -- | Require a singleton for every inner list in a list of lists. type SListI2 = All SListI @@ -87,6 +90,83 @@ -- it triggers GHC's superclass cycle check when used in a -- class context. +-- | Require a constraint for pointwise for every pair of +-- elements from two lists. +-- +-- /Example:/ The constraint +-- +-- > All (~) '[ Int, Bool, Char ] '[ a, b, c ] +-- +-- is equivalent to the constraint +-- +-- > (Int ~ a, Bool ~ b, Char ~ c) +-- +-- @since 0.3.1.0 +-- +class + ( SListI xs, SListI ys + , SameShapeAs xs ys, SameShapeAs ys xs + , AllZipF c xs ys + ) => AllZip (c :: a -> b -> Constraint) (xs :: [a]) (ys :: [b]) +instance + ( SListI xs, SListI ys + , SameShapeAs xs ys, SameShapeAs ys xs + , AllZipF c xs ys + ) => AllZip c xs ys + +-- | Type family used to implement 'AllZip'. +-- +-- @since 0.3.1.0 +-- +type family + AllZipF (c :: a -> b -> Constraint) (xs :: [a]) (ys :: [b]) + :: Constraint where + AllZipF _c '[] '[] = () + AllZipF c (x ': xs) (y ': ys) = (c x y, AllZip c xs ys) + +-- | Type family that forces a type-level list to be of the same +-- shape as the given type-level list. +-- +-- The main use of this constraint is to help type inference to +-- learn something about otherwise unknown type-level lists. +-- +-- @since 0.3.1.0 +-- +type family + SameShapeAs (xs :: [a]) (ys :: [b]) :: Constraint where + SameShapeAs '[] ys = (ys ~ '[]) + SameShapeAs (x ': xs) ys = + (ys ~ (Head ys ': Tail ys), SameShapeAs xs (Tail ys)) + +-- | Utility function to compute the head of a type-level list. +-- +-- @since 0.3.1.0 +-- +type family Head (xs :: [a]) :: a where + Head (x ': xs) = x + +-- | Utility function to compute the tail of a type-level list. +-- +-- @since 0.3.1.0 +-- +type family Tail (xs :: [a]) :: [a] where + Tail (x ': xs) = xs + +-- | The constraint @LiftedCoercible f g x y@ is equivalent +-- to @Coercible (f x) (g y)@. +-- +-- @since 0.3.1.0 +-- +class Coercible (f x) (g y) => LiftedCoercible f g x y +instance Coercible (f x) (g y) => LiftedCoercible f g x y + +-- | Require a constraint for pointwise for every pair of +-- elements from two lists of lists. +-- +-- +class (AllZipF (AllZip f) xss yss, SListI xss, SListI yss, SameShapeAs xss yss, SameShapeAs yss xss) => AllZip2 f xss yss +instance (AllZipF (AllZip f) xss yss, SListI xss, SListI yss, SameShapeAs xss yss, SameShapeAs yss xss) => AllZip2 f xss yss + -- | Composition of constraints. -- -- Note that the result of the composition must be a constraint, @@ -126,6 +206,13 @@ -- type family AllN (h :: (k -> *) -> (l -> *)) (c :: k -> Constraint) :: l -> Constraint +-- | A generalization of 'AllZip' and 'AllZip2'. +-- +-- The family 'AllZipN' expands to 'AllZip' or 'AllZip2' depending on +-- whther the argument is indexed by a list or a list of lists. +-- +type family AllZipN (h :: (k -> *) -> (l -> *)) (c :: k1 -> k2 -> Constraint) :: l1 -> l2 -> Constraint + -- | A generalization of 'SListI'. -- -- The family 'SListIN' expands to 'SListI' or 'SListI2' depending diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/generics-sop-0.2.5.0/src/Generics/SOP/GGP.hs new/generics-sop-0.3.1.0/src/Generics/SOP/GGP.hs --- old/generics-sop-0.2.5.0/src/Generics/SOP/GGP.hs 2017-04-21 15:30:39.000000000 +0200 +++ new/generics-sop-0.3.1.0/src/Generics/SOP/GGP.hs 2017-06-11 15:25:51.000000000 +0200 @@ -1,4 +1,7 @@ -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PolyKinds, UndecidableInstances #-} +#if __GLASGOW_HASKELL__ >= 780 +{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} +#endif -- | Derive @generics-sop@ boilerplate instances from GHC's 'GHC.Generic'. -- -- The technique being used here is described in the following paper: @@ -12,6 +15,9 @@ , GFrom , GTo , GDatatypeInfo +#if MIN_VERSION_base(4,9,0) + , GDatatypeInfoOf +#endif , gfrom , gto , gdatatypeInfo @@ -22,9 +28,16 @@ import Generics.SOP.NP as SOP import Generics.SOP.NS as SOP import Generics.SOP.BasicFunctors as SOP +#if !(MIN_VERSION_base(4,9,0)) import Generics.SOP.Constraint as SOP +#endif +#if MIN_VERSION_base(4,9,0) +import qualified Generics.SOP.Type.Metadata as SOP.T +#endif import Generics.SOP.Metadata as SOP +#if !(MIN_VERSION_base(4,9,0)) import Generics.SOP.Sing +#endif type family ToSingleCode (a :: * -> *) :: * type instance ToSingleCode (K1 _i a) = a @@ -46,6 +59,7 @@ data InfoProxy (c :: *) (f :: * -> *) (x :: *) = InfoProxy #endif +#if !(MIN_VERSION_base(4,9,0)) class GDatatypeInfo' (a :: * -> *) where gDatatypeInfo' :: proxy a -> DatatypeInfo (ToSumCode a '[]) @@ -105,6 +119,36 @@ where p :: InfoProxy c a x p = InfoProxy +#endif + +#if MIN_VERSION_base(4,9,0) +type family ToInfo (a :: * -> *) :: SOP.T.DatatypeInfo +type instance ToInfo (M1 D (MetaData n m p False) a) = + SOP.T.ADT m n (ToSumInfo a '[]) +type instance ToInfo (M1 D (MetaData n m p True) a) = + SOP.T.Newtype m n (ToSingleConstructorInfo a) + +type family ToSumInfo (a :: * -> *) (xs :: [SOP.T.ConstructorInfo]) :: [SOP.T.ConstructorInfo] +type instance ToSumInfo (a :+: b) xs = ToSumInfo a (ToSumInfo b xs) +type instance ToSumInfo V1 xs = xs +type instance ToSumInfo (M1 C c a) xs = ToSingleConstructorInfo (M1 C c a) ': xs + +type family ToSingleConstructorInfo (a :: * -> *) :: SOP.T.ConstructorInfo +type instance ToSingleConstructorInfo (M1 C (MetaCons n PrefixI False) a) = + SOP.T.Constructor n +type instance ToSingleConstructorInfo (M1 C (MetaCons n (InfixI assoc fix) False) a) = + SOP.T.Infix n assoc fix +type instance ToSingleConstructorInfo (M1 C (MetaCons n f True) a) = + SOP.T.Record n (ToProductInfo a '[]) + +type family ToProductInfo (a :: * -> *) (xs :: [SOP.T.FieldInfo]) :: [SOP.T.FieldInfo] +type instance ToProductInfo (a :*: b) xs = ToProductInfo a (ToProductInfo b xs) +type instance ToProductInfo U1 xs = xs +type instance ToProductInfo (M1 S c a) xs = ToSingleInfo (M1 S c a) ': xs + +type family ToSingleInfo (a :: * -> *) :: SOP.T.FieldInfo +type instance ToSingleInfo (M1 S (MetaSel (Just n) _su _ss _ds) a) = 'SOP.T.FieldInfo n +#endif class GFieldInfos (a :: * -> *) where gFieldInfos :: proxy a -> NP FieldInfo xs -> NP FieldInfo (ToProductCode a xs) @@ -209,7 +253,19 @@ type GTo a = GSumTo (GHC.Rep a) -- | Constraint for the class that computes 'gdatatypeInfo'. +#if MIN_VERSION_base(4,9,0) +type GDatatypeInfo a = SOP.T.DemoteDatatypeInfo (GDatatypeInfoOf a) (GCode a) +#else type GDatatypeInfo a = GDatatypeInfo' (GHC.Rep a) +#endif + +#if MIN_VERSION_base(4,9,0) +-- | Compute the datatype info of a datatype. +-- +-- @since 0.3.0.0 +-- +type GDatatypeInfoOf (a :: *) = ToInfo (GHC.Rep a) +#endif -- | An automatically computed version of 'Generics.SOP.from'. -- @@ -242,5 +298,9 @@ -- For more info, see 'Generics.SOP.HasDatatypeInfo'. -- gdatatypeInfo :: forall proxy a. (GDatatypeInfo a) => proxy a -> DatatypeInfo (GCode a) +#if MIN_VERSION_base(4,9,0) +gdatatypeInfo _ = SOP.T.demoteDatatypeInfo (Proxy :: Proxy (GDatatypeInfoOf a)) +#else gdatatypeInfo _ = gDatatypeInfo' (Proxy :: Proxy (GHC.Rep a)) +#endif diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/generics-sop-0.2.5.0/src/Generics/SOP/NP.hs new/generics-sop-0.3.1.0/src/Generics/SOP/NP.hs --- old/generics-sop-0.2.5.0/src/Generics/SOP/NP.hs 2017-04-21 15:30:39.000000000 +0200 +++ new/generics-sop-0.3.1.0/src/Generics/SOP/NP.hs 2017-06-11 15:25:51.000000000 +0200 @@ -64,12 +64,23 @@ , ccata_NP , ana_NP , cana_NP + -- * Transformation of index lists and coercions + , trans_NP + , trans_POP + , coerce_NP + , coerce_POP + , fromI_NP + , fromI_POP + , toI_NP + , toI_POP ) where #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative #endif +import Data.Coerce import Data.Proxy (Proxy(..)) +import Unsafe.Coerce import Control.DeepSeq (NFData(..)) @@ -152,6 +163,9 @@ type instance AllN NP c = All c type instance AllN POP c = All2 c +type instance AllZipN NP c = AllZip c +type instance AllZipN POP c = AllZip2 c + type instance SListIN NP = SListI type instance SListIN POP = SListI2 @@ -266,6 +280,9 @@ _ap_POP_spec :: SListI xss => POP (f -.-> g) xss -> POP f xss -> POP g xss _ap_POP_spec (POP fs) (POP xs) = POP (liftA2_NP ap_NP fs xs) +type instance Same NP = NP +type instance Same POP = POP + type instance Prod NP = NP type instance Prod POP = POP @@ -602,3 +619,124 @@ go SNil _ = Nil go SCons s = case uncons s of (x, s') -> x :* go sList s' + +-- | Specialization of 'htrans'. +-- +-- @since 0.3.1.0 +-- +trans_NP :: + AllZip c xs ys + => proxy c + -> (forall x y . c x y => f x -> g y) + -> NP f xs -> NP g ys +trans_NP _ _t Nil = Nil +trans_NP p t (x :* xs) = t x :* trans_NP p t xs + +-- | Specialization of 'htrans'. +-- +-- @since 0.3.1.0 +-- +trans_POP :: + AllZip2 c xss yss + => proxy c + -> (forall x y . c x y => f x -> g y) + -> POP f xss -> POP g yss +trans_POP p t = + POP . trans_NP (allZipP p) (trans_NP p t) . unPOP + +allZipP :: proxy c -> Proxy (AllZip c) +allZipP _ = Proxy + +-- | Specialization of 'hcoerce'. +-- +-- @since 0.3.1.0 +-- +coerce_NP :: + forall f g xs ys . + AllZip (LiftedCoercible f g) xs ys + => NP f xs -> NP g ys +coerce_NP = + unsafeCoerce + +-- There is a bug in the way coerce works for higher-kinded +-- type variables that seems to occur only in GHC 7.10. +-- +-- Therefore, the safe versions of the coercion functions +-- are excluded below. This is harmless because they're only +-- present for documentation purposes and not exported. + +#if __GLASGOW_HASKELL__ < 710 || __GLASGOW_HASKELL__ >= 800 +_safe_coerce_NP :: + forall f g xs ys . + AllZip (LiftedCoercible f g) xs ys + => NP f xs -> NP g ys +_safe_coerce_NP = + trans_NP (Proxy :: Proxy (LiftedCoercible f g)) coerce +#endif + +-- | Specialization of 'hcoerce'. +-- +-- @since 0.3.1.0 +-- +coerce_POP :: + forall f g xss yss . + AllZip2 (LiftedCoercible f g) xss yss + => POP f xss -> POP g yss +coerce_POP = + unsafeCoerce + +#if __GLASGOW_HASKELL__ < 710 || __GLASGOW_HASKELL__ >= 800 +_safe_coerce_POP :: + forall f g xss yss . + AllZip2 (LiftedCoercible f g) xss yss + => POP f xss -> POP g yss +_safe_coerce_POP = + trans_POP (Proxy :: Proxy (LiftedCoercible f g)) coerce +#endif + +-- | Specialization of 'hfromI'. +-- +-- @since 0.3.1.0 +-- +fromI_NP :: + forall f xs ys . + AllZip (LiftedCoercible I f) xs ys + => NP I xs -> NP f ys +fromI_NP = hfromI + +-- | Specialization of 'htoI'. +-- +-- @since 0.3.1.0 +-- +toI_NP :: + forall f xs ys . + AllZip (LiftedCoercible f I) xs ys + => NP f xs -> NP I ys +toI_NP = htoI + +-- | Specialization of 'hfromI'. +-- +-- @since 0.3.1.0 +-- +fromI_POP :: + forall f xss yss . + AllZip2 (LiftedCoercible I f) xss yss + => POP I xss -> POP f yss +fromI_POP = hfromI + +-- | Specialization of 'htoI'. +-- +-- @since 0.3.1.0 +-- +toI_POP :: + forall f xss yss . + AllZip2 (LiftedCoercible f I) xss yss + => POP f xss -> POP I yss +toI_POP = htoI + +instance HTrans NP NP where + htrans = trans_NP + hcoerce = coerce_NP +instance HTrans POP POP where + htrans = trans_POP + hcoerce = coerce_POP diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/generics-sop-0.2.5.0/src/Generics/SOP/NS.hs new/generics-sop-0.3.1.0/src/Generics/SOP/NS.hs --- old/generics-sop-0.2.5.0/src/Generics/SOP/NS.hs 2017-04-21 15:30:39.000000000 +0200 +++ new/generics-sop-0.3.1.0/src/Generics/SOP/NS.hs 2017-06-11 15:25:51.000000000 +0200 @@ -59,12 +59,23 @@ , cexpand_NS , expand_SOP , cexpand_SOP + -- * Transformation of index lists and coercions + , trans_NS + , trans_SOP + , coerce_NS + , coerce_SOP + , fromI_NS + , fromI_SOP + , toI_NS + , toI_SOP ) where #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative #endif +import Data.Coerce import Data.Proxy +import Unsafe.Coerce import Control.DeepSeq (NFData(..)) @@ -342,6 +353,9 @@ _ap_SOP_spec :: SListI xss => POP (t -.-> f) xss -> SOP t xss -> SOP f xss _ap_SOP_spec (POP fs) (SOP xs) = SOP (liftA2_NS ap_NP fs xs) +type instance Same NS = NS +type instance Same SOP = SOP + type instance Prod NS = NP type instance Prod SOP = POP @@ -591,3 +605,125 @@ instance HExpand SOP where hexpand = expand_SOP hcexpand = cexpand_SOP + +-- | Specialization of 'htrans'. +-- +-- @since 0.3.1.0 +-- +trans_NS :: + AllZip c xs ys + => proxy c + -> (forall x y . c x y => f x -> g y) + -> NS f xs -> NS g ys +trans_NS _ t (Z x) = Z (t x) +trans_NS p t (S x) = S (trans_NS p t x) + +-- | Specialization of 'htrans'. +-- +-- @since 0.3.1.0 +-- +trans_SOP :: + AllZip2 c xss yss + => proxy c + -> (forall x y . c x y => f x -> g y) + -> SOP f xss -> SOP g yss +trans_SOP p t = + SOP . trans_NS (allZipP p) (trans_NP p t) . unSOP + +allZipP :: proxy c -> Proxy (AllZip c) +allZipP _ = Proxy + +-- | Specialization of 'hcoerce'. +-- +-- @since 0.3.1.0 +-- +coerce_NS :: + forall f g xs ys . + AllZip (LiftedCoercible f g) xs ys + => NS f xs -> NS g ys +coerce_NS = + unsafeCoerce + +-- There is a bug in the way coerce works for higher-kinded +-- type variables that seems to occur only in GHC 7.10. +-- +-- Therefore, the safe versions of the coercion functions +-- are excluded below. This is harmless because they're only +-- present for documentation purposes and not exported. + +#if __GLASGOW_HASKELL__ < 710 || __GLASGOW_HASKELL__ >= 800 +_safe_coerce_NS :: + forall f g xs ys . + AllZip (LiftedCoercible f g) xs ys + => NS f xs -> NS g ys +_safe_coerce_NS = + trans_NS (Proxy :: Proxy (LiftedCoercible f g)) coerce +#endif + +-- | Specialization of 'hcoerce'. +-- +-- @since 0.3.1.0 +-- +coerce_SOP :: + forall f g xss yss . + AllZip2 (LiftedCoercible f g) xss yss + => SOP f xss -> SOP g yss +coerce_SOP = + unsafeCoerce + +#if __GLASGOW_HASKELL__ < 710 || __GLASGOW_HASKELL__ >= 800 +_safe_coerce_SOP :: + forall f g xss yss . + AllZip2 (LiftedCoercible f g) xss yss + => SOP f xss -> SOP g yss +_safe_coerce_SOP = + trans_SOP (Proxy :: Proxy (LiftedCoercible f g)) coerce +#endif + +-- | Specialization of 'hfromI'. +-- +-- @since 0.3.1.0 +-- +fromI_NS :: + forall f xs ys . + AllZip (LiftedCoercible I f) xs ys + => NS I xs -> NS f ys +fromI_NS = hfromI + +-- | Specialization of 'htoI'. +-- +-- @since 0.3.1.0 +-- +toI_NS :: + forall f xs ys . + AllZip (LiftedCoercible f I) xs ys + => NS f xs -> NS I ys +toI_NS = htoI + +-- | Specialization of 'hfromI'. +-- +-- @since 0.3.1.0 +-- +fromI_SOP :: + forall f xss yss . + AllZip2 (LiftedCoercible I f) xss yss + => SOP I xss -> SOP f yss +fromI_SOP = hfromI + +-- | Specialization of 'htoI'. +-- +-- @since 0.3.1.0 +-- +toI_SOP :: + forall f xss yss . + AllZip2 (LiftedCoercible f I) xss yss + => SOP f xss -> SOP I yss +toI_SOP = htoI + +instance HTrans NS NS where + htrans = trans_NS + hcoerce = coerce_NS + +instance HTrans SOP SOP where + htrans = trans_SOP + hcoerce = coerce_SOP diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/generics-sop-0.2.5.0/src/Generics/SOP/TH.hs new/generics-sop-0.3.1.0/src/Generics/SOP/TH.hs --- old/generics-sop-0.2.5.0/src/Generics/SOP/TH.hs 2017-04-21 15:30:39.000000000 +0200 +++ new/generics-sop-0.3.1.0/src/Generics/SOP/TH.hs 2017-06-11 15:25:51.000000000 +0200 @@ -5,15 +5,18 @@ , deriveGenericOnly , deriveGenericFunctions , deriveMetadataValue + , deriveMetadataType ) where import Control.Monad (replicateM) import Data.Maybe (fromMaybe) +import Data.Proxy import Language.Haskell.TH import Language.Haskell.TH.Syntax import Generics.SOP.BasicFunctors import qualified Generics.SOP.Metadata as SOP +import qualified Generics.SOP.Type.Metadata as SOP.T import Generics.SOP.NP import Generics.SOP.NS import Generics.SOP.Universe @@ -51,8 +54,12 @@ -- > to _ = error "unreachable" -- to avoid GHC warnings -- > -- > instance HasDatatypeInfo Tree where --- > datatypeInfo _ = ADT "Main" "Tree" --- > (Constructor "Leaf" :* Constructor "Node" :* Nil) +-- > type DatatypeInfoOf Tree = +-- > T.ADT "Main" "Tree" +-- > '[ T.Constructor "Leaf", T.Constructor "Node" ] +-- > +-- > datatypeInfo _ = +-- > T.demoteDatatypeInfo (Proxy :: Proxy (DatatypeInfoOf Tree)) -- -- /Limitations:/ Generation does not work for GADTs, for -- datatypes that involve existential quantification, for @@ -134,6 +141,29 @@ sequence [ sigD datatypeInfoName' [t| SOP.DatatypeInfo $(conT codeName') |] -- treeDatatypeInfo :: DatatypeInfo TreeCode , funD datatypeInfoName' [clause [] (normalB $ metadata' isNewtype name cons) []] -- treeDatatypeInfo = ... ] +{-# DEPRECATED deriveMetadataValue "Use 'deriveMetadataType' and 'demoteDatatypeInfo' instead." #-} + +-- | Derive @DatatypeInfo@ type for the type. +-- +-- /Example:/ If you say +-- +-- > deriveMetadataType ''Tree "TreeDatatypeInfo" +-- +-- then you get code that is equivalent to: +-- +-- > type TreeDatatypeInfo = +-- > T.ADT "Main" "Tree" +-- > [ T.Constructor "Leaf", T.Constructor "Node" ] +-- +-- @since 0.3.0.0 +-- +deriveMetadataType :: Name -> String -> Q [Dec] +deriveMetadataType n datatypeInfoName = do + let datatypeInfoName' = mkName datatypeInfoName + dec <- reifyDec n + withDataDec dec $ \ isNewtype _ctx name _bndrs cons _derivs -> + sequence + [ tySynD datatypeInfoName' [] (metadataType' isNewtype name cons) ] deriveGenericForDataDec :: Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q [Dec] deriveGenericForDataDec _isNewtype _cxt name bndrs cons _derivs = do @@ -154,7 +184,14 @@ let typ = appTyVars name bndrs md <- instanceD (cxt []) [t| HasDatatypeInfo $typ |] - [metadata isNewtype name cons] + [ metadataType typ isNewtype name cons + , funD 'datatypeInfo + [ clause [wildP] + (normalB [| SOP.T.demoteDatatypeInfo (Proxy :: Proxy (DatatypeInfoOf $typ)) |]) + [] + ] + ] + -- [metadata isNewtype name cons] return [md] @@ -212,10 +249,11 @@ Compute metadata -------------------------------------------------------------------------------} -metadata :: Bool -> Name -> [Con] -> Q Dec -metadata isNewtype typeName cs = - funD 'datatypeInfo [clause [wildP] (normalB $ metadata' isNewtype typeName cs) []] +metadataType :: Q Type -> Bool -> Name -> [Con] -> Q Dec +metadataType typ isNewtype typeName cs = + tySynInstD ''DatatypeInfoOf (tySynEqn [typ] (metadataType' isNewtype typeName cs)) +-- | Derive term-level metadata. metadata' :: Bool -> Name -> [Con] -> Q Exp metadata' isNewtype typeName cs = md where @@ -263,6 +301,54 @@ mdAssociativity InfixR = [| SOP.RightAssociative |] mdAssociativity InfixN = [| SOP.NotAssociative |] +-- | Derive type-level metadata. +metadataType' :: Bool -> Name -> [Con] -> Q Type +metadataType' isNewtype typeName cs = md + where + md :: Q Type + md | isNewtype = [t| 'SOP.T.Newtype $(stringT (nameModule' typeName)) + $(stringT (nameBase typeName)) + $(mdCon (head cs)) + |] + | otherwise = [t| 'SOP.T.ADT $(stringT (nameModule' typeName)) + $(stringT (nameBase typeName)) + $(promotedTypeList $ map mdCon cs) + |] + + + mdCon :: Con -> Q Type + mdCon (NormalC n _) = [t| 'SOP.T.Constructor $(stringT (nameBase n)) |] + mdCon (RecC n ts) = [t| 'SOP.T.Record $(stringT (nameBase n)) + $(promotedTypeList (map mdField ts)) + |] + mdCon (InfixC _ n _) = do +#if MIN_VERSION_template_haskell(2,11,0) + fixity <- reifyFixity n + case fromMaybe defaultFixity fixity of + Fixity f a -> +#else + i <- reify n + case i of + DataConI _ _ _ (Fixity f a) -> +#endif + [t| 'SOP.T.Infix $(stringT (nameBase n)) $(mdAssociativity a) $(natT f) |] +#if !MIN_VERSION_template_haskell(2,11,0) + _ -> fail "Strange infix operator" +#endif + mdCon (ForallC _ _ _) = fail "Existentials not supported" +#if MIN_VERSION_template_haskell(2,11,0) + mdCon (GadtC _ _ _) = fail "GADTs not supported" + mdCon (RecGadtC _ _ _) = fail "GADTs not supported" +#endif + + mdField :: VarStrictType -> Q Type + mdField (n, _, _) = [t| 'SOP.T.FieldInfo $(stringT (nameBase n)) |] + + mdAssociativity :: FixityDirection -> Q Type + mdAssociativity InfixL = [t| 'SOP.T.LeftAssociative |] + mdAssociativity InfixR = [t| 'SOP.T.RightAssociative |] + mdAssociativity InfixN = [t| 'SOP.T.NotAssociative |] + nameModule' :: Name -> String nameModule' = fromMaybe "" . nameModule @@ -300,6 +386,12 @@ conInfo (RecGadtC _ _ _) = fail "GADTs not supported" #endif +stringT :: String -> Q Type +stringT = litT . strTyLit + +natT :: Int -> Q Type +natT = litT . numTyLit . fromIntegral + promotedTypeList :: [Q Type] -> Q Type promotedTypeList [] = promotedNilT promotedTypeList (t:ts) = [t| $promotedConsT $t $(promotedTypeList ts) |] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/generics-sop-0.2.5.0/src/Generics/SOP/Type/Metadata.hs new/generics-sop-0.3.1.0/src/Generics/SOP/Type/Metadata.hs --- old/generics-sop-0.2.5.0/src/Generics/SOP/Type/Metadata.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/generics-sop-0.3.1.0/src/Generics/SOP/Type/Metadata.hs 2017-06-11 15:25:51.000000000 +0200 @@ -0,0 +1,270 @@ +{-# LANGUAGE PolyKinds, UndecidableInstances #-} +-- | Type-level metadata +-- +-- This module provides datatypes (to be used promoted) that can represent the +-- metadata of Haskell datatypes on the type level. +-- +-- We do not reuse the term-level metadata types, because these are GADTs that +-- incorporate additional invariants. We could (at least in GHC 8) impose the +-- same invariants on the type level as well, but some tests have revealed that +-- the resulting type are rather inconvenient to work with. +-- +-- So we use simple datatypes to represent the type-level metadata, even if +-- this means that some invariants are not explicitly captured. +-- +-- We establish a relation between the term- and type-level versions of the +-- metadata by automatically computing the term-level version from the type-level +-- version. +-- +-- As we now have two versions of metadata (term-level and type-level) +-- with very similar, yet slightly different datatype definitions, the names +-- between the modules clash, and this module is recommended to be imported +-- qualified when needed. +-- +-- The interface exported by this module is still somewhat experimental. +-- +-- @since 0.3.0.0 +-- +module Generics.SOP.Type.Metadata + ( module Generics.SOP.Type.Metadata + -- * re-exports + , Associativity(..) + ) where + +import Data.Proxy +import GHC.Generics (Associativity(..)) +#if __GLASGOW_HASKELL__ >= 800 +import GHC.Types +#endif +import GHC.TypeLits + +import qualified Generics.SOP.Metadata as M +import Generics.SOP.NP +import Generics.SOP.Sing + +-- Regarding the CPP in the datatype definitions below: +-- +-- We cannot promote type synonyms in GHC 7, so we +-- use equivalent yet less descriptive definitions +-- for the older GHCs. + +-- | Metadata for a datatype (to be used promoted). +-- +-- A type of kind @'DatatypeInfo'@ contains meta-information about a datatype +-- that is not contained in its code. This information consists +-- primarily of the names of the datatype, its constructors, and possibly its +-- record selectors. +-- +-- The constructor indicates whether the datatype has been declared using @newtype@ +-- or not. +-- +-- @since 0.3.0.0 +-- +data DatatypeInfo = +#if __GLASGOW_HASKELL__ >= 800 + ADT ModuleName DatatypeName [ConstructorInfo] + -- ^ Standard algebraic datatype + | Newtype ModuleName DatatypeName ConstructorInfo + -- ^ Newtype +#else + ADT Symbol Symbol [ConstructorInfo] + -- ^ Standard algebraic datatype + | Newtype Symbol Symbol ConstructorInfo + -- ^ Newtype +#endif + +-- | Metadata for a single constructors (to be used promoted). +-- +-- @since 0.3.0.0 +-- +data ConstructorInfo = +#if __GLASGOW_HASKELL__ >= 800 + Constructor ConstructorName + -- ^ Normal constructor + | Infix ConstructorName Associativity Fixity + -- ^ Infix constructor + | Record ConstructorName [FieldInfo] + -- ^ Record constructor +#else + Constructor Symbol + -- ^ Normal constructor + | Infix Symbol Associativity Nat + -- ^ Infix constructor + | Record Symbol [FieldInfo] + -- ^ Record constructor +#endif + +-- | Metadata for a single record field (to be used promoted). +-- +-- @since 0.3.0.0 +-- +data FieldInfo = +#if __GLASGOW_HASKELL__ >= 800 + FieldInfo FieldName +#else + FieldInfo Symbol +#endif + +#if __GLASGOW_HASKELL__ >= 800 +-- | The name of a datatype. +type DatatypeName = Symbol + +-- | The name of a module. +type ModuleName = Symbol + +-- | The name of a data constructor. +type ConstructorName = Symbol + +-- | The name of a field / record selector. +type FieldName = Symbol + +-- | The fixity of an infix constructor. +type Fixity = Nat +#endif + +-- Demotion +-- +-- The following classes are concerned with computing the +-- term-level metadata from the type-level metadata. + +-- | Class for computing term-level datatype information from +-- type-level datatype information. +-- +-- @since 0.3.0.0 +-- +class DemoteDatatypeInfo (x :: DatatypeInfo) (xss :: [[*]]) where + -- | Given a proxy of some type-level datatype information, + -- return the corresponding term-level information. + -- + -- @since 0.3.0.0 + -- + demoteDatatypeInfo :: proxy x -> M.DatatypeInfo xss + +instance + (KnownSymbol m, KnownSymbol d, DemoteConstructorInfos cs xss) + => DemoteDatatypeInfo ('ADT m d cs) xss where + demoteDatatypeInfo _ = + M.ADT + (symbolVal (Proxy :: Proxy m)) + (symbolVal (Proxy :: Proxy d)) + (demoteConstructorInfos (Proxy :: Proxy cs)) + +instance + (KnownSymbol m, KnownSymbol d, DemoteConstructorInfo c '[ x ]) + => DemoteDatatypeInfo ('Newtype m d c) '[ '[ x ] ] where + demoteDatatypeInfo _ = + M.Newtype + (symbolVal (Proxy :: Proxy m)) + (symbolVal (Proxy :: Proxy d)) + (demoteConstructorInfo (Proxy :: Proxy c)) + +-- | Class for computing term-level constructor information from +-- type-level constructor information. +-- +-- @since 0.3.0.0 +-- +class DemoteConstructorInfos (cs :: [ConstructorInfo]) (xss :: [[*]]) where + -- | Given a proxy of some type-level constructor information, + -- return the corresponding term-level information as a product. + -- + -- @since 0.3.0.0 + -- + demoteConstructorInfos :: proxy cs -> NP M.ConstructorInfo xss + +instance DemoteConstructorInfos '[] '[] where + demoteConstructorInfos _ = Nil + +instance + (DemoteConstructorInfo c xs, DemoteConstructorInfos cs xss) + => DemoteConstructorInfos (c ': cs) (xs ': xss) where + demoteConstructorInfos _ = + demoteConstructorInfo (Proxy :: Proxy c) :* demoteConstructorInfos (Proxy :: Proxy cs) + +-- | Class for computing term-level constructor information from +-- type-level constructor information. +-- +-- @since 0.3.0.0 +-- +class DemoteConstructorInfo (x :: ConstructorInfo) (xs :: [*]) where + -- | Given a proxy of some type-level constructor information, + -- return the corresponding term-level information. + -- + -- @since 0.3.0.0 + -- + demoteConstructorInfo :: proxy x -> M.ConstructorInfo xs + +instance (KnownSymbol s, SListI xs) => DemoteConstructorInfo ('Constructor s) xs where + demoteConstructorInfo _ = M.Constructor (symbolVal (Proxy :: Proxy s)) + +instance + (KnownSymbol s, DemoteAssociativity a, KnownNat f) + => DemoteConstructorInfo ('Infix s a f) [y, z] where + demoteConstructorInfo _ = + M.Infix + (symbolVal (Proxy :: Proxy s)) + (demoteAssociativity (Proxy :: Proxy a)) + (fromInteger (natVal (Proxy :: Proxy f))) + +instance (KnownSymbol s, DemoteFieldInfos fs xs) => DemoteConstructorInfo ('Record s fs) xs where + demoteConstructorInfo _ = + M.Record (symbolVal (Proxy :: Proxy s)) (demoteFieldInfos (Proxy :: Proxy fs)) + +-- | Class for computing term-level field information from +-- type-level field information. +-- +-- @since 0.3.0.0 +-- +class SListI xs => DemoteFieldInfos (fs :: [FieldInfo]) (xs :: [*]) where + -- | Given a proxy of some type-level field information, + -- return the corresponding term-level information as a product. + -- + -- @since 0.3.0.0 + -- + demoteFieldInfos :: proxy fs -> NP M.FieldInfo xs + +instance DemoteFieldInfos '[] '[] where + demoteFieldInfos _ = Nil + +instance + (DemoteFieldInfo f x, DemoteFieldInfos fs xs) + => DemoteFieldInfos (f ': fs) (x ': xs) where + demoteFieldInfos _ = demoteFieldInfo (Proxy :: Proxy f) :* demoteFieldInfos (Proxy :: Proxy fs) + +-- | Class for computing term-level field information from +-- type-level field information. +-- +-- @since 0.3.0.0 +-- +class DemoteFieldInfo (x :: FieldInfo) (a :: *) where + -- | Given a proxy of some type-level field information, + -- return the corresponding term-level information. + -- + -- @since 0.3.0.0 + -- + demoteFieldInfo :: proxy x -> M.FieldInfo a + +instance KnownSymbol s => DemoteFieldInfo ('FieldInfo s) a where + demoteFieldInfo _ = M.FieldInfo (symbolVal (Proxy :: Proxy s)) + +-- | Class for computing term-level associativity information +-- from type-level associativity information. +-- +-- @since 0.3.0.0 +-- +class DemoteAssociativity (a :: Associativity) where + -- | Given a proxy of some type-level associativity information, + -- return the corresponding term-level information. + -- + -- @since 0.3.0.0 + -- + demoteAssociativity :: proxy a -> M.Associativity + +instance DemoteAssociativity 'LeftAssociative where + demoteAssociativity _ = M.LeftAssociative + +instance DemoteAssociativity 'RightAssociative where + demoteAssociativity _ = M.RightAssociative + +instance DemoteAssociativity 'NotAssociative where + demoteAssociativity _ = M.NotAssociative + diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/generics-sop-0.2.5.0/src/Generics/SOP/Universe.hs new/generics-sop-0.3.1.0/src/Generics/SOP/Universe.hs --- old/generics-sop-0.2.5.0/src/Generics/SOP/Universe.hs 2017-04-21 15:30:39.000000000 +0200 +++ new/generics-sop-0.3.1.0/src/Generics/SOP/Universe.hs 2017-06-11 15:25:51.000000000 +0200 @@ -5,6 +5,7 @@ -- | Codes and interpretations module Generics.SOP.Universe where +import Data.Coerce (Coercible) import qualified GHC.Generics as GHC import Generics.SOP.BasicFunctors @@ -13,6 +14,7 @@ import Generics.SOP.Sing import Generics.SOP.GGP import Generics.SOP.Metadata +import qualified Generics.SOP.Type.Metadata as T -- | The (generic) representation of a datatype. -- @@ -137,7 +139,56 @@ -- of 'Generic' for the options. -- class HasDatatypeInfo a where + -- | Type-level datatype info + type DatatypeInfoOf a :: T.DatatypeInfo +#if MIN_VERSION_base(4,9,0) + type DatatypeInfoOf a = GDatatypeInfoOf a +#else + type DatatypeInfoOf a = DatatypeInfoOf a +#endif + + -- | Term-level datatype info; by default, the term-level datatype info is produced + -- from the type-level info. + -- datatypeInfo :: proxy a -> DatatypeInfo (Code a) - default datatypeInfo :: (GDatatypeInfo a, Code a ~ GCode a) - => proxy a -> DatatypeInfo (Code a) + default datatypeInfo :: (GDatatypeInfo a, GCode a ~ Code a) => proxy a -> DatatypeInfo (Code a) datatypeInfo = gdatatypeInfo + +-- | Constraint that captures that a datatype is a product type, +-- i.e., a type with a single constructor. +-- +-- It also gives access to the code for the arguments of that +-- constructor. +-- +-- @since 0.3.1.0 +-- +type IsProductType (a :: *) (xs :: [*]) = + (Generic a, Code a ~ '[ xs ]) + +-- | Constraint that captures that a datatype is an enumeration type, +-- i.e., none of the constructors have any arguments. +-- +-- @since 0.3.1.0 +-- +type IsEnumType (a :: *) = + (Generic a, All ((~) '[]) (Code a)) + +-- | Constraint that captures that a datatype is a single-constructor, +-- single-field datatype. This always holds for newtype-defined types, +-- but it can also be true for data-defined types. +-- +-- The constraint also gives access to the type that is wrapped. +-- +-- @since 0.3.1.0 +-- +type IsWrappedType (a :: *) (x :: *) = + (Generic a, Code a ~ '[ '[ x ] ]) + +-- | Constraint that captures that a datatype is a newtype. +-- This makes use of the fact that newtypes are always coercible +-- to the type they wrap, whereas datatypes are not. +-- +-- @since 0.3.1.0 +-- +type IsNewtype (a :: *) (x :: *) = + (IsWrappedType a x, Coercible a x) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/generics-sop-0.2.5.0/src/Generics/SOP.hs new/generics-sop-0.3.1.0/src/Generics/SOP.hs --- old/generics-sop-0.2.5.0/src/Generics/SOP.hs 2017-04-21 15:30:39.000000000 +0200 +++ new/generics-sop-0.3.1.0/src/Generics/SOP.hs 2017-06-11 15:25:51.000000000 +0200 @@ -218,6 +218,10 @@ -- * Codes and interpretations Generic(..) , Rep + , IsProductType + , IsEnumType + , IsWrappedType + , IsNewtype -- * n-ary datatypes , NP(..) , NS(..) @@ -296,6 +300,10 @@ , hsequenceK -- ** Expanding sums to products , HExpand(..) + -- ** Transformation of index lists and coercions + , HTrans(..) + , hfromI + , htoI -- ** Partial operations , fromList -- * Utilities @@ -322,10 +330,16 @@ -- ** Mapping constraints , All , All2 + , AllZip + , AllZip2 + , AllN + , AllZipN + -- ** Other constraints , Compose , And , Top - , AllN + , LiftedCoercible + , SameShapeAs -- ** Singletons , SList(..) , SListI(..) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/generics-sop-0.2.5.0/test/Example.hs new/generics-sop-0.3.1.0/test/Example.hs --- old/generics-sop-0.2.5.0/test/Example.hs 2017-04-21 15:30:39.000000000 +0200 +++ new/generics-sop-0.3.1.0/test/Example.hs 2017-06-11 15:25:51.000000000 +0200 @@ -10,6 +10,9 @@ import qualified GHC.Generics as GHC import Generics.SOP import Generics.SOP.TH +import qualified Generics.SOP.Type.Metadata as T + +import HTransExample -- Generic show, kind of gshow :: (Generic a, All2 Show (Code a)) => a -> String @@ -43,7 +46,7 @@ treeB :: TreeB treeB = NodeB (LeafB 1) (LeafB 2) -deriveGenericOnly ''TreeB +deriveGeneric ''TreeB instance Show TreeB where show = gshow @@ -56,6 +59,10 @@ deriveGenericFunctions ''TreeC "TreeCCode" "fromTreeC" "toTreeC" deriveMetadataValue ''TreeC "TreeCCode" "treeDatatypeInfo" +deriveMetadataType ''TreeC "TreeDatatypeInfo" + +demotedTreeDatatypeInfo :: DatatypeInfo TreeCCode +demotedTreeDatatypeInfo = T.demoteDatatypeInfo (Proxy :: Proxy TreeDatatypeInfo) instance Show TreeC where show x = gshowS (fromTreeC x) @@ -66,5 +73,9 @@ print tree print $ datatypeInfo (Proxy :: Proxy Tree) print treeB + print $ datatypeInfo (Proxy :: Proxy TreeB) print treeC print treeDatatypeInfo + print demotedTreeDatatypeInfo + print (treeDatatypeInfo == demotedTreeDatatypeInfo) + print $ convertFull tree diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/generics-sop-0.2.5.0/test/HTransExample.hs new/generics-sop-0.3.1.0/test/HTransExample.hs --- old/generics-sop-0.2.5.0/test/HTransExample.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/generics-sop-0.3.1.0/test/HTransExample.hs 2017-06-11 15:25:51.000000000 +0200 @@ -0,0 +1,27 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +module HTransExample where + +import Generics.SOP + +class IsTupleTypeOf xs y | xs -> y where + toTuple :: NP I xs -> y + default toTuple :: (Generic y, Code y ~ '[ xs ]) => NP I xs -> y + toTuple = to . SOP . Z + +instance IsTupleTypeOf '[] () +instance IsTupleTypeOf '[x1] x1 where toTuple = unI . hd +instance IsTupleTypeOf '[x1, x2] (x1, x2) +instance IsTupleTypeOf '[x1, x2, x3] (x1, x2, x3) +instance IsTupleTypeOf '[x1, x2, x3, x4] (x1, x2, x3, x4) + +convert :: (AllZip IsTupleTypeOf xss ys) => NS (NP I) xss -> NS I ys +convert = htrans (Proxy :: Proxy IsTupleTypeOf) (I . toTuple) + +convertFull :: (Generic a, AllZip IsTupleTypeOf (Code a) ys) => a -> NS I ys +convertFull = convert . unSOP . from