linear-generics 0.1.0.0 → 0.1.0.1
raw patch · 7 files changed
+170/−182 lines, 7 files
Files
- CHANGELOG.md +11/−0
- README.md +5/−3
- linear-generics.cabal +3/−2
- src/Generics/Linear/Instances/Template_haskell.hs +3/−1
- src/Generics/Linear/TH.hs +59/−104
- src/Generics/Linear/TH/Internal.hs +60/−72
- tests/DataFamilyKindsSpec.hs +29/−0
CHANGELOG.md view
@@ -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`.
README.md view
@@ -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)`.
linear-generics.cabal view
@@ -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 <https://gitlab.haskell.org/ghc/ghc/-/issues/15969 greatly improve performance>,- and it is + and it is <https://github.com/tweag/linear-base/pull/316 necessary to support multiplicity polymorphism>. A smaller change, approximately <https://gitlab.haskell.org/ghc/ghc/-/issues/7492 as proposed by spl>,@@ -103,6 +103,7 @@ type: exitcode-stdio-1.0 main-is: Spec.hs other-modules:+ DataFamilyKindsSpec DefaultSpec EmptyCaseSpec ExampleSpec
src/Generics/Linear/Instances/Template_haskell.hs view
@@ -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
src/Generics/Linear/TH.hs view
@@ -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. -}
src/Generics/Linear/TH/Internal.hs view
@@ -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.
+ tests/DataFamilyKindsSpec.hs view
@@ -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)