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