diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,14 @@ +# 0.5 [2017.12.07] +* `Data.Functor.Invariant.TH` now derives `invmap(2)` implementations for empty + data types that are strict in the argument. +* When using `Data.Functor.Invariant.TH` to derive `Invariant(2)` instances for + data types where the last type variables are at phantom roles, generated + `invmap(2)` implementations now use `coerce` for efficiency. +* Add `Options` to `Data.Functor.Invariant.TH`, along with variants of existing + functions that take `Options` as an argument. For now, the only configurable + option is whether derived instances for empty data types should use the + `EmptyCase` extension (this is disabled by default). + # 0.4.3 [2017.07.31] * Add `Invariant(2)` instances for `Data.Profunctor.Yoneda.Yoneda`. diff --git a/invariant.cabal b/invariant.cabal --- a/invariant.cabal +++ b/invariant.cabal @@ -1,5 +1,5 @@ name: invariant -version: 0.4.3 +version: 0.5 synopsis: Haskell98 invariant functors description: Haskell98 invariant functors (also known as exponential functors). . @@ -23,7 +23,7 @@ , GHC == 7.8.4 , GHC == 7.10.3 , GHC == 8.0.2 - , GHC == 8.2.1 + , GHC == 8.2.2 extra-source-files: CHANGELOG.md, README.md source-repository head diff --git a/src/Data/Functor/Invariant/TH.hs b/src/Data/Functor/Invariant/TH.hs --- a/src/Data/Functor/Invariant/TH.hs +++ b/src/Data/Functor/Invariant/TH.hs @@ -15,12 +15,19 @@ -- * @deriveInvariant(2)@ -- $deriveInvariant deriveInvariant + , deriveInvariantOptions -- $deriveInvariant2 , deriveInvariant2 + , deriveInvariant2Options -- * @makeInvmap(2)@ -- $make , makeInvmap + , makeInvmapOptions , makeInvmap2 + , makeInvmap2Options + -- * 'Options' + , Options(..) + , defaultOptions ) where import Control.Monad (unless, when) @@ -39,6 +46,22 @@ -- User-facing API ------------------------------------------------------------------------------- +-- | Options that further configure how the functions in +-- "Data.Functor.Invariant.TH" should behave. +newtype Options = Options + { emptyCaseBehavior :: Bool + -- ^ If 'True', derived instances for empty data types (i.e., ones with + -- no data constructors) will use the @EmptyCase@ language extension. + -- If 'False', derived instances will simply use 'seq' instead. + -- (This has no effect on GHCs before 7.8, since @EmptyCase@ is only + -- available in 7.8 or later.) + } deriving (Eq, Ord, Read, Show) + +-- | Conservative 'Options' that doesn't attempt to use @EmptyCase@ (to +-- prevent users from having to enable that extension at use sites.) +defaultOptions :: Options +defaultOptions = Options { emptyCaseBehavior = False } + {- $deriveInvariant 'deriveInvariant' automatically generates an 'Invariant' instance declaration for a @@ -115,8 +138,12 @@ -- | Generates an 'Invariant' instance declaration for the given data type or data -- family instance. deriveInvariant :: Name -> Q [Dec] -deriveInvariant = deriveInvariantClass Invariant +deriveInvariant = deriveInvariantOptions defaultOptions +-- | Like 'deriveInvariant', but takes an 'Options' argument. +deriveInvariantOptions :: Options -> Name -> Q [Dec] +deriveInvariantOptions = deriveInvariantClass Invariant + {- $deriveInvariant2 'deriveInvariant2' automatically generates an 'Invariant2' instance declaration for @@ -171,8 +198,12 @@ -- | Generates an 'Invariant2' instance declaration for the given data type or data -- family instance. deriveInvariant2 :: Name -> Q [Dec] -deriveInvariant2 = deriveInvariantClass Invariant2 +deriveInvariant2 = deriveInvariant2Options defaultOptions +-- | Like 'deriveInvariant2', but takes an 'Options' argument. +deriveInvariant2Options :: Options -> Name -> Q [Dec] +deriveInvariant2Options = deriveInvariantClass Invariant2 + {- $make There may be scenarios in which you want to @invmap@ over an arbitrary data type or @@ -202,21 +233,29 @@ -- | Generates a lambda expression which behaves like 'invmap' (without requiring an -- 'Invariant' instance). makeInvmap :: Name -> Q Exp -makeInvmap = makeInvmapClass Invariant +makeInvmap = makeInvmapOptions defaultOptions +-- | Like 'makeInvmap', but takes an 'Options' argument. +makeInvmapOptions :: Options -> Name -> Q Exp +makeInvmapOptions = makeInvmapClass Invariant + -- | Generates a lambda expression which behaves like 'invmap2' (without requiring an -- 'Invariant2' instance). makeInvmap2 :: Name -> Q Exp -makeInvmap2 = makeInvmapClass Invariant2 +makeInvmap2 = makeInvmap2Options defaultOptions +-- | Like 'makeInvmap2', but takes an 'Options' argument. +makeInvmap2Options :: Options -> Name -> Q Exp +makeInvmap2Options = makeInvmapClass Invariant2 + ------------------------------------------------------------------------------- -- Code generation ------------------------------------------------------------------------------- -- | Derive an Invariant(2) instance declaration (depending on the InvariantClass -- argument's value). -deriveInvariantClass :: InvariantClass -> Name -> Q [Dec] -deriveInvariantClass iClass name = do +deriveInvariantClass :: InvariantClass -> Options -> Name -> Q [Dec] +deriveInvariantClass iClass opts name = do info <- reifyDatatype name case info of DatatypeInfo { datatypeContext = ctxt @@ -229,23 +268,24 @@ <- buildTypeInstance iClass parentName ctxt vars variant (:[]) `fmap` instanceD (return instanceCxt) (return instanceType) - (invmapDecs iClass vars cons) + (invmapDecs iClass opts parentName vars cons) -- | Generates a declaration defining the primary function corresponding to a -- particular class (invmap for Invariant and invmap2 for Invariant2). -invmapDecs :: InvariantClass -> [Type] -> [ConstructorInfo] -> [Q Dec] -invmapDecs iClass vars cons = +invmapDecs :: InvariantClass -> Options -> Name -> [Type] -> [ConstructorInfo] + -> [Q Dec] +invmapDecs iClass opts parentName vars cons = [ funD (invmapName iClass) [ clause [] - (normalB $ makeInvmapForCons iClass vars cons) + (normalB $ makeInvmapForCons iClass opts parentName vars cons) [] ] ] -- | Generates a lambda expression which behaves like invmap (for Invariant), -- or invmap2 (for Invariant2). -makeInvmapClass :: InvariantClass -> Name -> Q Exp -makeInvmapClass iClass name = do +makeInvmapClass :: InvariantClass -> Options -> Name -> Q Exp +makeInvmapClass iClass opts name = do info <- reifyDatatype name case info of DatatypeInfo { datatypeContext = ctxt @@ -258,14 +298,13 @@ -- or not the provided datatype can actually have invmap/invmap2 -- implemented for it, and produces errors if it can't. buildTypeInstance iClass parentName ctxt vars variant - `seq` makeInvmapForCons iClass vars cons + >> makeInvmapForCons iClass opts parentName vars cons -- | Generates a lambda expression for invmap(2) for the given constructors. -- All constructors must be from the same type. -makeInvmapForCons :: InvariantClass -> [Type] -> [ConstructorInfo] -> Q Exp -makeInvmapForCons iClass vars cons = do - let numNbs = fromEnum iClass - +makeInvmapForCons :: InvariantClass -> Options -> Name -> [Type] -> [ConstructorInfo] + -> Q Exp +makeInvmapForCons iClass opts _parentName vars cons = do value <- newName "value" covMaps <- newNameList "covMap" numNbs contraMaps <- newNameList "contraMap" numNbs @@ -277,13 +316,46 @@ lamE (map varP argNames) . appsE $ [ varE $ invmapConstName iClass - , if null cons - then appE (varE errorValName) - (stringE $ "Void " ++ nameBase (invmapName iClass)) - else caseE (varE value) - (map (makeInvmapForCon iClass tvMap) cons) + , makeFun value tvMap ] ++ map varE argNames + where + numNbs :: Int + numNbs = fromEnum iClass + makeFun :: Name -> TyVarMap -> Q Exp + makeFun value tvMap = do +#if MIN_VERSION_template_haskell(2,9,0) + roles <- reifyRoles _parentName + let rroles = roles +#endif + case () of + _ + +#if MIN_VERSION_template_haskell(2,9,0) + | (length rroles >= numNbs) && + (all (== PhantomR) (take numNbs rroles)) + -> varE coerceValName `appE` varE value +#endif + + | null cons && emptyCaseBehavior opts && ghc7'8OrLater + -> caseE (varE value) [] + + | null cons + -> appE (varE seqValName) (varE value) `appE` + appE (varE errorValName) + (stringE $ "Void " ++ nameBase (invmapName iClass)) + + | otherwise + -> caseE (varE value) + (map (makeInvmapForCon iClass tvMap) cons) + + ghc7'8OrLater :: Bool +#if __GLASGOW_HASKELL__ >= 708 + ghc7'8OrLater = True +#else + ghc7'8OrLater = False +#endif + -- | Generates a lambda expression for invmap(2) for a single constructor. makeInvmapForCon :: InvariantClass -> TyVarMap -> ConstructorInfo -> Q Match makeInvmapForCon iClass tvMap @@ -550,54 +622,75 @@ {- Note [Kind signatures in derived instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + It is possible to put explicit kind signatures into the derived instances, e.g., + instance C a => C (Data (f :: * -> *)) where ... + But it is preferable to avoid this if possible. If we come up with an incorrect kind signature (which is entirely possible, since our type inferencer is pretty unsophisticated - see Note [Type inference in derived instances]), then GHC will flat-out reject the instance, which is quite unfortunate. + Plain old datatypes have the advantage that you can avoid using any kind signatures at all in their instances. This is because a datatype declaration uses all type variables, so the types that we use in a derived instance uniquely determine their kinds. As long as we plug in the right types, the kind inferencer can do the rest of the work. For this reason, we use unSigT to remove all kind signatures before splicing in the instance context and head. + Data family instances are trickier, since a data family can have two instances that are distinguished by kind alone, e.g., + data family Fam (a :: k) data instance Fam (a :: * -> *) data instance Fam (a :: *) + If we dropped the kind signatures for C (Fam a), then GHC will have no way of knowing which instance we are talking about. To avoid this scenario, we always include explicit kind signatures in data family instances. There is a chance that the inferred kind signatures will be incorrect, but if so, we can always fall back on the make- functions. + Note [Type inference in derived instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Type inference is can be tricky to get right, and we want to avoid recreating the entirety of GHC's type inferencer in Template Haskell. For this reason, we will probably never come up with derived instance contexts that are as accurate as GHC's. But that doesn't mean we can't do anything! There are a couple of simple things we can do to make instance contexts that work for 80% of use cases: + 1. If one of the last type parameters is polykinded, then its kind will be specialized to * in the derived instance. We note what kind variable the type parameter had and substitute it with * in the other types as well. For example, imagine you had + data Data (a :: k) (b :: k) (c :: k) + Then you'd want to derived instance to be: + instance C (Data (a :: *)) + Not: + instance C (Data (a :: k)) + 2. We naïvely come up with instance constraints using the following criteria: + (i) If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind variables), then generate an Invariant n constraint, and if k1/k2 are kind variables, then substitute k1/k2 with * elsewhere in the types. We must consider the case where they are kind variables because you might have a scenario like this: + newtype Compose (f :: k3 -> *) (g :: k1 -> k2 -> k3) (a :: k1) (b :: k2) = Compose (f (g a b)) + Which would have a derived Invariant2 instance of: + instance (Invariant f, Invariant2 g) => Invariant2 (Compose f g) where ... + (ii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are * or kind variables), then generate a Invariant2 n constraint and perform kind substitution as in the other case. diff --git a/src/Data/Functor/Invariant/TH/Internal.hs b/src/Data/Functor/Invariant/TH/Internal.hs --- a/src/Data/Functor/Invariant/TH/Internal.hs +++ b/src/Data/Functor/Invariant/TH/Internal.hs @@ -390,8 +390,14 @@ invmap2ConstValName :: Name invmap2ConstValName = mkInvariantName_v "Data.Functor.Invariant.TH.Internal" "invmap2Const" +coerceValName :: Name +coerceValName = mkNameG_v "ghc-prim" "GHC.Prim" "coerce" + errorValName :: Name errorValName = mkNameG_v "base" "GHC.Err" "error" + +seqValName :: Name +seqValName = mkNameG_v "ghc-prim" "GHC.Prim" "seq" #if MIN_VERSION_base(4,6,0) && !(MIN_VERSION_base(4,9,0)) starKindName :: Name diff --git a/test/THSpec.hs b/test/THSpec.hs --- a/test/THSpec.hs +++ b/test/THSpec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -6,6 +7,11 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE RoleAnnotations #-} +#endif + {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} #if __GLASGOW_HASKELL__ >= 800 @@ -61,6 +67,12 @@ type IntFun a b = b -> a data IntFunD a b = IntFunD (IntFun a b) +data Empty1 a b +data Empty2 a b +#if __GLASGOW_HASKELL__ >= 708 +type role Empty2 nominal nominal +#endif + -- Data families data family StrangeFam a b c @@ -132,6 +144,13 @@ $(deriveInvariant ''IntFunD) $(deriveInvariant2 ''IntFunD) + +$(deriveInvariant ''Empty1) +$(deriveInvariant2 ''Empty1) + +-- Use EmptyCase here +$(deriveInvariantOptions defaultOptions{emptyCaseBehavior = True} ''Empty2) +$(deriveInvariant2Options defaultOptions{emptyCaseBehavior = True} ''Empty2) #if MIN_VERSION_template_haskell(2,7,0) -- Data Families