diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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`. 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.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 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 @@ -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_ 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 @@ -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 diff --git a/src/Generics/Linear/Unsafe/ViaGHCGenerics.hs b/src/Generics/Linear/Unsafe/ViaGHCGenerics.hs --- a/src/Generics/Linear/Unsafe/ViaGHCGenerics.hs +++ b/src/Generics/Linear/Unsafe/ViaGHCGenerics.hs @@ -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