diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,14 @@ +# 0.5.0.0 (2019-05-09) + +* Add strictness info to the metadata. This means that + code directly using the `ADT` constructor has to be + modified because it now has a new fourth argument. + (See #76 and #87.) + +* Depend on `sop-core-0.5.0.*` which changes the + definition of `SameShapeAs` to improve compiler + performance and adds "ejections". + # 0.4.0.1 (2018-10-23) * Remove `GHC.Event` import in `Generics.SOP.Instances` diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain 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.4.0.1 +version: 0.5.0.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.3, GHC == 8.6.1 +tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5 source-repository head type: git @@ -66,7 +66,7 @@ Generics.SOP.NS Generics.SOP.Sing build-depends: base >= 4.9 && < 5, - sop-core == 0.4.0.*, + sop-core == 0.5.0.*, template-haskell >= 2.8 && < 2.15, ghc-prim >= 0.3 && < 0.6 hs-source-dirs: src diff --git a/src/Generics/SOP.hs b/src/Generics/SOP.hs --- a/src/Generics/SOP.hs +++ b/src/Generics/SOP.hs @@ -25,7 +25,7 @@ -- witness the isomorphism. -- -- 3. Since all 'Rep' types are sums of products, you can define --- functions over them by performing induction on the structure, of +-- functions over them by performing induction on the structure, or -- by using predefined combinators that the library provides. Such -- functions then work for all 'Rep' types. -- @@ -224,9 +224,19 @@ Generic(..) , Rep , IsProductType + , ProductCode + , productTypeFrom + , productTypeTo , IsEnumType + , enumTypeFrom + , enumTypeTo , IsWrappedType + , WrappedCode + , wrappedTypeFrom + , wrappedTypeTo , IsNewtype + , newtypeFrom + , newtypeTo -- * n-ary datatypes , NP(..) , NS(..) @@ -292,6 +302,9 @@ -- ** Destructing sums , unZ , HIndex(..) + , Ejection + , ejections + , shiftEjection -- ** Dealing with @'All' c@ , hcliftA' , hcliftA2' 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 @@ -46,9 +46,22 @@ type family ToInfo (a :: Type -> Type) :: SOP.T.DatatypeInfo type instance ToInfo (M1 D (MetaData n m p False) a) = - SOP.T.ADT m n (ToSumInfo a '[]) + SOP.T.ADT m n (ToSumInfo a '[]) (ToStrictnessInfoss a '[]) type instance ToInfo (M1 D (MetaData n m p True) a) = SOP.T.Newtype m n (ToSingleConstructorInfo a) + +type family ToStrictnessInfoss (a :: Type -> Type) (xss :: [[SOP.T.StrictnessInfo]]) :: [[SOP.T.StrictnessInfo]] +type instance ToStrictnessInfoss (a :+: b) xss = ToStrictnessInfoss a (ToStrictnessInfoss b xss) +type instance ToStrictnessInfoss V1 xss = xss +type instance ToStrictnessInfoss (M1 C _ a) xss = ToStrictnessInfos a '[] ': xss + +type family ToStrictnessInfos (a :: Type -> Type) (xs :: [SOP.T.StrictnessInfo]) :: [SOP.T.StrictnessInfo] +type instance ToStrictnessInfos (a :*: b) xs = ToStrictnessInfos a (ToStrictnessInfos b xs) +type instance ToStrictnessInfos U1 xs = xs +type instance ToStrictnessInfos (M1 S s a) xs = ToStrictnessInfo s ': xs + +type family ToStrictnessInfo (s :: Meta) :: SOP.T.StrictnessInfo +type instance ToStrictnessInfo (MetaSel _ su ss ds) = 'SOP.T.StrictnessInfo su ss ds type family ToSumInfo (a :: Type -> Type) (xs :: [SOP.T.ConstructorInfo]) :: [SOP.T.ConstructorInfo] type instance ToSumInfo (a :+: b) xs = ToSumInfo a (ToSumInfo b xs) diff --git a/src/Generics/SOP/Metadata.hs b/src/Generics/SOP/Metadata.hs --- a/src/Generics/SOP/Metadata.hs +++ b/src/Generics/SOP/Metadata.hs @@ -15,10 +15,18 @@ ( module Generics.SOP.Metadata -- * re-exports , Associativity(..) + , DecidedStrictness(..) + , SourceStrictness(..) + , SourceUnpackedness(..) ) where import Data.Kind (Type) -import GHC.Generics (Associativity(..)) +import GHC.Generics + ( Associativity(..) + , DecidedStrictness(..) + , SourceStrictness(..) + , SourceUnpackedness(..) + ) import Generics.SOP.Constraint import Generics.SOP.NP @@ -35,16 +43,25 @@ -- data DatatypeInfo :: [[Type]] -> Type where -- Standard algebraic datatype - ADT :: ModuleName -> DatatypeName -> NP ConstructorInfo xss -> DatatypeInfo xss + ADT :: + ModuleName + -> DatatypeName + -> NP ConstructorInfo xss + -> POP StrictnessInfo xss + -> DatatypeInfo xss -- Newtype - Newtype :: ModuleName -> DatatypeName -> ConstructorInfo '[x] -> DatatypeInfo '[ '[x] ] + Newtype :: + ModuleName + -> DatatypeName + -> ConstructorInfo '[x] + -> DatatypeInfo '[ '[x] ] -- | The module name where a datatype is defined. -- -- @since 0.2.3.0 -- moduleName :: DatatypeInfo xss -> ModuleName -moduleName (ADT name _ _) = name +moduleName (ADT name _ _ _) = name moduleName (Newtype name _ _) = name -- | The name of a datatype (or newtype). @@ -52,7 +69,7 @@ -- @since 0.2.3.0 -- datatypeName :: DatatypeInfo xss -> DatatypeName -datatypeName (ADT _ name _ ) = name +datatypeName (ADT _ name _ _) = name datatypeName (Newtype _ name _) = name -- | The constructor info for a datatype (or newtype). @@ -60,14 +77,25 @@ -- @since 0.2.3.0 -- constructorInfo :: DatatypeInfo xss -> NP ConstructorInfo xss -constructorInfo (ADT _ _ cs) = cs +constructorInfo (ADT _ _ cs _) = cs constructorInfo (Newtype _ _ c) = c :* Nil -deriving instance All (Show `Compose` ConstructorInfo) xs => Show (DatatypeInfo xs) -deriving instance All (Eq `Compose` ConstructorInfo) xs => Eq (DatatypeInfo xs) -deriving instance (All (Eq `Compose` ConstructorInfo) xs, All (Ord `Compose` ConstructorInfo) xs) => Ord (DatatypeInfo xs) +deriving instance + ( All (Show `Compose` ConstructorInfo) xs + , All (Show `Compose` NP StrictnessInfo) xs + ) => Show (DatatypeInfo xs) +deriving instance + ( All (Eq `Compose` ConstructorInfo) xs + , All (Eq `Compose` NP StrictnessInfo) xs + ) => Eq (DatatypeInfo xs) +deriving instance + ( All (Eq `Compose` ConstructorInfo) xs + , All (Ord `Compose` ConstructorInfo) xs + , All (Eq `Compose` NP StrictnessInfo) xs + , All (Ord `Compose` NP StrictnessInfo) xs + ) => Ord (DatatypeInfo xs) --- | Metadata for a single constructors. +-- | Metadata for a single constructor. -- -- This is indexed by the product structure of the constructor components. -- @@ -91,6 +119,20 @@ deriving instance All (Show `Compose` FieldInfo) xs => Show (ConstructorInfo xs) deriving instance All (Eq `Compose` FieldInfo) xs => Eq (ConstructorInfo xs) deriving instance (All (Eq `Compose` FieldInfo) xs, All (Ord `Compose` FieldInfo) xs) => Ord (ConstructorInfo xs) + +-- | Metadata for strictness information of a field. +-- +-- Indexed by the type of the field. +-- +-- @since 0.4.0.0 +-- +data StrictnessInfo :: Type -> Type where + StrictnessInfo :: + SourceUnpackedness + -> SourceStrictness + -> DecidedStrictness + -> StrictnessInfo a + deriving (Show, Eq, Ord, Functor) -- | For records, this functor maps the component to its selector name. data FieldInfo :: Type -> Type where 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,7 +10,7 @@ , deriveMetadataType ) where -import Control.Monad (replicateM) +import Control.Monad (join, replicateM) import Data.List (foldl') import Data.Maybe (fromMaybe) import Data.Proxy @@ -193,7 +193,11 @@ deriveGenericForDataType :: (Name -> Q Type) -> Q Type -> [Con] -> 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 inst <- instanceD (cxt []) [t| Generic $typ |] @@ -301,7 +305,11 @@ 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 -- | Derive term-level metadata. metadata' :: Bool -> Name -> [Con] -> Q Exp @@ -315,9 +323,27 @@ | otherwise = [| SOP.ADT $(stringE (nameModule' typeName)) $(stringE (nameBase typeName)) $(npE $ map mdCon cs) + $(popE $ map mdStrictness 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" + mdConStrictness :: Name -> [Bang] -> Q [Q Exp] + mdConStrictness n bs = do + dss <- reifyConStrictness n + return (zipWith (\ (Bang su ss) ds -> + [| SOP.StrictnessInfo + $(mdSourceUnpackedness su) + $(mdSourceStrictness 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)) @@ -335,6 +361,21 @@ 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 |] + + mdSourceStrictness :: SourceStrictness -> Q Exp + mdSourceStrictness NoSourceStrictness = [| SOP.NoSourceStrictness |] + mdSourceStrictness SourceLazy = [| SOP.SourceLazy |] + mdSourceStrictness SourceStrict = [| SOP.SourceStrict |] + + mdDecidedStrictness :: DecidedStrictness -> Q Exp + mdDecidedStrictness DecidedLazy = [| SOP.DecidedLazy |] + mdDecidedStrictness DecidedStrict = [| SOP.DecidedStrict |] + mdDecidedStrictness DecidedUnpack = [| SOP.DecidedUnpack |] + mdAssociativity :: FixityDirection -> Q Exp mdAssociativity InfixL = [| SOP.LeftAssociative |] mdAssociativity InfixR = [| SOP.RightAssociative |] @@ -352,9 +393,27 @@ | otherwise = [t| 'SOP.T.ADT $(stringT (nameModule' typeName)) $(stringT (nameBase typeName)) $(promotedTypeList $ map mdCon cs) + $(promotedTypeListOfList $ map mdStrictness 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" + mdConStrictness :: Name -> [Bang] -> Q [Q Type] + mdConStrictness n bs = do + dss <- reifyConStrictness n + return (zipWith (\ (Bang su ss) ds -> + [t| 'SOP.T.StrictnessInfo + $(mdSourceUnpackedness su) + $(mdSourceStrictness 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)) @@ -372,6 +431,21 @@ mdField :: VarStrictType -> 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 |] + + mdSourceStrictness :: SourceStrictness -> Q Type + mdSourceStrictness NoSourceStrictness = [t| 'SOP.NoSourceStrictness |] + mdSourceStrictness SourceLazy = [t| 'SOP.SourceLazy |] + mdSourceStrictness SourceStrict = [t| 'SOP.SourceStrict |] + + mdDecidedStrictness :: DecidedStrictness -> Q Type + mdDecidedStrictness DecidedLazy = [t| 'SOP.DecidedLazy |] + mdDecidedStrictness DecidedStrict = [t| 'SOP.DecidedStrict |] + mdDecidedStrictness DecidedUnpack = [t| 'SOP.DecidedUnpack |] + mdAssociativity :: FixityDirection -> Q Type mdAssociativity InfixL = [t| 'SOP.T.LeftAssociative |] mdAssociativity InfixR = [t| 'SOP.T.RightAssociative |] @@ -395,6 +469,11 @@ npE [] = [| Nil |] npE (e:es) = [| $e :* $(npE es) |] +-- Construct a POP. +popE :: [Q [Q Exp]] -> Q Exp +popE ess = + [| POP $(npE (map (join . fmap npE) ess)) |] + -- Like npE, but construct a pattern instead npP :: [Q Pat] -> Q Pat npP [] = conP 'Nil [] @@ -421,6 +500,10 @@ promotedTypeList :: [Q Type] -> Q Type promotedTypeList [] = promotedNilT promotedTypeList (t:ts) = [t| $promotedConsT $t $(promotedTypeList ts) |] + +promotedTypeListOfList :: [Q [Q Type]] -> Q Type +promotedTypeListOfList = + promotedTypeList . map (join . fmap promotedTypeList) promotedTypeListSubst :: (Name -> Q Type) -> [Q Type] -> Q Type promotedTypeListSubst _ [] = promotedNilT 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 @@ -35,7 +35,12 @@ import Data.Kind (Type) import Data.Proxy (Proxy (..)) -import GHC.Generics (Associativity(..)) +import GHC.Generics + ( Associativity(..) + , DecidedStrictness(..) + , SourceStrictness(..) + , SourceUnpackedness(..) + ) import GHC.Types import GHC.TypeLits @@ -62,7 +67,7 @@ -- @since 0.3.0.0 -- data DatatypeInfo = - ADT ModuleName DatatypeName [ConstructorInfo] + ADT ModuleName DatatypeName [ConstructorInfo] [[StrictnessInfo]] -- ^ Standard algebraic datatype | Newtype ModuleName DatatypeName ConstructorInfo -- ^ Newtype @@ -79,6 +84,13 @@ | Record ConstructorName [FieldInfo] -- ^ Record constructor +-- | Strictness information for a single field (to be used promoted). +-- +-- @since 0.4.0.0 +-- +data StrictnessInfo = + StrictnessInfo SourceUnpackedness SourceStrictness DecidedStrictness + -- | Metadata for a single record field (to be used promoted). -- -- @since 0.3.0.0 @@ -120,13 +132,18 @@ demoteDatatypeInfo :: proxy x -> M.DatatypeInfo xss instance - (KnownSymbol m, KnownSymbol d, DemoteConstructorInfos cs xss) - => DemoteDatatypeInfo ('ADT m d cs) xss where + ( KnownSymbol m + , KnownSymbol d + , DemoteConstructorInfos cs xss + , DemoteStrictnessInfoss sss xss + ) + => DemoteDatatypeInfo ('ADT m d cs sss) xss where demoteDatatypeInfo _ = M.ADT (symbolVal (Proxy :: Proxy m)) (symbolVal (Proxy :: Proxy d)) (demoteConstructorInfos (Proxy :: Proxy cs)) + (POP (demoteStrictnessInfoss (Proxy :: Proxy sss))) instance (KnownSymbol m, KnownSymbol d, DemoteConstructorInfo c '[ x ]) @@ -188,6 +205,48 @@ demoteConstructorInfo _ = M.Record (symbolVal (Proxy :: Proxy s)) (demoteFieldInfos (Proxy :: Proxy fs)) + +class DemoteStrictnessInfoss (sss :: [[StrictnessInfo]]) (xss :: [[Type]]) where + demoteStrictnessInfoss :: proxy sss -> NP (NP M.StrictnessInfo) xss + +instance DemoteStrictnessInfoss '[] '[] where + demoteStrictnessInfoss _ = Nil + +instance + (DemoteStrictnessInfos ss xs, DemoteStrictnessInfoss sss xss) + => DemoteStrictnessInfoss (ss ': sss) (xs ': xss) where + demoteStrictnessInfoss _ = + demoteStrictnessInfos (Proxy :: Proxy ss ) + :* demoteStrictnessInfoss (Proxy :: Proxy sss) + +class DemoteStrictnessInfos (ss :: [StrictnessInfo]) (xs :: [Type]) where + demoteStrictnessInfos :: proxy ss -> NP M.StrictnessInfo xs + +instance DemoteStrictnessInfos '[] '[] where + demoteStrictnessInfos _ = Nil + +instance + (DemoteStrictnessInfo s x, DemoteStrictnessInfos ss xs) + => DemoteStrictnessInfos (s ': ss) (x ': xs) where + demoteStrictnessInfos _ = + demoteStrictnessInfo (Proxy :: Proxy s ) + :* demoteStrictnessInfos (Proxy :: Proxy ss) + +class DemoteStrictnessInfo (s :: StrictnessInfo) (x :: Type) where + demoteStrictnessInfo :: proxy s -> M.StrictnessInfo x + +instance + ( DemoteSourceUnpackedness su + , DemoteSourceStrictness ss + , DemoteDecidedStrictness ds + ) + => DemoteStrictnessInfo ('StrictnessInfo su ss ds) x where + demoteStrictnessInfo _ = + M.StrictnessInfo + (demoteSourceUnpackedness (Proxy :: Proxy su)) + (demoteSourceStrictness (Proxy :: Proxy ss)) + (demoteDecidedStrictness (Proxy :: Proxy ds)) + -- | Class for computing term-level field information from -- type-level field information. -- @@ -246,4 +305,70 @@ instance DemoteAssociativity 'NotAssociative where demoteAssociativity _ = M.NotAssociative + +-- | Class for computing term-level source unpackedness information +-- from type-level source unpackedness information. +-- +-- @since 0.4.0.0 +-- +class DemoteSourceUnpackedness (a :: SourceUnpackedness) where + -- | Given a proxy of some type-level source unpackedness information, + -- return the corresponding term-level information. + -- + -- @since 0.4.0.0 + -- + demoteSourceUnpackedness :: proxy a -> M.SourceUnpackedness + +instance DemoteSourceUnpackedness 'NoSourceUnpackedness where + demoteSourceUnpackedness _ = M.NoSourceUnpackedness + +instance DemoteSourceUnpackedness 'SourceNoUnpack where + demoteSourceUnpackedness _ = M.SourceNoUnpack + +instance DemoteSourceUnpackedness 'SourceUnpack where + demoteSourceUnpackedness _ = M.SourceUnpack + +-- | Class for computing term-level source strictness information +-- from type-level source strictness information. +-- +-- @since 0.4.0.0 +-- +class DemoteSourceStrictness (a :: SourceStrictness) where + -- | Given a proxy of some type-level source strictness information, + -- return the corresponding term-level information. + -- + -- @since 0.4.0.0 + -- + demoteSourceStrictness :: proxy a -> M.SourceStrictness + +instance DemoteSourceStrictness 'NoSourceStrictness where + demoteSourceStrictness _ = M.NoSourceStrictness + +instance DemoteSourceStrictness 'SourceLazy where + demoteSourceStrictness _ = M.SourceLazy + +instance DemoteSourceStrictness 'SourceStrict where + demoteSourceStrictness _ = M.SourceStrict + +-- | Class for computing term-level decided strictness information +-- from type-level decided strictness information. +-- +-- @since 0.4.0.0 +-- +class DemoteDecidedStrictness (a :: DecidedStrictness) where + -- | Given a proxy of some type-level source strictness information, + -- return the corresponding term-level information. + -- + -- @since 0.4.0.0 + -- + demoteDecidedStrictness :: proxy a -> M.DecidedStrictness + +instance DemoteDecidedStrictness 'DecidedLazy where + demoteDecidedStrictness _ = M.DecidedLazy + +instance DemoteDecidedStrictness 'DecidedStrict where + demoteDecidedStrictness _ = M.DecidedStrict + +instance DemoteDecidedStrictness 'DecidedUnpack where + demoteDecidedStrictness _ = M.DecidedUnpack 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 @@ -28,7 +28,7 @@ -- -- The SOP approach to generic programming is based on viewing -- datatypes as a representation ('Rep') built from the sum of --- products of its components. The components of are datatype +-- products of its components. The components of a datatype -- are specified using the 'Code' type family. -- -- The isomorphism between the original Haskell datatype and its