diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,2 +1,13 @@ +# 0.1.0.1 +* Make `Generic1` deriving properly polykinded. There was an old kind check + that has not been valid for a long time. + +* Improve error handling slightly. + +* Adjust `README`. + +* Refactor code in Generics.Linear.TH + +* Improve comments. # 0.1.0.0 * Initial fork from `generic-deriving`. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -38,9 +38,11 @@ This library is organized as follows: -* `Generics.Linear` defines the core functionality for generics, - including the multiplicity-polymorphic `Generic(1)` classes and - a replacement for the `:.:` composition type. +* `Generics.Linear` defines the core functionality for generics. This includes: + + - multiplicity polymorphic `Generic` and `Generic1` classes, + - a replacement for the `:.:` composition type, and + - an `MP1` type for nonlinear and multiplicity polymorphic fields. * `Generics.Linear.TH` implements Template Haskell functionality for deriving instances of `Generic(1)`. diff --git a/linear-generics.cabal b/linear-generics.cabal --- a/linear-generics.cabal +++ b/linear-generics.cabal @@ -1,5 +1,5 @@ name: linear-generics -version: 0.1.0.0 +version: 0.1.0.1 synopsis: Generic programming library for generalised deriving. description: This package offers a version of @@ -13,7 +13,7 @@ 2. The representations used for @Generic1@ are modified slightly. As a result, @to1@ and @from1@ never need to use @fmap@. This can , - and it is + and it is . A smaller change, approximately , @@ -103,6 +103,7 @@ type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: + DataFamilyKindsSpec DefaultSpec EmptyCaseSpec ExampleSpec diff --git a/src/Generics/Linear/Instances/Template_haskell.hs b/src/Generics/Linear/Instances/Template_haskell.hs --- a/src/Generics/Linear/Instances/Template_haskell.hs +++ b/src/Generics/Linear/Instances/Template_haskell.hs @@ -3,7 +3,9 @@ {-# options_ghc -Wno-orphans #-} -module Generics.Linear.Instances.Template_haskell where +module Generics.Linear.Instances.Template_haskell ( + -- Instances only + ) where import Generics.Linear.TH import Language.Haskell.TH import Language.Haskell.TH.Syntax diff --git a/src/Generics/Linear/TH.hs b/src/Generics/Linear/TH.hs --- a/src/Generics/Linear/TH.hs +++ b/src/Generics/Linear/TH.hs @@ -103,8 +103,6 @@ import Control.Monad ((>=>), unless, when) -import qualified Data.Map as Map - import Generics.Linear.TH.Internal import Generics.Linear.TH.MetaData import Language.Haskell.TH.Datatype @@ -157,16 +155,15 @@ -> Name -> Q [Dec] deriveInstCommon genericName repName gClass fromName toName n = do - i <- reifyDataInfo n - let (name, instTys, cons, dv) = either error id i + (name, instTys, cons, dv) <- reifyDataInfo n + let gt = mkGenericTvbs gClass instTys (origTy, origKind) <- buildTypeInstance gClass name instTys - tyInsRHS <- makeRepInline gClass dv name instTys cons origTy + tyInsRHS <- repType gt dv name cons let origSigTy = SigT origTy origKind tyIns <- tySynInstDCompat repName Nothing [return origSigTy] (return tyInsRHS) let - mkBody maker = [clause [] (normalB $ - lamCaseE [maker gClass 1 1 instTys cons]) []] + mkBody maker = [clause [] (normalB $ lamCaseE [maker gt cons]) []] fcs = mkBody mkFrom tcs = mkBody mkTo @@ -175,44 +172,24 @@ instanceD (cxt []) (conT genericName `appT` return origSigTy) [return tyIns, funD fromName fcs, funD toName tcs] -makeRepInline :: GenericClass - -> DatatypeVariant_ - -> Name - -> [Type] - -> [ConstructorInfo] - -> Type - -> Q Type -makeRepInline gClass dv name instTys cons ty = do - let instVars = freeVariablesWellScoped [ty] - (tySynVars, gk) = genericKind gClass instTys - - typeSubst :: TypeSubst - typeSubst = Map.fromList $ - zip (map tvName tySynVars) - (map (VarT . tvName) instVars) - - repType gk dv name typeSubst cons - -repType :: GenericKind +repType :: GenericTvbs -> DatatypeVariant_ -> Name - -> TypeSubst -> [ConstructorInfo] -> Q Type -repType gk dv dt typeSubst cs = +repType gt dv dt cs = conT ''D1 `appT` mkMetaDataType dv dt `appT` - foldBal sum' (conT ''V1) (map (repCon gk dv dt typeSubst) cs) + foldBal sum' (conT ''V1) (map (repCon gt dv dt) cs) where sum' :: Q Type -> Q Type -> Q Type sum' a b = conT ''(:+:) `appT` a `appT` b -repCon :: GenericKind +repCon :: GenericTvbs -> DatatypeVariant_ -> Name - -> TypeSubst -> ConstructorInfo -> Q Type -repCon gk dv dt typeSubst +repCon gt dv dt (ConstructorInfo { constructorName = n , constructorVars = vars , constructorContext = ctxt @@ -234,28 +211,27 @@ InfixConstructor -> True RecordConstructor _ -> False ssis <- reifySelStrictInfo n bangs - repConWith gk dv dt n typeSubst mbSelNames ssis ts isRecord isInfix + repConWith gt dv dt n mbSelNames ssis ts isRecord isInfix -repConWith :: GenericKind +repConWith :: GenericTvbs -> DatatypeVariant_ -> Name -> Name - -> TypeSubst -> Maybe [Name] -> [SelStrictInfo] -> [Type] -> Bool -> Bool -> Q Type -repConWith gk dv dt n typeSubst mbSelNames ssis ts isRecord isInfix = do +repConWith gt dv dt n mbSelNames ssis ts isRecord isInfix = do let structureType :: Q Type structureType = foldBal prodT (conT ''U1) f f :: [Q Type] f = case mbSelNames of - Just selNames -> zipWith3 (repField gk dv dt n typeSubst . Just) + Just selNames -> zipWith3 (repField gt dv dt n . Just) selNames ssis ts - Nothing -> zipWith (repField gk dv dt n typeSubst Nothing) + Nothing -> zipWith (repField gt dv dt n Nothing) ssis ts conT ''C1 @@ -265,26 +241,22 @@ prodT :: Q Type -> Q Type -> Q Type prodT a b = conT ''(:*:) `appT` a `appT` b -repField :: GenericKind +repField :: GenericTvbs -> DatatypeVariant_ -> Name -> Name - -> TypeSubst -> Maybe Name -> SelStrictInfo -> Type -> Q Type -repField gk dv dt ns typeSubst mbF ssi t = +repField gt dv dt ns mbF ssi t = conT ''S1 `appT` mkMetaSelType dv dt ns mbF ssi - `appT` (repFieldArg gk =<< resolveTypeSynonyms t') - where - t' :: Type - t' = applySubstitution typeSubst t + `appT` (repFieldArg gt =<< resolveTypeSynonyms t) -repFieldArg :: GenericKind -> Type -> Q Type -repFieldArg Gen0 (dustOff -> t0) = boxT t0 -repFieldArg (Gen1 name) (dustOff -> t0) = go (conT ''Par1) t0 +repFieldArg :: GenericTvbs -> Type -> Q Type +repFieldArg Gen0{} (dustOff -> t0) = boxT t0 +repFieldArg (Gen1{gen1LastTvbName = name}) (dustOff -> t0) = go (conT ''Par1) t0 where -- | Returns NoPar if the parameter doesn't appear. -- Expects its argument to have been dusted. @@ -307,29 +279,23 @@ Just (boxTyName, _, _) -> conT boxTyName Nothing -> conT ''Rec0 `appT` return ty -mkFrom :: GenericClass -> Int -> Int -> [Type] - -> [ConstructorInfo] -> Q Match -mkFrom gClass m i instTys cs = do +mkFrom :: GenericTvbs -> [ConstructorInfo] -> Q Match +mkFrom gt cs = do y <- newName "y" match (varP y) (normalB $ conE 'M1 `appE` tweakedCaseE (varE y) cases) [] where - cases = zipWith (fromCon gk wrapE (length cs)) [1..] cs - wrapE e = lrE i m e - (_, gk) = genericKind gClass instTys + cases = zipWith (fromCon gt id (length cs)) [1..] cs -mkTo :: GenericClass -> Int -> Int -> [Type] - -> [ConstructorInfo] -> Q Match -mkTo gClass m i instTys cs = do +mkTo :: GenericTvbs -> [ConstructorInfo] -> Q Match +mkTo gt cs = do y <- newName "y" match (conP 'M1 [varP y]) (normalB $ tweakedCaseE (varE y) cases) [] where - cases = zipWith (toCon gk wrapP (length cs)) [1..] cs - wrapP p = lrP i m p - (_, gk) = genericKind gClass instTys + cases = zipWith (toCon gt id (length cs)) [1..] cs tweakedCaseE :: Quote m => m Exp -> [m Match] -> m Exp #if __GLASGOW_HASKELL__ >= 901 @@ -347,9 +313,9 @@ tweakedCaseE scrut branches = lamCaseE branches `appE` scrut #endif -fromCon :: GenericKind -> (Q Exp -> Q Exp) -> Int -> Int +fromCon :: GenericTvbs -> (Q Exp -> Q Exp) -> Int -> Int -> ConstructorInfo -> Q Match -fromCon gk wrap m i +fromCon gt wrap m i (ConstructorInfo { constructorName = cn , constructorVars = vars , constructorContext = ctxt @@ -359,19 +325,19 @@ fNames <- newNameList "f" $ length ts match (conP cn (map varP fNames)) (normalB $ wrap $ lrE i m $ conE 'M1 `appE` - foldBal prodE (conE 'U1) (zipWith (fromField gk) fNames ts)) [] + foldBal prodE (conE 'U1) (zipWith (fromField gt) fNames ts)) [] prodE :: Q Exp -> Q Exp -> Q Exp prodE x y = conE '(:*:) `appE` x `appE` y -fromField :: GenericKind -> Name -> Type -> Q Exp -fromField gk nr t = conE 'M1 `appE` (fromFieldWrap gk nr =<< resolveTypeSynonyms t) +fromField :: GenericTvbs -> Name -> Type -> Q Exp +fromField gt nr t = conE 'M1 `appE` (fromFieldWrap gt nr =<< resolveTypeSynonyms t) -fromFieldWrap :: GenericKind -> Name -> Type -> Q Exp -fromFieldWrap _ _ ForallT{} = rankNError -fromFieldWrap gk nr (SigT t _) = fromFieldWrap gk nr t -fromFieldWrap Gen0 nr t = conE (boxRepName t) `appE` varE nr -fromFieldWrap (Gen1 name) nr t = wC t name `appE` varE nr +fromFieldWrap :: GenericTvbs -> Name -> Type -> Q Exp +fromFieldWrap _ _ ForallT{} = rankNError +fromFieldWrap gt nr (SigT t _) = fromFieldWrap gt nr t +fromFieldWrap Gen0{} nr t = conE (boxRepName t) `appE` varE nr +fromFieldWrap (Gen1{gen1LastTvbName = name}) nr t = wC t name `appE` varE nr wC :: Type -> Name -> Q Exp wC (dustOff -> t0) name = go (ConE 'Par1) t0 @@ -394,9 +360,9 @@ boxRepName :: Type -> Name boxRepName = maybe 'K1 snd3 . unboxedRepNames -toCon :: GenericKind -> (Q Pat -> Q Pat) -> Int -> Int +toCon :: GenericTvbs -> (Q Pat -> Q Pat) -> Int -> Int -> ConstructorInfo -> Q Match -toCon gk wrap m i +toCon gt wrap m i (ConstructorInfo { constructorName = cn , constructorVars = vars , constructorContext = ctxt @@ -405,21 +371,21 @@ checkExistentialContext cn vars ctxt fNames <- newNameList "f" $ length ts match (wrap $ lrP i m $ conP 'M1 - [foldBal prod (conP 'U1 []) (zipWith (toField gk) fNames ts)]) + [foldBal prod (conP 'U1 []) (zipWith (toField gt) fNames ts)]) (normalB $ foldl appE (conE cn) - (zipWith (\nr -> resolveTypeSynonyms >=> toConUnwC gk nr) + (zipWith (\nr -> resolveTypeSynonyms >=> toConUnwC gt nr) fNames ts)) [] where prod x y = conP '(:*:) [x,y] -toConUnwC :: GenericKind -> Name -> Type -> Q Exp -toConUnwC Gen0 nr _ = varE nr -toConUnwC (Gen1 name) nr t = unwC t name `appE` varE nr +toConUnwC :: GenericTvbs -> Name -> Type -> Q Exp +toConUnwC Gen0{} nr _ = varE nr +toConUnwC (Gen1{gen1LastTvbName = name}) nr t = unwC t name `appE` varE nr -toField :: GenericKind -> Name -> Type -> Q Pat -toField gk nr t = conP 'M1 [toFieldWrap gk nr t] +toField :: GenericTvbs -> Name -> Type -> Q Pat +toField gt nr t = conP 'M1 [toFieldWrap gt nr t] -toFieldWrap :: GenericKind -> Name -> Type -> Q Pat -toFieldWrap Gen0 nr t = conP (boxRepName t) [varP nr] +toFieldWrap :: GenericTvbs -> Name -> Type -> Q Pat +toFieldWrap Gen0{} nr t = conP (boxRepName t) [varP nr] toFieldWrap Gen1{} nr _ = varP nr unwC :: Type -> Name -> Q Exp @@ -494,16 +460,8 @@ let remainingLength :: Int remainingLength = length varTysOrig - fromEnum gClass - droppedTysExp :: [Type] - droppedTysExp = drop remainingLength varTysExp - - droppedStarKindStati :: [StarKindStatus] - droppedStarKindStati = map canRealizeKindStar droppedTysExp - - -- Check there are enough types to drop and that all of them are either of - -- kind * or kind k (for some kind variable k). If not, throw an error. - when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $ - derivingKindError tyConName + -- Check there are enough types to drop. If not, throw an error. + when (remainingLength < 0) $ derivingKindError tyConName -- Substitute kind * for any dropped kind variables let varTysExpSubst :: [Type] @@ -561,28 +519,25 @@ data instance Fam (a :: *) If we dropped the kind signature for a in a derived instance for Fam a, then GHC -would have no way of knowing which instance we are talking about. +would have no way of knowing which instance we are talking about. The +DataFamilyKindsSpec test case checks that this behaves as intended. -Another motivation for explicit kind signatures is the -XTypeInType extension. -With -XTypeInType, dropping kind signatures can completely change the meaning -of some data types. For example, there is a substantial difference between these -two data types: +In addition to using explicit kind signatures in the instance head, we also put +explicit kinds in the associated Rep(1) instance. For example, this data type: - data T k (a :: k) = T k - data T k a = T k + data S (a :: k) = S k -In addition to using explicit kind signatures on type variables, we also put -explicit kinds in the instance head, so generated instances will look -something like this: +Will have the following Generic1 instance generated for it: - data S (a :: k) = S k instance Generic1 (S :: k -> *) where type Rep1 (S :: k -> *) = ... (Rec0 k) -Why do we do this? Imagine what the instance would be without the explicit return kind: +Why do we do this? Imagine what the instance would be without the explicit kind +annotation in the Rep1 instance: instance Generic1 S where type Rep1 S = ... (Rec0 k) -This is an error, since the variable k is now out-of-scope! +This is an error, since the variable k is now out-of-scope! The TypeInTypeSpec +test case checks that this behaves as intended. -} diff --git a/src/Generics/Linear/TH/Internal.hs b/src/Generics/Linear/TH/Internal.hs --- a/src/Generics/Linear/TH/Internal.hs +++ b/src/Generics/Linear/TH/Internal.hs @@ -19,7 +19,6 @@ import Data.Foldable (foldr') import qualified Data.List as List -import Data.Map as Map (Map) import qualified Data.Set as Set import Data.Set (Set) @@ -30,44 +29,6 @@ import Language.Haskell.TH.Syntax ------------------------------------------------------------------------------- --- Expanding type synonyms -------------------------------------------------------------------------------- - -type TypeSubst = Map Name Type - -------------------------------------------------------------------------------- --- StarKindStatus -------------------------------------------------------------------------------- - --- | Whether a type is not of kind *, is of kind *, or is a kind variable. -data StarKindStatus = NotKindStar - | MaybeKindStar - deriving Eq - --- | Can a type possibly have kind *? This is a really rough guess, --- because there are lots of ways for it to happen. -canRealizeKindStar :: Type -> StarKindStatus -canRealizeKindStar = \case - VarT{} -> MaybeKindStar - SigT _ StarT -> MaybeKindStar - ParensT t -> canRealizeKindStar t - SigT _ (VarT _) -> MaybeKindStar - SigT _ k -> canMakeStar k - _ -> MaybeKindStar - --- | Can a kind be *? -canMakeStar :: Kind -> StarKindStatus -canMakeStar = \case - ParensT t -> canMakeStar t - AppT k _ -> canMakeStar k - StarT -> MaybeKindStar - TupleT _ -> NotKindStar - UnboxedTupleT _ -> NotKindStar - ArrowT -> NotKindStar - ListT -> NotKindStar - _ -> MaybeKindStar - -------------------------------------------------------------------------------- -- Assorted utilities ------------------------------------------------------------------------------- @@ -249,19 +210,35 @@ -- | Indicates whether Generic or Generic1 is being derived. data GenericClass = Generic | Generic1 deriving Enum --- | Like 'GenericClass', but in the 'Gen1' case bundling the --- 'Name' of the last type parameter. -data GenericKind = Gen0 - | Gen1 Name +-- | Records information about the type variables of a data type with a +-- 'Generic' or 'Generic1' instance. +data GenericTvbs + -- | Information about a data type with a 'Generic' instance. + = Gen0 + { gen0Tvbs :: [TyVarBndrUnit] + -- ^ All of the type variable arguments to the data type. + } + -- | Information about a data type with a 'Generic1' instance. + | Gen1 + { gen1InitTvbs :: [TyVarBndrUnit] + -- ^ All of the type variable arguments to the data type except the + -- last one. In a @'Generic1' (T a_1 ... a_(n-1))@ instance, the + -- 'gen1InitTvbs' would be @[a_1, ..., a_(n-1)]@. + , gen1LastTvbName :: Name + -- ^ The name of the last type variable argument to the data type. + -- In a @'Generic1' (T a_1 ... a_(n-1))@ instance, the + -- 'gen1LastTvbName' name would be @a_n@. + } --- Determines the universally quantified type variables (possibly after --- substituting * in the case of Generic1) and the last type parameter name --- (if there is one). -genericKind :: GenericClass -> [Type] -> ([TyVarBndrUnit], GenericKind) -genericKind gClass tySynVars = +-- | Compute 'GenericTvbs' from a 'GenericClass' and the type variable +-- arguments to a data type. +mkGenericTvbs :: GenericClass -> [Type] -> GenericTvbs +mkGenericTvbs gClass tySynVars = case gClass of - Generic -> (freeVariablesWellScoped tySynVars, Gen0) - Generic1 -> (freeVariablesWellScoped initArgs, Gen1 (varTToName lastArg)) + Generic -> Gen0{gen0Tvbs = freeVariablesWellScoped tySynVars} + Generic1 -> Gen1{ gen1InitTvbs = freeVariablesWellScoped initArgs + , gen1LastTvbName = varTToName lastArg + } where -- Everything below is only used for Generic1. initArgs :: [Type] @@ -270,6 +247,14 @@ lastArg :: Type lastArg = last tySynVars +-- | Return the type variable arguments to a data type that appear in a +-- 'Generic' or 'Generic1' instance. For a 'Generic' instance, this consists of +-- all the type variable arguments. For a 'Generic1' instance, this consists of +-- all the type variable arguments except for the last one. +genericInitTvbs :: GenericTvbs -> [TyVarBndrUnit] +genericInitTvbs (Gen0{gen0Tvbs = tvbs}) = tvbs +genericInitTvbs (Gen1{gen1InitTvbs = tvbs}) = tvbs + -- | A version of 'DatatypeVariant' in which the data family instance -- constructors come equipped with the 'ConstructorInfo' of the first -- constructor in the family instance (for 'Name' generation purposes). @@ -295,7 +280,7 @@ ( showString (nameBase tyConName) . showString " ..." ) - . showString "‘\n\tClass Generic1 expects an argument of kind * -> *" + . showString "‘\n\tClass Generic1 expects an argument of kind k -> Type" $ "" -- | The data type mentions the last type variable in a place other @@ -328,34 +313,37 @@ -- -- Any other value will result in an exception. reifyDataInfo :: Name - -> Q (Either String (Name, [Type], [ConstructorInfo], DatatypeVariant_)) + -> Q (Name, [Type], [ConstructorInfo], DatatypeVariant_) reifyDataInfo name = do - return $ Left $ ns ++ " Could not reify " ++ nameBase name - `recover` - do DatatypeInfo { datatypeContext = ctxt - , datatypeName = parentName - , datatypeInstTypes = tys - , datatypeVariant = variant - , datatypeCons = cons - } <- reifyDatatype name - let variant_ = case variant of - Datatype -> Datatype_ - Newtype -> Newtype_ - -- This isn't total, but the API requires that the data - -- family instance have at least one constructor anyways, - -- so this will always succeed. - DataInstance -> DataInstance_ $ head cons - NewtypeInstance -> NewtypeInstance_ $ head cons - checkDataContext parentName ctxt $ Right (parentName, tys, cons, variant_) + do + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeInstTypes = tys + , datatypeVariant = variant + , datatypeCons = cons + } <- + fail (ns ++ " Could not reify " ++ nameBase name) + `recover` + reifyDatatype name + let variant_ = case variant of + Datatype -> Datatype_ + Newtype -> Newtype_ + -- This isn't total, but the API requires that the data + -- family instance have at least one constructor anyways, + -- so this will always succeed. + DataInstance -> DataInstance_ $ head cons + NewtypeInstance -> NewtypeInstance_ $ head cons + checkDataContext parentName ctxt + pure (parentName, tys, cons, variant_) where ns :: String ns = "Generics.Linear.TH.reifyDataInfo: " -- | One cannot derive Generic(1) instance for anything that uses DatatypeContexts, -- so check to make sure the Cxt field of a datatype is null. -checkDataContext :: Name -> Cxt -> a -> Q a -checkDataContext _ [] x = return x -checkDataContext dataName _ _ = fail $ +checkDataContext :: Name -> Cxt -> Q () +checkDataContext _ [] = pure () +checkDataContext dataName _ = fail $ nameBase dataName ++ " must not have a datatype context" -- | Deriving Generic(1) doesn't work with ExistentialQuantification or GADTs. diff --git a/tests/DataFamilyKindsSpec.hs b/tests/DataFamilyKindsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/DataFamilyKindsSpec.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +-- | A test case which ensures that generated Generic instances are able to +-- distinguish data family instances which only differ in their kinds. See +-- https://github.com/linear-generics/linear-generics/issues/8#issuecomment-940512978 +module DataFamilyKindsSpec (main, spec) where + +import Data.Kind (Type) +import Generics.Linear.TH (deriveGeneric) +import Test.Hspec (Spec, hspec) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = pure () + +type Fam :: k -> Type +data family Fam a + +data instance Fam (a :: Type -> Type) = Fam1 +data instance Fam (a :: Type) = Fam2 + +$(deriveGeneric 'Fam1) +$(deriveGeneric 'Fam2)