diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,36 @@ +# 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. diff --git a/generics-sop.cabal b/generics-sop.cabal --- a/generics-sop.cabal +++ b/generics-sop.cabal @@ -1,5 +1,5 @@ name: generics-sop -version: 0.2.5.0 +version: 0.3.0.0 synopsis: Generic Programming using True Sums of Products description: A library to support the definition of generic functions. @@ -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 diff --git a/src/Generics/SOP/GGP.hs b/src/Generics/SOP/GGP.hs --- a/src/Generics/SOP/GGP.hs +++ b/src/Generics/SOP/GGP.hs @@ -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,7 +119,37 @@ 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,8 +253,20 @@ 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'. -- -- This requires that the type being converted has a @@ -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 --git a/src/Generics/SOP/TH.hs b/src/Generics/SOP/TH.hs --- a/src/Generics/SOP/TH.hs +++ b/src/Generics/SOP/TH.hs @@ -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,7 +141,30 @@ 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 let typ = appTyVars name bndrs @@ -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 @@ -299,6 +385,12 @@ conInfo (GadtC _ _ _) = fail "GADTs not supported" 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 diff --git a/src/Generics/SOP/Type/Metadata.hs b/src/Generics/SOP/Type/Metadata.hs new file mode 100644 --- /dev/null +++ b/src/Generics/SOP/Type/Metadata.hs @@ -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 --git a/src/Generics/SOP/Universe.hs b/src/Generics/SOP/Universe.hs --- a/src/Generics/SOP/Universe.hs +++ b/src/Generics/SOP/Universe.hs @@ -13,6 +13,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 +138,17 @@ -- 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 diff --git a/test/Example.hs b/test/Example.hs --- a/test/Example.hs +++ b/test/Example.hs @@ -10,6 +10,7 @@ import qualified GHC.Generics as GHC import Generics.SOP import Generics.SOP.TH +import qualified Generics.SOP.Type.Metadata as T -- Generic show, kind of gshow :: (Generic a, All2 Show (Code a)) => a -> String @@ -43,7 +44,7 @@ treeB :: TreeB treeB = NodeB (LeafB 1) (LeafB 2) -deriveGenericOnly ''TreeB +deriveGeneric ''TreeB instance Show TreeB where show = gshow @@ -56,7 +57,11 @@ 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 +71,8 @@ print tree print $ datatypeInfo (Proxy :: Proxy Tree) print treeB + print $ datatypeInfo (Proxy :: Proxy TreeB) print treeC print treeDatatypeInfo + print demotedTreeDatatypeInfo + print (treeDatatypeInfo == demotedTreeDatatypeInfo)