diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +# 0.5.1.0 (2020-03-29) + +* Compatibility with GHC-8.10 (thanks to Ryan Scott). + +* Improve TH generation support and extend it to + type families (thanks to Ryan Scott). + # 0.5.0.0 (2019-05-09) * Add strictness info to the metadata. This means that diff --git a/bench/SOPBench/Type.hs b/bench/SOPBench/Type.hs --- a/bench/SOPBench/Type.hs +++ b/bench/SOPBench/Type.hs @@ -187,6 +187,8 @@ instance Show (S2 'SOPTH) where showsPrec = SOP.gshowsPrec +deriveGenericSubst ''S20 (const (promotedT 'SOPTH)) + instance Roundtrip (S20 'GHCGeneric) where roundtrip = ghcroundtrip @@ -204,8 +206,6 @@ instance SOP.Generic (S20 'SOPGGP) instance SOP.HasDatatypeInfo (S20 'SOPGGP) -deriveGenericSubst ''S20 (const (promotedT 'SOPTH)) - instance Eq (S20 'SOPGGP) where (==) = SOP.geq @@ -218,6 +218,8 @@ instance Show (S20 'SOPTH) where showsPrec = SOP.gshowsPrec +deriveGenericSubst ''PB2 (const (promotedT 'SOPTH)) + instance Roundtrip (PB2 'GHCGeneric) where roundtrip = ghcroundtrip @@ -234,8 +236,6 @@ deriving instance GHC.Generic (PB2 'SOPGGP) instance SOP.Generic (PB2 'SOPGGP) instance SOP.HasDatatypeInfo (PB2 'SOPGGP) - -deriveGenericSubst ''PB2 (const (promotedT 'SOPTH)) instance Eq (PB2 'SOPGGP) where (==) = SOP.geq 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.5.0.0 +version: 0.5.1.0 synopsis: Generic Programming using True Sums of Products description: A library to support the definition of generic functions. @@ -42,7 +42,7 @@ build-type: Simple cabal-version: >=1.10 extra-source-files: CHANGELOG.md doctest.sh -tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5 +tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.2, GHC == 8.10.1 source-repository head type: git @@ -65,10 +65,11 @@ Generics.SOP.NP Generics.SOP.NS Generics.SOP.Sing - build-depends: base >= 4.9 && < 5, + build-depends: base >= 4.9 && < 4.15, sop-core == 0.5.0.*, - template-haskell >= 2.8 && < 2.15, - ghc-prim >= 0.3 && < 0.6 + template-haskell >= 2.8 && < 2.17, + th-abstraction >= 0.3 && < 0.4, + ghc-prim >= 0.3 && < 0.7 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall @@ -90,7 +91,10 @@ KindSignatures DataKinds FunctionalDependencies - AutoDeriveTypeable + + if impl(ghc <8.2) + default-extensions: AutoDeriveTypeable + -- if impl(ghc >= 8.6) -- default-extensions: NoStarIsType other-extensions: PolyKinds 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 @@ -137,7 +137,7 @@ -- This can most certainly be simplified class GSumFrom (a :: Type -> Type) where - gSumFrom :: a x -> SOP I xss -> SOP I (ToSumCode a xss) + gSumFrom :: a x -> proxy xss -> SOP I (ToSumCode a xss) gSumSkip :: proxy a -> SOP I xss -> SOP I (ToSumCode a xss) instance GSumFrom V1 where @@ -145,7 +145,10 @@ gSumSkip _ xss = xss instance (GSumFrom a, GSumFrom b) => GSumFrom (a :+: b) where - gSumFrom (L1 a) xss = gSumFrom a (gSumSkip (Proxy :: Proxy b) xss) + gSumFrom (L1 a) xss = gSumFrom a (toSumCodeProxy xss) where + toSumCodeProxy :: proxy xss -> Proxy (ToSumCode b xss) + toSumCodeProxy _ = Proxy + gSumFrom (R1 b) xss = gSumSkip (Proxy :: Proxy a) (gSumFrom b xss) gSumSkip _ xss = gSumSkip (Proxy :: Proxy a) (gSumSkip (Proxy :: Proxy b) xss) @@ -208,7 +211,7 @@ -- For more info, see 'Generics.SOP.Generic'. -- gfrom :: (GFrom a, GHC.Generic a) => a -> SOP I (GCode a) -gfrom x = gSumFrom (GHC.from x) (error "gfrom: internal error" :: SOP.SOP SOP.I '[]) +gfrom x = gSumFrom (GHC.from x) (Proxy :: Proxy '[]) -- | An automatically computed version of 'Generics.SOP.to'. -- 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 @@ -10,12 +10,12 @@ , deriveMetadataType ) where -import Control.Monad (join, replicateM) +import Control.Monad (join, replicateM, unless) import Data.List (foldl') import Data.Maybe (fromMaybe) import Data.Proxy import Language.Haskell.TH -import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Datatype as TH import Generics.SOP.BasicFunctors import qualified Generics.SOP.Metadata as SOP @@ -83,7 +83,7 @@ -- deriveGenericSubst :: Name -> (Name -> Q Type) -> Q [Dec] deriveGenericSubst n f = do - dec <- reifyDec n + dec <- reifyDatatype n ds1 <- withDataDec dec (deriveGenericForDataDec f) ds2 <- withDataDec dec (deriveMetadataForDataDec f) return (ds1 ++ ds2) @@ -94,7 +94,7 @@ -- deriveGenericOnlySubst :: Name -> (Name -> Q Type) -> Q [Dec] deriveGenericOnlySubst n f = do - dec <- reifyDec n + dec <- reifyDatatype n withDataDec dec (deriveGenericForDataDec f) -- | Like 'deriveGenericOnly', but don't derive class instance, only functions. @@ -123,10 +123,10 @@ let codeName' = mkName codeName let fromName' = mkName fromName let toName' = mkName toName - dec <- reifyDec n - withDataDec dec $ \_isNewtype _cxt name bndrs cons _derivs -> do + dec <- reifyDatatype n + withDataDec dec $ \_variant _cxt name bndrs instTys cons -> do let codeType = codeFor varT cons -- '[ '[Int], '[Tree, Tree] ] - let origType = appTyVars varT name bndrs -- Tree + let origType = appTysSubst varT name instTys -- Tree let repType = [t| SOP I $(appTyVars varT codeName' bndrs) |] -- SOP I TreeCode sequence [ tySynD codeName' bndrs codeType -- type TreeCode = '[ '[Int], '[Tree, Tree] ] @@ -156,10 +156,10 @@ deriveMetadataValue n codeName datatypeInfoName = do let codeName' = mkName codeName let datatypeInfoName' = mkName datatypeInfoName - dec <- reifyDec n - withDataDec dec $ \isNewtype _cxt name _bndrs cons _derivs -> do - sequence [ sigD datatypeInfoName' [t| SOP.DatatypeInfo $(conT codeName') |] -- treeDatatypeInfo :: DatatypeInfo TreeCode - , funD datatypeInfoName' [clause [] (normalB $ metadata' isNewtype name cons) []] -- treeDatatypeInfo = ... + dec <- reifyDatatype n + withDataDec dec $ \variant _cxt name bndrs _instTys cons -> do + sequence [ sigD datatypeInfoName' [t| SOP.DatatypeInfo $(appTyVars varT codeName' bndrs) |] -- treeDatatypeInfo :: DatatypeInfo TreeCode + , funD datatypeInfoName' [clause [] (normalB $ metadata' variant name cons) []] -- treeDatatypeInfo = ... ] {-# DEPRECATED deriveMetadataValue "Use 'deriveMetadataType' and 'demoteDatatypeInfo' instead." #-} @@ -180,24 +180,20 @@ deriveMetadataType :: Name -> String -> Q [Dec] deriveMetadataType n datatypeInfoName = do let datatypeInfoName' = mkName datatypeInfoName - dec <- reifyDec n - withDataDec dec $ \ isNewtype _ctx name _bndrs cons _derivs -> + dec <- reifyDatatype n + withDataDec dec $ \ variant _ctx name _bndrs _instTys cons -> sequence - [ tySynD datatypeInfoName' [] (metadataType' isNewtype name cons) ] + [ tySynD datatypeInfoName' [] (metadataType' variant name cons) ] deriveGenericForDataDec :: - (Name -> Q Type) -> Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q [Dec] -deriveGenericForDataDec f _isNewtype _cxt name bndrs cons _derivs = do - let typ = appTyVars f name bndrs + (Name -> Q Type) -> DatatypeVariant -> Cxt -> Name -> [TyVarBndr] -> [Type] -> [TH.ConstructorInfo] -> Q [Dec] +deriveGenericForDataDec f _variant _cxt name _bndrs instTys cons = do + let typ = appTysSubst f name instTys deriveGenericForDataType f typ cons -deriveGenericForDataType :: (Name -> Q Type) -> Q Type -> [Con] -> Q [Dec] +deriveGenericForDataType :: (Name -> Q Type) -> Q Type -> [TH.ConstructorInfo] -> Q [Dec] deriveGenericForDataType f typ cons = do -#if MIN_VERSION_template_haskell(2,15,0) - let codeSyn = tySynInstD (tySynEqn Nothing [t| Code $typ |] (codeFor f cons)) -#else - let codeSyn = tySynInstD ''Code $ tySynEqn [typ] (codeFor f cons) -#endif + let codeSyn = tySynInstDCompat ''Code Nothing [typ] (codeFor f cons) inst <- instanceD (cxt []) [t| Generic $typ |] @@ -205,33 +201,33 @@ return [inst] deriveMetadataForDataDec :: - (Name -> Q Type) -> Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q [Dec] -deriveMetadataForDataDec f isNewtype _cxt name bndrs cons _derivs = do - let typ = appTyVars f name bndrs - deriveMetadataForDataType isNewtype name typ cons + (Name -> Q Type) -> DatatypeVariant -> Cxt -> Name -> [TyVarBndr] -> [Type] -> [TH.ConstructorInfo] -> Q [Dec] +deriveMetadataForDataDec f variant _cxt name _bndrs instTys cons = do + let typ = appTysSubst f name instTys + deriveMetadataForDataType variant name typ cons -deriveMetadataForDataType :: Bool -> Name -> Q Type -> [Con] -> Q [Dec] -deriveMetadataForDataType isNewtype name typ cons = do +deriveMetadataForDataType :: DatatypeVariant -> Name -> Q Type -> [TH.ConstructorInfo] -> Q [Dec] +deriveMetadataForDataType variant name typ cons = do md <- instanceD (cxt []) [t| HasDatatypeInfo $typ |] - [ metadataType typ isNewtype name cons + [ metadataType typ variant name cons , funD 'datatypeInfo [ clause [wildP] (normalB [| SOP.T.demoteDatatypeInfo (Proxy :: Proxy (DatatypeInfoOf $typ)) |]) [] ] ] - -- [metadata isNewtype name cons] + -- [metadata variant name cons] return [md] {------------------------------------------------------------------------------- Computing the code for a data type -------------------------------------------------------------------------------} -codeFor :: (Name -> Q Type) -> [Con] -> Q Type +codeFor :: (Name -> Q Type) -> [TH.ConstructorInfo] -> Q Type codeFor f = promotedTypeList . map go where - go :: Con -> Q Type + go :: TH.ConstructorInfo -> Q Type go c = do (_, ts) <- conInfo c promotedTypeListSubst f ts @@ -239,20 +235,20 @@ Computing the embedding/projection pair -------------------------------------------------------------------------------} -embedding :: Name -> [Con] -> Q Dec +embedding :: Name -> [TH.ConstructorInfo] -> Q Dec embedding fromName = funD fromName . go' (\e -> [| Z $e |]) where - go' :: (Q Exp -> Q Exp) -> [Con] -> [Q Clause] + go' :: (Q Exp -> Q Exp) -> [TH.ConstructorInfo] -> [Q Clause] go' _ [] = (:[]) $ do x <- newName "x" clause [varP x] (normalB (caseE (varE x) [])) [] go' br cs = go br cs - go :: (Q Exp -> Q Exp) -> [Con] -> [Q Clause] + go :: (Q Exp -> Q Exp) -> [TH.ConstructorInfo] -> [Q Clause] go _ [] = [] go br (c:cs) = mkClause br c : go (\e -> [| S $(br e) |]) cs - mkClause :: (Q Exp -> Q Exp) -> Con -> Q Clause + mkClause :: (Q Exp -> Q Exp) -> TH.ConstructorInfo -> Q Clause mkClause br c = do (n, ts) <- conInfo c vars <- replicateM (length ts) (newName "x") @@ -260,16 +256,16 @@ (normalB [| SOP $(br . npE . map (appE (conE 'I) . varE) $ vars) |]) [] -projection :: Name -> [Con] -> Q Dec +projection :: Name -> [TH.ConstructorInfo] -> Q Dec projection toName = funD toName . go' where - go' :: [Con] -> [Q Clause] + go' :: [TH.ConstructorInfo] -> [Q Clause] go' [] = (:[]) $ do x <- newName "x" clause [varP x] (normalB (caseE (varE x) [])) [] go' cs = go id cs - go :: (Q Pat -> Q Pat) -> [Con] -> [Q Clause] + go :: (Q Pat -> Q Pat) -> [TH.ConstructorInfo] -> [Q Clause] go br [] = [mkUnreachableClause br] go br (c:cs) = mkClause br c : go (\p -> conP 'S [br p]) cs @@ -291,7 +287,7 @@ (normalB [| $(varE var) `seq` error "inaccessible" |]) [] - mkClause :: (Q Pat -> Q Pat) -> Con -> Q Clause + mkClause :: (Q Pat -> Q Pat) -> TH.ConstructorInfo -> Q Clause mkClause br c = do (n, ts) <- conInfo c vars <- replicateM (length ts) (newName "x") @@ -303,74 +299,74 @@ Compute metadata -------------------------------------------------------------------------------} -metadataType :: Q Type -> Bool -> Name -> [Con] -> Q Dec -metadataType typ isNewtype typeName cs = -#if MIN_VERSION_template_haskell(2,15,0) - tySynInstD (tySynEqn Nothing [t| DatatypeInfoOf $typ |] (metadataType' isNewtype typeName cs)) -#else - tySynInstD ''DatatypeInfoOf (tySynEqn [typ] (metadataType' isNewtype typeName cs)) -#endif +metadataType :: Q Type -> DatatypeVariant -> Name -> [TH.ConstructorInfo] -> Q Dec +metadataType typ variant typeName cs = + tySynInstDCompat ''DatatypeInfoOf Nothing [typ] (metadataType' variant typeName cs) -- | Derive term-level metadata. -metadata' :: Bool -> Name -> [Con] -> Q Exp -metadata' isNewtype typeName cs = md +metadata' :: DatatypeVariant -> Name -> [TH.ConstructorInfo] -> Q Exp +metadata' dataVariant typeName cs = md where md :: Q Exp - md | isNewtype = [| SOP.Newtype $(stringE (nameModule' typeName)) - $(stringE (nameBase typeName)) - $(mdCon (head cs)) - |] - | otherwise = [| SOP.ADT $(stringE (nameModule' typeName)) - $(stringE (nameBase typeName)) - $(npE $ map mdCon cs) - $(popE $ map mdStrictness cs) - |] + md | isNewtypeVariant dataVariant + = [| SOP.Newtype $(stringE (nameModule' typeName)) + $(stringE (nameBase typeName)) + $(mdCon (head cs)) + |] - mdStrictness :: Con -> Q [Q Exp] - mdStrictness (NormalC n bts) = mdConStrictness n (map fst bts) - mdStrictness (RecC n vbts) = mdConStrictness n (map (\ (_, b, _) -> b) vbts) - mdStrictness (InfixC (b1, _) n (b2, _)) = mdConStrictness n [b1, b2] - mdStrictness (ForallC _ _ _) = fail "Existentials not supported" - mdStrictness (GadtC _ _ _) = fail "GADTs not supported" - mdStrictness (RecGadtC _ _ _) = fail "GADTs not supported" + | otherwise + = [| SOP.ADT $(stringE (nameModule' typeName)) + $(stringE (nameBase typeName)) + $(npE $ map mdCon cs) + $(popE $ map mdStrictness cs) + |] - mdConStrictness :: Name -> [Bang] -> Q [Q Exp] + mdStrictness :: TH.ConstructorInfo -> Q [Q Exp] + mdStrictness ci@(ConstructorInfo { constructorName = n + , constructorStrictness = bs }) = + checkForGADTs ci $ mdConStrictness n bs + + mdConStrictness :: Name -> [FieldStrictness] -> Q [Q Exp] mdConStrictness n bs = do dss <- reifyConStrictness n - return (zipWith (\ (Bang su ss) ds -> + return (zipWith (\ (FieldStrictness su ss) ds -> [| SOP.StrictnessInfo - $(mdSourceUnpackedness su) - $(mdSourceStrictness ss) + $(mdTHUnpackedness su) + $(mdTHStrictness ss) $(mdDecidedStrictness ds) |]) bs dss) - mdCon :: Con -> Q Exp - mdCon (NormalC n _) = [| SOP.Constructor $(stringE (nameBase n)) |] - mdCon (RecC n ts) = [| SOP.Record $(stringE (nameBase n)) - $(npE (map mdField ts)) - |] - mdCon (InfixC _ n _) = do - fixity <- reifyFixity n - case fromMaybe defaultFixity fixity of - Fixity f a -> - [| SOP.Infix $(stringE (nameBase n)) $(mdAssociativity a) f |] - mdCon (ForallC _ _ _) = fail "Existentials not supported" - mdCon (GadtC _ _ _) = fail "GADTs not supported" - mdCon (RecGadtC _ _ _) = fail "GADTs not supported" + mdCon :: TH.ConstructorInfo -> Q Exp + mdCon ci@(ConstructorInfo { constructorName = n + , constructorVariant = conVariant }) = + checkForGADTs ci $ + case conVariant of + NormalConstructor -> [| SOP.Constructor $(stringE (nameBase n)) |] + RecordConstructor ts -> [| SOP.Record $(stringE (nameBase n)) + $(npE (map mdField ts)) + |] + InfixConstructor -> do + fixity <- reifyFixity n + case fromMaybe defaultFixity fixity of + Fixity f a -> [| SOP.Infix $(stringE (nameBase n)) + $(mdAssociativity a) + f + |] - mdField :: VarStrictType -> Q Exp - mdField (n, _, _) = [| SOP.FieldInfo $(stringE (nameBase n)) |] - mdSourceUnpackedness :: SourceUnpackedness -> Q Exp - mdSourceUnpackedness NoSourceUnpackedness = [| SOP.NoSourceUnpackedness |] - mdSourceUnpackedness SourceNoUnpack = [| SOP.SourceNoUnpack |] - mdSourceUnpackedness SourceUnpack = [| SOP.SourceUnpack |] + mdField :: Name -> Q Exp + mdField n = [| SOP.FieldInfo $(stringE (nameBase n)) |] - mdSourceStrictness :: SourceStrictness -> Q Exp - mdSourceStrictness NoSourceStrictness = [| SOP.NoSourceStrictness |] - mdSourceStrictness SourceLazy = [| SOP.SourceLazy |] - mdSourceStrictness SourceStrict = [| SOP.SourceStrict |] + mdTHUnpackedness :: TH.Unpackedness -> Q Exp + mdTHUnpackedness UnspecifiedUnpackedness = [| SOP.NoSourceUnpackedness |] + mdTHUnpackedness NoUnpack = [| SOP.SourceNoUnpack |] + mdTHUnpackedness Unpack = [| SOP.SourceUnpack |] + mdTHStrictness :: TH.Strictness -> Q Exp + mdTHStrictness UnspecifiedStrictness = [| SOP.NoSourceStrictness |] + mdTHStrictness Lazy = [| SOP.SourceLazy |] + mdTHStrictness TH.Strict = [| SOP.SourceStrict |] + mdDecidedStrictness :: DecidedStrictness -> Q Exp mdDecidedStrictness DecidedLazy = [| SOP.DecidedLazy |] mdDecidedStrictness DecidedStrict = [| SOP.DecidedStrict |] @@ -382,64 +378,67 @@ mdAssociativity InfixN = [| SOP.NotAssociative |] -- | Derive type-level metadata. -metadataType' :: Bool -> Name -> [Con] -> Q Type -metadataType' isNewtype typeName cs = md +metadataType' :: DatatypeVariant -> Name -> [TH.ConstructorInfo] -> Q Type +metadataType' dataVariant 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) - $(promotedTypeListOfList $ map mdStrictness cs) - |] + md | isNewtypeVariant dataVariant + = [t| 'SOP.T.Newtype $(stringT (nameModule' typeName)) + $(stringT (nameBase typeName)) + $(mdCon (head cs)) + |] - mdStrictness :: Con -> Q [Q Type] - mdStrictness (NormalC n bts) = mdConStrictness n (map fst bts) - mdStrictness (RecC n vbts) = mdConStrictness n (map (\ (_, b, _) -> b) vbts) - mdStrictness (InfixC (b1, _) n (b2, _)) = mdConStrictness n [b1, b2] - mdStrictness (ForallC _ _ _) = fail "Existentials not supported" - mdStrictness (GadtC _ _ _) = fail "GADTs not supported" - mdStrictness (RecGadtC _ _ _) = fail "GADTs not supported" + | otherwise + = [t| 'SOP.T.ADT $(stringT (nameModule' typeName)) + $(stringT (nameBase typeName)) + $(promotedTypeList $ map mdCon cs) + $(promotedTypeListOfList $ map mdStrictness cs) + |] - mdConStrictness :: Name -> [Bang] -> Q [Q Type] + mdStrictness :: TH.ConstructorInfo -> Q [Q Type] + mdStrictness ci@(ConstructorInfo { constructorName = n + , constructorStrictness = bs }) = + checkForGADTs ci $ mdConStrictness n bs + + mdConStrictness :: Name -> [FieldStrictness] -> Q [Q Type] mdConStrictness n bs = do dss <- reifyConStrictness n - return (zipWith (\ (Bang su ss) ds -> + return (zipWith (\ (FieldStrictness su ss) ds -> [t| 'SOP.T.StrictnessInfo - $(mdSourceUnpackedness su) - $(mdSourceStrictness ss) + $(mdTHUnpackedness su) + $(mdTHStrictness ss) $(mdDecidedStrictness ds) |]) bs dss) - 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 - fixity <- reifyFixity n - case fromMaybe defaultFixity fixity of - Fixity f a -> - [t| 'SOP.T.Infix $(stringT (nameBase n)) $(mdAssociativity a) $(natT f) |] - mdCon (ForallC _ _ _) = fail "Existentials not supported" - mdCon (GadtC _ _ _) = fail "GADTs not supported" - mdCon (RecGadtC _ _ _) = fail "GADTs not supported" + mdCon :: TH.ConstructorInfo -> Q Type + mdCon ci@(ConstructorInfo { constructorName = n + , constructorVariant = conVariant }) = + checkForGADTs ci $ + case conVariant of + NormalConstructor -> [t| 'SOP.T.Constructor $(stringT (nameBase n)) |] + RecordConstructor ts -> [t| 'SOP.T.Record $(stringT (nameBase n)) + $(promotedTypeList (map mdField ts)) + |] + InfixConstructor -> do + fixity <- reifyFixity n + case fromMaybe defaultFixity fixity of + Fixity f a -> [t| 'SOP.T.Infix $(stringT (nameBase n)) + $(mdAssociativity a) + $(natT f) + |] - mdField :: VarStrictType -> Q Type - mdField (n, _, _) = [t| 'SOP.T.FieldInfo $(stringT (nameBase n)) |] + mdField :: Name -> Q Type + mdField n = [t| 'SOP.T.FieldInfo $(stringT (nameBase n)) |] - mdSourceUnpackedness :: SourceUnpackedness -> Q Type - mdSourceUnpackedness NoSourceUnpackedness = [t| 'SOP.NoSourceUnpackedness |] - mdSourceUnpackedness SourceNoUnpack = [t| 'SOP.SourceNoUnpack |] - mdSourceUnpackedness SourceUnpack = [t| 'SOP.SourceUnpack |] + mdTHUnpackedness :: TH.Unpackedness -> Q Type + mdTHUnpackedness UnspecifiedUnpackedness = [t| 'SOP.NoSourceUnpackedness |] + mdTHUnpackedness NoUnpack = [t| 'SOP.SourceNoUnpack |] + mdTHUnpackedness Unpack = [t| 'SOP.SourceUnpack |] - mdSourceStrictness :: SourceStrictness -> Q Type - mdSourceStrictness NoSourceStrictness = [t| 'SOP.NoSourceStrictness |] - mdSourceStrictness SourceLazy = [t| 'SOP.SourceLazy |] - mdSourceStrictness SourceStrict = [t| 'SOP.SourceStrict |] + mdTHStrictness :: TH.Strictness -> Q Type + mdTHStrictness UnspecifiedStrictness = [t| 'SOP.NoSourceStrictness |] + mdTHStrictness Lazy = [t| 'SOP.SourceLazy |] + mdTHStrictness TH.Strict = [t| 'SOP.SourceStrict |] mdDecidedStrictness :: DecidedStrictness -> Q Type mdDecidedStrictness DecidedLazy = [t| 'SOP.DecidedLazy |] @@ -483,13 +482,10 @@ Some auxiliary definitions for working with TH -------------------------------------------------------------------------------} -conInfo :: Con -> Q (Name, [Q Type]) -conInfo (NormalC n ts) = return (n, map (return . (\(_, t) -> t)) ts) -conInfo (RecC n ts) = return (n, map (return . (\(_, _, t) -> t)) ts) -conInfo (InfixC (_, t) n (_, t')) = return (n, map return [t, t']) -conInfo (ForallC _ _ _) = fail "Existentials not supported" -conInfo (GadtC _ _ _) = fail "GADTs not supported" -conInfo (RecGadtC _ _ _) = fail "GADTs not supported" +conInfo :: TH.ConstructorInfo -> Q (Name, [Q Type]) +conInfo ci@(ConstructorInfo { constructorName = n + , constructorFields = ts }) = + checkForGADTs ci $ return (n, map return ts) stringT :: String -> Q Type stringT = litT . strTyLit @@ -512,14 +508,18 @@ appsT :: Name -> [Q Type] -> Q Type appsT n = foldl' appT (conT n) -bndrToName :: TyVarBndr -> Name -bndrToName (PlainTV v ) = v -bndrToName (KindedTV v _) = v - appTyVars :: (Name -> Q Type) -> Name -> [TyVarBndr] -> Q Type appTyVars f n bndrs = - appsT n (map (f . bndrToName) bndrs) + appsT n (map (f . tvName) bndrs) +appTysSubst :: (Name -> Q Type) -> Name -> [Type] -> Q Type +appTysSubst f n args = + appsT n (map (substType f . unSigType) args) + +unSigType :: Type -> Type +unSigType (SigT t _) = t +unSigType t = t + substType :: (Name -> Q Type) -> Type -> Q Type substType f = go where @@ -536,20 +536,58 @@ -- in the benchmarking suite. So we can fall back on identity in all -- but the cases we need for the benchmarking suite. -reifyDec :: Name -> Q Dec -reifyDec name = - do info <- reify name - case info of TyConI dec -> return dec - _ -> fail "Info must be type declaration type." +-- Process a DatatypeInfo using continuation-passing style. +withDataDec :: TH.DatatypeInfo + -> (DatatypeVariant + -- The variety of data type + -- (@data@, @newtype@, @data instance@, or @newtype instance@) + -> Cxt + -- The datatype context + -> Name + -- The data type's name + -> [TyVarBndr] + -- The datatype's type variable binders, both implicit and explicit. + -- Examples: + -- + -- - For `data Maybe a = Nothing | Just a`, the binders are + -- [PlainTV a] + -- - For `data Proxy (a :: k) = Proxy`, the binders are + -- [PlainTV k, KindedTV a (VarT k)] + -- - For `data instance DF Int (Maybe b) = DF b`, the binders are + -- [PlainTV b] + -> [Type] + -- For vanilla data types, these are the explicitly bound + -- type variable binders, but in Type form. + -- For data family instances, these are the type arguments. + -- Examples: + -- + -- - For `data Maybe a = Nothing | Just a`, the types are + -- [VarT a] + -- - For `data Proxy (a :: k) = Proxy`, the types are + -- [SigT (VarT a) (VarT k)] + -- - For `data instance DF Int (Maybe b) = DF b`, the binders are + -- [ConT ''Int, ConT ''Maybe `AppT` VarT b] + -> [TH.ConstructorInfo] + -- The data type's constructors + -> Q a) + -> Q a +withDataDec (TH.DatatypeInfo { datatypeContext = ctxt + , datatypeName = name + , datatypeVars = bndrs + , datatypeInstTypes = instTypes + , datatypeVariant = variant + , datatypeCons = cons }) f = + f variant ctxt name bndrs instTypes cons -withDataDec :: Dec -> (Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q a) -> Q a -withDataDec (DataD ctxt name bndrs _ cons derivs) f = f False ctxt name bndrs cons derivs -withDataDec (NewtypeD ctxt name bndrs _ con derivs) f = f True ctxt name bndrs [con] derivs -withDataDec _ _ = fail "Can only derive labels for datatypes and newtypes." +checkForGADTs :: TH.ConstructorInfo -> Q a -> Q a +checkForGADTs (ConstructorInfo { constructorVars = exVars + , constructorContext = exCxt }) q = do + unless (null exVars) $ fail "Existentials not supported" + unless (null exCxt) $ fail "GADTs not supported" + q --- | Utility type synonym to cover changes in the TH code -#if MIN_VERSION_template_haskell(2,12,0) -type Derivings = [DerivClause] -#else -type Derivings = Cxt -#endif +isNewtypeVariant :: DatatypeVariant -> Bool +isNewtypeVariant Datatype = False +isNewtypeVariant DataInstance = False +isNewtypeVariant Newtype = True +isNewtypeVariant NewtypeInstance = True diff --git a/src/Generics/SOP/Type/Metadata.hs b/src/Generics/SOP/Type/Metadata.hs --- a/src/Generics/SOP/Type/Metadata.hs +++ b/src/Generics/SOP/Type/Metadata.hs @@ -33,7 +33,9 @@ , Associativity(..) ) where +#if __GLASGOW_HASKELL__ <802 import Data.Kind (Type) +#endif import Data.Proxy (Proxy (..)) import GHC.Generics ( Associativity(..) diff --git a/test/Example.hs b/test/Example.hs --- a/test/Example.hs +++ b/test/Example.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GADTs #-} @@ -8,7 +9,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} -module Main (main, toTreeC) where +module Main (main, toTreeC, toDataFamC) where import qualified GHC.Generics as GHC import Generics.SOP @@ -67,6 +68,16 @@ instance Generic Void instance HasDatatypeInfo Void +data family DataFam a b c +data instance DataFam Int (Maybe b) c = DF b c + deriving (GHC.Generic) + +dataFam :: DataFam Int (Maybe Int) Int +dataFam = DF 1 2 + +instance Generic (DataFam Int (Maybe b) c) +instance HasDatatypeInfo (DataFam Int (Maybe b) c) + instance Show Tree where show = gshow @@ -76,6 +87,9 @@ instance Show Void where show = gshow +instance (Show b, Show c) => Show (DataFam Int (Maybe b) c) where + show = gshow + instance Enumerable ABC where enum = genum @@ -101,6 +115,14 @@ deriveGeneric ''VoidB +data family DataFamB a b c +data instance DataFamB Int (Maybe b) c = DFB b c + +dataFamB :: DataFamB Int (Maybe Int) Int +dataFamB = DFB 1 2 + +deriveGeneric 'DFB + instance Show TreeB where show = gshow @@ -110,6 +132,9 @@ instance Show VoidB where show = gshow +instance (Show b, Show c) => Show (DataFamB Int (Maybe b) c) where + show = gshow + instance Enumerable ABCB where enum = genum @@ -129,6 +154,12 @@ data VoidC +data family DataFamC a b c +data instance DataFamC Int (Maybe b) c = DFC b c + +dataFamC :: DataFamC Int (Maybe Int) Int +dataFamC = DFC 1 2 + deriveGenericFunctions ''TreeC "TreeCCode" "fromTreeC" "toTreeC" deriveMetadataValue ''TreeC "TreeCCode" "treeDatatypeInfo" deriveMetadataType ''TreeC "TreeDatatypeInfo" @@ -141,6 +172,10 @@ deriveMetadataValue ''VoidC "VoidCCode" "voidDatatypeInfo" deriveMetadataType ''VoidC "VoidDatatypeInfo" +deriveGenericFunctions 'DFC "DataFamCCode" "fromDataFamC" "toDataFamC" +deriveMetadataValue 'DFC "DataFamCCode" "dataFamDatatypeInfo" +deriveMetadataType 'DFC "DataFamDatatypeInfo" + demotedTreeDatatypeInfo :: DatatypeInfo TreeCCode demotedTreeDatatypeInfo = T.demoteDatatypeInfo (Proxy :: Proxy TreeDatatypeInfo) @@ -150,6 +185,9 @@ demotedVoidDatatypeInfo :: DatatypeInfo VoidCCode demotedVoidDatatypeInfo = T.demoteDatatypeInfo (Proxy :: Proxy VoidDatatypeInfo) +demotedDataFamDatatypeInfo :: DatatypeInfo (DataFamCCode b c) +demotedDataFamDatatypeInfo = T.demoteDatatypeInfo (Proxy :: Proxy DataFamDatatypeInfo) + instance Show TreeC where show x = gshowS (fromTreeC x) @@ -159,6 +197,9 @@ instance Show VoidC where show x = gshowS (fromVoidC x) +instance (Show b, Show c) => Show (DataFamC Int (Maybe b) c) where + show x = gshowS (fromDataFamC x) + instance Enumerable ABCC where enum = fmap toABCC genumS @@ -170,23 +211,30 @@ main = do print tree print abc + print dataFam print $ (enum :: [ABC]) print $ (enum :: [Void]) print $ datatypeInfo (Proxy :: Proxy Tree) print $ datatypeInfo (Proxy :: Proxy Void) + print $ datatypeInfo (Proxy :: Proxy (DataFam Int (Maybe Int) Int)) print treeB print abcB + print dataFamB print $ (enum :: [ABCB]) print $ (enum :: [VoidB]) print $ datatypeInfo (Proxy :: Proxy TreeB) print $ datatypeInfo (Proxy :: Proxy VoidB) + print $ datatypeInfo (Proxy :: Proxy (DataFamB Int (Maybe Int) Int)) print treeC print abcC + print dataFamC print $ (enum :: [ABCC]) print $ (enum :: [VoidC]) print treeDatatypeInfo print demotedTreeDatatypeInfo + print demotedDataFamDatatypeInfo print (treeDatatypeInfo == demotedTreeDatatypeInfo) print (abcDatatypeInfo == demotedABCDatatypeInfo) print (voidDatatypeInfo == demotedVoidDatatypeInfo) + print (dataFamDatatypeInfo == demotedDataFamDatatypeInfo) print $ convertFull tree