linear-generics 0.2.1 → 0.2.2
raw patch · 5 files changed
+119/−24 lines, 5 filesdep ~basedep ~template-haskelldep ~th-abstraction
Dependency ranges changed: base, template-haskell, th-abstraction
Files
- CHANGELOG.md +8/−0
- linear-generics.cabal +12/−6
- src/Generics/Linear/TH.hs +22/−1
- src/Generics/Linear/TH/Internal.hs +7/−6
- src/Generics/Linear/Unsafe/ViaGHCGenerics.hs +70/−11
CHANGELOG.md view
@@ -1,3 +1,11 @@+# 0.2.2+* Produce an orderly error message if someone gives us `type data`.+* Produce an error message much more eagerly when someone tries to+ use `GHCGenerically1` with an improperly shaped type.+* Place `INLINE [1]` pragmas on `from` and `to` implementations when types+ don't have too many constructors or fields, following the heuristics GHC+ has used for `Generic` deriving since version 9.2.+ # 0.2.1 * Add a `Generic` instance for `Data.Void.Void`.
linear-generics.cabal view
@@ -1,5 +1,5 @@ name: linear-generics-version: 0.2.1+version: 0.2.2 synopsis: Generic programming library for generalised deriving. description: This package offers a version of@@ -22,6 +22,12 @@ . For more details, see the "Generics.Linear" documentation. .+ The implementation is based on the @generic-deriving@ package, first described in the paper+ .+ * /A generic deriving mechanism for Haskell/.+ Jose Pedro Magalhaes, Atze Dijkstra, Johan Jeuring, and Andres Loeh.+ Haskell'10.+ . This library is organized as follows: . * "Generics.Linear" defines the core functionality for generics,@@ -60,7 +66,7 @@ build-type: Simple cabal-version: >= 1.10 tested-with: GHC == 9.0.2- , GHC == 9.2.6+ , GHC == 9.2.7 , GHC == 9.4.4 , GHC == 9.6.1 extra-source-files: CHANGELOG.md@@ -92,8 +98,8 @@ build-depends: base >= 4.15 && < 5 , containers >= 0.5.9 && < 0.7 , ghc-prim < 1- , template-haskell >= 2.16 && < 2.20- , th-abstraction >= 0.4 && < 0.5+ , template-haskell >= 2.16 && < 2.21+ , th-abstraction >= 0.5 && < 0.6 default-language: Haskell2010 default-extensions: KindSignatures@@ -127,10 +133,10 @@ Generics.Deriving.Traversable Generics.Deriving.TraversableConf Generics.Deriving.Uniplate- build-depends: base >= 4.15 && < 5+ build-depends: base , linear-generics , hspec >= 2 && < 3- , template-haskell >= 2.16 && < 2.20+ , template-haskell build-tool-depends: hspec-discover:hspec-discover hs-source-dirs: tests default-language: Haskell2010
src/Generics/Linear/TH.hs view
@@ -168,9 +168,30 @@ fcs = mkBody mkFrom tcs = mkBody mkTo + inline_pragmas+ | inlining_useful cons+ = map (\fun_name -> pragInlD fun_name Inline FunLike (FromPhase 1)) [fromName, toName]+ | otherwise+ = [] fmap (:[]) $ instanceD (cxt []) (conT genericName `appT` return origSigTy)- [return tyIns, funD fromName fcs, funD toName tcs]+ (inline_pragmas ++ [return tyIns, funD fromName fcs, funD toName tcs])++ where+ -- Adapted from inlining_useful in GHC.Tc.Deriv.Generics.mkBindsRep in the GHC+ -- source code:+ --+ -- https://gitlab.haskell.org/ghc/ghc/-/blob/80729d96e47c99dc38e83612dfcfe01cf565eac0/compiler/GHC/Tc/Deriv/Generics.hs#L368-386+ inlining_useful cons+ | ncons <= 1 = True+ | ncons <= 4 = max_fields <= 5+ | ncons <= 8 = max_fields <= 2+ | ncons <= 16 = max_fields <= 1+ | ncons <= 24 = max_fields == 0+ | otherwise = False+ where+ ncons = length cons+ max_fields = maximum $ map (length . constructorFields) cons repType :: GenericTvbs -> DatatypeVariant_
src/Generics/Linear/TH/Internal.hs view
@@ -26,7 +26,7 @@ import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Lib import Language.Haskell.TH.Ppr (pprint)-import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Syntax hiding (Extension (..)) ------------------------------------------------------------------------------- -- Assorted utilities@@ -325,14 +325,15 @@ fail (ns ++ " Could not reify " ++ nameBase name) `recover` reifyDatatype name- let variant_ = case variant of- Datatype -> Datatype_- Newtype -> Newtype_+ variant_ <- case variant of+ Datatype -> pure Datatype_+ Newtype -> pure 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+ DataInstance -> pure $ DataInstance_ (head cons)+ NewtypeInstance -> pure $ NewtypeInstance_ (head cons)+ TypeData -> fail $ "Cannot derive Generic instances for TypeData " ++ nameBase name checkDataContext parentName ctxt pure (parentName, tys, cons, variant_) where
src/Generics/Linear/Unsafe/ViaGHCGenerics.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-}@@ -31,7 +32,8 @@ , GHCGenerically1(..) ) where import Data.Coerce (Coercible, coerce)-import Data.Kind (Type)+import Data.Kind (Constraint, Type)+import Data.Type.Bool (type (&&)) import Generics.Linear import qualified GHC.Generics as G import Unsafe.Coerce@@ -122,8 +124,10 @@ newtype GHCGenerically1 f a = GHCGenerically1 { unGHCGenerically1 :: f a } instance forall k (f :: k -> Type).- (forall (a :: k). G.Generic (f a)) => Generic1 (GHCGenerically1 f) where- type Rep1 (GHCGenerically1 (f :: k -> Type)) = MakeRep1 @k (G.Rep ((MarkOtherPars f) (LastPar :: k)))+ ( forall (a :: k). G.Generic (f a)+ , CheckValid f+ ) => Generic1 (GHCGenerically1 f) where+ type Rep1 (GHCGenerically1 (f :: k -> Type)) = MakeRep1 @k (MarkedRep f) -- Why do we use unsafeCoerce here? While @G.Rep (f a)@ and @Rep1 f a@ are -- the same in memory, they're not (generally) Coercible. This largely has to@@ -149,9 +153,31 @@ -- This marking technique is inspired by Csongor Kiss's `GenericN`, part of his -- generic-lens package family. -data family LastPar :: k-data family OtherPar :: k -> k+data LastMarkT = LastMark+data OtherMarkT = OtherMark+type family LastPar :: LastMarkT -> k+type family OtherPar :: OtherMarkT -> k -> k +-- | Check whether a type is suitable for a `Generic1` instance, using its+-- `GHC.Generics.Generic` representation. We used to just throw `TypeError`s in+-- the `Rep1` calculation. But that meant that type errors occurred only at use+-- sites. Indeed, the situation was even worse than that: a representation+-- could actually be constructed and (partially) explored when some of its+-- contents had `TypeError` types. Yuck.+type CheckValid :: forall k. (k -> Type) -> Constraint+type CheckValid (f :: k -> Type) = CheckValid' f (ValidRep1 (MarkedRep f))++type MarkedRep :: forall k. (k -> Type) -> Type -> Type+type MarkedRep (f :: k -> Type) = G.Rep ((MarkOtherPars f) (LastPar 'LastMark :: k))++type CheckValid' :: forall k. (k -> Type) -> Bool -> Constraint+type family CheckValid' f valid where+ CheckValid' _ 'True = ()+ CheckValid' f 'False = TypeError+ ('Text "Cannot create Generic1 instance for" ':$$:+ 'ShowType f ':$$:+ 'Text "the last parameter appears in an invalid location.")+ type MakeRep1 :: forall k. (Type -> Type) -> k -> Type type family MakeRep1 (rep :: Type -> Type) :: k -> Type where MakeRep1 (M1 i c f) = M1 i c (MakeRep1 f)@@ -161,23 +187,56 @@ MakeRep1 V1 = V1 MakeRep1 (Rec0 c) = MakeRep1Field (Rec0 (Unmark c)) Par1 c +-- This follows the structure of MakeRep1+type ValidRep1 :: (Type -> Type) -> Bool+type family ValidRep1 rep where+ ValidRep1 (M1 _ _ f) = ValidRep1 f+ ValidRep1 (x :+: y) = ValidRep1 x && ValidRep1 y+ ValidRep1 (x :*: y) = ValidRep1 x && ValidRep1 y+ ValidRep1 U1 = 'True+ ValidRep1 V1 = 'True+ ValidRep1 (Rec0 c) = ValidRep1Field c+ type MarkOtherPars :: forall k. k -> k type family MarkOtherPars (f :: k) :: k where- MarkOtherPars ((f :: j -> k) (a :: j)) = MarkOtherPars f (OtherPar a)+ MarkOtherPars ((f :: j -> k) (a :: j)) = MarkOtherPars f (OtherPar 'OtherMark a) MarkOtherPars f = f type Unmark :: forall k. k -> k-type family Unmark (f :: k) :: k where- Unmark LastPar = TypeError ('Text "Cannot create Generic1 instance: the last parameter appears in an invalid location.")- Unmark (OtherPar a) = a+type family Unmark f where+ -- We let the erroneous 'LastMark case get stuck; that's handled in the+ -- checker and we don't want redundant (and less informative) error+ -- messages.+ Unmark (_LastPar 'LastMark) = Stuck+ Unmark (_OtherPar 'OtherMark a) = a Unmark ((f :: j -> k) (a :: j)) = Unmark f (Unmark a) Unmark a = a +type Stuck :: forall k. k+type family Stuck where++-- Verify that the last parameter does not occur. This follows the structure+-- of Unmark+type NoLast :: forall k. k -> Bool+type family NoLast f where+ NoLast (_LastPar 'LastMark) = 'False+ NoLast (_OtherPar 'OtherMark a) = 'True+ NoLast ((f :: j -> k) (a :: j)) = NoLast f && NoLast a+ NoLast _ = 'True+ type MakeRep1Field :: forall j k. (k -> Type) -> (j -> Type) -> j -> k -> Type type family MakeRep1Field fk acc c where -- Watch out! Order matters here. The third clause will match -- OtherPar _ as well, and that's no good.- MakeRep1Field fk (acc :: k -> Type) (LastPar :: k) = acc- MakeRep1Field fk (_ :: b -> Type) (OtherPar _) = fk+ MakeRep1Field fk (acc :: k -> Type) (_LastPar 'LastMark :: k) = acc+ MakeRep1Field fk (_ :: b -> Type) (_OtherPar 'OtherMark _) = fk MakeRep1Field fk (acc :: b -> Type) ((f :: a -> b) (x :: a)) = MakeRep1Field fk (acc :.: Unmark f) x MakeRep1Field fk _ _ = fk++-- This follows the structure of MakeRep1Field+type ValidRep1Field :: forall k. k -> Bool+type family ValidRep1Field c where+ ValidRep1Field (_LastPar 'LastMark :: k) = 'True+ ValidRep1Field (_OtherPar 'OtherMark _) = 'True+ ValidRep1Field ((f :: a -> b) (x :: a)) = NoLast f && ValidRep1Field x+ ValidRep1Field _ = 'True