invariant-0.2.1: src/Data/Functor/Invariant/TH.hs
{-# LANGUAGE CPP #-}
{-|
Module: Data.Functor.Invariant.TH
Copyright: (C) 2012-2015 Nicolas Frisby, (C) 2015 Ryan Scott
License: BSD-style (see the file LICENSE)
Maintainer: Ryan Scott
Portability: Template Haskell
Functions to mechanically derive 'Invariant' or 'Invariant2' instances,
or to splice 'invmap' or 'invmap2' into Haskell source code. You need to enable
the @TemplateHaskell@ language extension in order to use this module.
-}
module Data.Functor.Invariant.TH (
-- * @deriveInvariant(2)@
-- $deriveInvariant
deriveInvariant
-- $deriveInvariant2
, deriveInvariant2
-- * @makeInvmap(2)@
-- $make
, makeInvmap
, makeInvmap2
) where
import Data.Functor.Invariant.TH.Internal
import Data.List
#if __GLASGOW_HASKELL__ < 710 && MIN_VERSION_template_haskell(2,8,0)
import qualified Data.Set as Set
#endif
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Ppr
import Language.Haskell.TH.Syntax
-------------------------------------------------------------------------------
-- User-facing API
-------------------------------------------------------------------------------
{- $deriveInvariant
'deriveInvariant' automatically generates an 'Invariant' instance declaration for a
data type, newtype, or data family instance that has at least one type variable.
This emulates what would (hypothetically) happen if you could attach a @deriving
'Invariant'@ clause to the end of a data declaration. Examples:
@
{-# LANGUAGE TemplateHaskell #-}
import Data.Functor.Invariant.TH
data Pair a = Pair a a
$('deriveInvariant' ''Pair) -- instance Invariant Pair where ...
newtype Alt f a = Alt (f a)
$('deriveInvariant' ''Alt) -- instance Invariant f => Invariant (Alt f) where ...
@
If you are using @template-haskell-2.7.0.0@ or later (i.e., GHC 7.4 or later),
'deriveInvariant' can also be used to derive 'Invariant' instances for data family
instances (which requires the @-XTypeFamilies@ extension). To do so, pass the name of
a data or newtype instance constructor to 'deriveInvariant'. Note that the generated
code may require the @-XFlexibleInstances@ extension. Some examples:
@
{-# LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies #-}
import Data.Functor.Invariant.TH
class AssocClass a b where
data AssocData a b
instance AssocClass Int b where
data AssocData Int b = AssocDataInt1 Int | AssocDataInt2 b Int
$('deriveInvariant' 'AssocDataInt1) -- instance Invariant (AssocData Int) where ...
-- Alternatively, one could use $(deriveInvariant 'AssocDataInt2)
data family DataFam a b
newtype instance DataFam () b = DataFamB b
$('deriveInvariant' 'DataFamB) -- instance Invariant (DataFam ())
@
Note that there are some limitations:
* The 'Name' argument to 'deriveInvariant' must not be a type synonym.
* With 'deriveInvariant', the argument's last type variable must be of kind @*@.
For other ones, type variables of kind @* -> *@ are assumed to require an 'Invariant'
context. For more complicated scenarios, use 'makeInvmap'.
* If using the @-XDatatypeContexts@, @-XExistentialQuantification@, or @-XGADTs@
extensions, a constraint cannot mention the last type variable. For example,
@data Illegal a where I :: Ord a => a -> Illegal a@ cannot have a derived
'Invariant' instance.
* If the last type variable is used within a data field of a constructor, it must only
be used in the last argument of the data type constructor. For example, @data Legal a
= Legal (Either Int a)@ can have a derived 'Invariant' instance, but @data Illegal a =
Illegal (Either a a)@ cannot.
* Data family instances must be able to eta-reduce the last type variable. In other
words, if you have a instance of the form:
@
data family Family a1 ... an t
data instance Family e1 ... e2 v = ...
@
Then the following conditions must hold:
1. @v@ must be a type variable.
2. @v@ must not be mentioned in any of @e1@, ..., @e2@.
* In GHC 7.8, a bug exists that can cause problems when a data family declaration and
one of its data instances use different type variables, e.g.,
@
data family Foo a b c
data instance Foo Int y z = Foo Int y z
$('deriveInvariant' 'Foo)
@
To avoid this issue, it is recommened that you use the same type variables in the
same positions in which they appeared in the data family declaration:
@
data family Foo a b c
data instance Foo Int b c = Foo Int b c
$('deriveInvariant' 'Foo)
@
-}
-- | Generates an 'Invariant' instance declaration for the given data type or data
-- family instance.
deriveInvariant :: Name -> Q [Dec]
deriveInvariant = deriveInvariantClass Invariant
{- $deriveInvariant2
'deriveInvariant2' automatically generates an 'Invariant2' instance declaration for
a data type, newtype, or data family instance that has at least two type variables.
This emulates what would (hypothetically) happen if you could attach a @deriving
'Invariant2'@ clause to the end of a data declaration. Examples:
@
{-# LANGUAGE TemplateHaskell #-}
import Data.Functor.Invariant.TH
data OneOrNone a b = OneL a | OneR b | None
$('deriveInvariant2' ''OneOrNone) -- instance Invariant2 OneOrNone where ...
newtype Alt2 f a b = Alt2 (f a b)
$('deriveInvariant2' ''Alt2) -- instance Invariant2 f => Invariant2 (Alt2 f) where ...
@
The same restrictions that apply to 'deriveInvariant' also apply to 'deriveInvariant2',
with some caveats:
* With 'deriveInvariant2', the last type variables must both be of kind @*@. For other
ones, type variables of kind @* -> *@ are assumed to require an 'Invariant'
constraint, and type variables of kind @* -> * -> *@ are assumed to require an
'Invariant2' constraint. For more complicated scenarios, use 'makeInvmap2'.
* If using the @-XDatatypeContexts@, @-XExistentialQuantification@, or @-XGADTs@
extensions, a constraint cannot mention either of the last two type variables. For
example, @data Illegal2 a b where I2 :: Ord a => a -> b -> Illegal2 a b@ cannot
have a derived 'Invariant2' instance.
* If either of the last two type variables is used within a data field of a constructor,
it must only be used in the last two arguments of the data type constructor. For
example, @data Legal a b = Legal (Int, Int, a, b)@ can have a derived 'Invariant2'
instance, but @data Illegal a b = Illegal (a, b, a, b)@ cannot.
* Data family instances must be able to eta-reduce the last two type variables. In other
words, if you have a instance of the form:
@
data family Family a1 ... an t1 t2
data instance Family e1 ... e2 v1 v2 = ...
@
Then the following conditions must hold:
1. @v1@ and @v2@ must be distinct type variables.
2. Neither @v1@ not @v2@ must be mentioned in any of @e1@, ..., @e2@.
-}
-- | Generates an 'Invariant2' instance declaration for the given data type or data
-- family instance.
deriveInvariant2 :: Name -> Q [Dec]
deriveInvariant2 = deriveInvariantClass Invariant2
{- $make
There may be scenarios in which you want to @invmap@ over an arbitrary data type or
data family instance without having to make the type an instance of 'Invariant'. For
these cases, this module provides several functions (all prefixed with @make-@) that
splice the appropriate lambda expression into your source code. Example:
This is particularly useful for creating instances for sophisticated data types. For
example, 'deriveInvariant' cannot infer the correct type context for @newtype
HigherKinded f a b c = HigherKinded (f a b c)@, since @f@ is of kind
@* -> * -> * -> *@. However, it is still possible to create an 'Invariant' instance
for @HigherKinded@ without too much trouble using 'makeInvmap':
@
{-# LANGUAGE FlexibleContexts, TemplateHaskell #-}
import Data.Functor.Invariant
import Data.Functor.Invariant.TH
newtype HigherKinded f a b c = HigherKinded (f a b c)
instance Invariant (f a b) => Invariant (HigherKinded f a b) where
invmap = $(makeInvmap ''HigherKinded)
@
-}
-- | Generates a lambda expression which behaves like 'invmap' (without requiring an
-- 'Invariant' instance).
makeInvmap :: Name -> Q Exp
makeInvmap = makeInvmapClass Invariant
-- | Generates a lambda expression which behaves like 'invmap2' (without requiring an
-- 'Invariant2' instance).
makeInvmap2 :: Name -> Q Exp
makeInvmap2 = 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 = withType name fromCons
where
fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec]
fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap`
instanceD (return instanceCxt)
(return instanceType)
(invmapDecs droppedNbs cons)
where
(instanceCxt, instanceType, droppedNbs) =
buildTypeInstance iClass name' ctxt tvbs mbTys
-- | Generates a declaration defining the primary function corresponding to a
-- particular class (invmap for Invariant and invmap2 for Invariant2).
invmapDecs :: [NameBase] -> [Con] -> [Q Dec]
invmapDecs nbs cons =
[ funD classFuncName
[ clause []
(normalB $ makeInvmapForCons nbs cons)
[]
]
]
where
classFuncName :: Name
classFuncName = invmapName . toEnum $ length nbs
-- | Generates a lambda expression which behaves like invmap (for Invariant),
-- or invmap2 (for Invariant2).
makeInvmapClass :: InvariantClass -> Name -> Q Exp
makeInvmapClass iClass name = withType name fromCons
where
fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp
fromCons name' ctxt tvbs cons mbTys =
let nbs = thd3 $ buildTypeInstance iClass name' ctxt tvbs mbTys
in nbs `seq` makeInvmapForCons nbs cons
-- | Generates a lambda expression for invmap(2) for the given constructors.
-- All constructors must be from the same type.
makeInvmapForCons :: [NameBase] -> [Con] -> Q Exp
makeInvmapForCons nbs cons = do
let numNbs = length nbs
value <- newName "value"
covMaps <- newNameList "covMap" numNbs
contraMaps <- newNameList "contraMap" numNbs
let tvis = zip3 nbs covMaps contraMaps
iClass = toEnum numNbs
argNames = concat (transpose [covMaps, contraMaps]) ++ [value]
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 tvis) cons)
] ++ map varE argNames
-- | Generates a lambda expression for invmap(2) for a single constructor.
makeInvmapForCon :: InvariantClass -> [TyVarInfo] -> Con -> Q Match
makeInvmapForCon iClass tvis (NormalC conName tys) = do
args <- newNameList "arg" $ length tys
let argTys = map snd tys
makeInvmapForArgs iClass tvis conName argTys args
makeInvmapForCon iClass tvis (RecC conName tys) = do
args <- newNameList "arg" $ length tys
let argTys = map thd3 tys
makeInvmapForArgs iClass tvis conName argTys args
makeInvmapForCon iClass tvis (InfixC (_, argTyL) conName (_, argTyR)) = do
argL <- newName "argL"
argR <- newName "argR"
makeInvmapForArgs iClass tvis conName [argTyL, argTyR] [argL, argR]
makeInvmapForCon iClass tvis (ForallC tvbs faCxt con) =
if any (`predMentionsNameBase` map fst3 tvis) faCxt
then existentialContextError $ constructorName con
else makeInvmapForCon iClass (removeForalled tvbs tvis) con
makeInvmapForArgs :: InvariantClass
-> [TyVarInfo]
-> Name
-> [Type]
-> [Name]
-> Q Match
makeInvmapForArgs iClass tvis conName tys args =
let mappedArgs :: [Q Exp]
mappedArgs = zipWith (makeInvmapForArg iClass conName tvis) tys args
in match (conP conName $ map varP args)
(normalB . appsE $ conE conName:mappedArgs)
[]
-- | Generates a lambda expression for invmap(2) for an argument of a constructor.
makeInvmapForArg :: InvariantClass
-> Name
-> [TyVarInfo]
-> Type
-> Name
-> Q Exp
makeInvmapForArg iClass conName tvis ty tyExpName = do
ty' <- expandSyn ty
makeInvmapForArg' iClass conName tvis ty' tyExpName
-- | Generates a lambda expression for invmap(2) for an argument of a
-- constructor, after expanding all type synonyms.
makeInvmapForArg' :: InvariantClass
-> Name
-> [TyVarInfo]
-> Type
-> Name
-> Q Exp
makeInvmapForArg' iClass conName tvis ty tyExpName =
appE (makeInvmapForType iClass conName tvis True ty) (varE tyExpName)
-- | Generates a lambda expression for invmap(2) for a specific type.
-- The generated expression depends on the number of type variables.
makeInvmapForType :: InvariantClass
-> Name
-> [TyVarInfo]
-> Bool
-> Type
-> Q Exp
makeInvmapForType _ _ tvis covariant (VarT tyName) =
case lookup2 (NameBase tyName) tvis of
Just (covMap, contraMap) ->
varE $ if covariant then covMap else contraMap
Nothing -> do -- Produce a lambda expression rather than id, addressing Trac #7436
x <- newName "x"
lamE [varP x] $ varE x
makeInvmapForType iClass conName tvis covariant (SigT ty _) =
makeInvmapForType iClass conName tvis covariant ty
makeInvmapForType iClass conName tvis covariant (ForallT tvbs _ ty)
= makeInvmapForType iClass conName (removeForalled tvbs tvis) covariant ty
makeInvmapForType iClass conName tvis covariant ty =
let tyCon :: Type
tyArgs :: [Type]
tyCon:tyArgs = unapplyTy ty
numLastArgs :: Int
numLastArgs = min (fromEnum iClass) (length tyArgs)
lhsArgs, rhsArgs :: [Type]
(lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs
tyVarNameBases :: [NameBase]
tyVarNameBases = map fst3 tvis
doubleMap :: (Bool -> Type -> Q Exp) -> [Type] -> [Q Exp]
doubleMap _ [] = []
doubleMap f (t:ts) = f covariant t : f (not covariant) t : doubleMap f ts
mentionsTyArgs :: Bool
mentionsTyArgs = any (`mentionsNameBase` tyVarNameBases) tyArgs
makeInvmapTuple :: Type -> Name -> Q Exp
makeInvmapTuple fieldTy fieldName =
appE (makeInvmapForType iClass conName tvis covariant fieldTy) $ varE fieldName
in case tyCon of
ArrowT | mentionsTyArgs ->
let [argTy, resTy] = tyArgs
in do x <- newName "x"
b <- newName "b"
lamE [varP x, varP b] $
makeInvmapForType iClass conName tvis covariant resTy `appE` (varE x `appE`
(makeInvmapForType iClass conName tvis (not covariant) argTy `appE` varE b))
TupleT n | n > 0 && mentionsTyArgs -> do
x <- newName "x"
xs <- newNameList "x" n
lamE [varP x] $ caseE (varE x)
[ match (tupP $ map varP xs)
(normalB . tupE $ zipWith makeInvmapTuple tyArgs xs)
[]
]
_ -> do
itf <- isTyFamily tyCon
if any (`mentionsNameBase` tyVarNameBases) lhsArgs || (itf && mentionsTyArgs)
then outOfPlaceTyVarError conName tyVarNameBases
else if any (`mentionsNameBase` tyVarNameBases) rhsArgs
then appsE $
( varE (invmapName (toEnum numLastArgs))
: doubleMap (makeInvmapForType iClass conName tvis) rhsArgs
)
else do x <- newName "x"
lamE [varP x] $ varE x
-------------------------------------------------------------------------------
-- Template Haskell reifying and AST manipulation
-------------------------------------------------------------------------------
-- | Extracts a plain type constructor's information.
-- | Boilerplate for top level splices.
--
-- The given Name must meet one of two criteria:
--
-- 1. It must be the name of a type constructor of a plain data type or newtype.
-- 2. It must be the name of a data family instance or newtype instance constructor.
--
-- Any other value will result in an exception.
withType :: Name
-> (Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q a)
-> Q a
withType name f = do
info <- reify name
case info of
TyConI dec ->
case dec of
DataD ctxt _ tvbs cons _ -> f name ctxt tvbs cons Nothing
NewtypeD ctxt _ tvbs con _ -> f name ctxt tvbs [con] Nothing
_ -> error $ ns ++ "Unsupported type: " ++ show dec
#if MIN_VERSION_template_haskell(2,7,0)
# if MIN_VERSION_template_haskell(2,11,0)
DataConI _ _ parentName -> do
# else
DataConI _ _ parentName _ -> do
# endif
parentInfo <- reify parentName
case parentInfo of
# if MIN_VERSION_template_haskell(2,11,0)
FamilyI (DataFamilyD _ tvbs _) decs ->
# else
FamilyI (FamilyD DataFam _ tvbs _) decs ->
# endif
let instDec = flip find decs $ \dec -> case dec of
DataInstD _ _ _ cons _ -> any ((name ==) . constructorName) cons
NewtypeInstD _ _ _ con _ -> name == constructorName con
_ -> error $ ns ++ "Must be a data or newtype instance."
in case instDec of
Just (DataInstD ctxt _ instTys cons _)
-> f parentName ctxt tvbs cons $ Just instTys
Just (NewtypeInstD ctxt _ instTys con _)
-> f parentName ctxt tvbs [con] $ Just instTys
_ -> error $ ns ++
"Could not find data or newtype instance constructor."
_ -> error $ ns ++ "Data constructor " ++ show name ++
" is not from a data family instance constructor."
# if MIN_VERSION_template_haskell(2,11,0)
FamilyI DataFamilyD{} _ ->
# else
FamilyI (FamilyD DataFam _ _ _) _ ->
# endif
error $ ns ++
"Cannot use a data family name. Use a data family instance constructor instead."
_ -> error $ ns ++ "The name must be of a plain data type constructor, "
++ "or a data family instance constructor."
#else
DataConI{} -> dataConIError
_ -> error $ ns ++ "The name must be of a plain type constructor."
#endif
where
ns :: String
ns = "Data.Functor.Invariant.TH.withType: "
-- | Deduces the instance context, instance head, and eta-reduced type variables
-- for an instance.
buildTypeInstance :: InvariantClass
-- ^ Invariant or Invariant2
-> Name
-- ^ The type constructor or data family name
-> Cxt
-- ^ The datatype context
-> [TyVarBndr]
-- ^ The type variables from the data type/data family declaration
-> Maybe [Type]
-- ^ 'Just' the types used to instantiate a data family instance,
-- or 'Nothing' if it's a plain data type
-> (Cxt, Type, [NameBase])
-- Plain data type/newtype case
buildTypeInstance iClass tyConName dataCxt tvbs Nothing =
if remainingLength < 0 || not (wellKinded droppedKinds) -- If we have enough well-kinded type variables
then derivingKindError iClass tyConName
else if any (`predMentionsNameBase` droppedNbs) dataCxt -- If the last type variable(s) are mentioned in a datatype context
then datatypeContextError tyConName instanceType
else (instanceCxt, instanceType, droppedNbs)
where
instanceCxt :: Cxt
instanceCxt = map (applyInvariantConstraint)
$ filter (needsConstraint iClass . tvbKind) remaining
instanceType :: Type
instanceType = AppT (ConT $ invariantClassName iClass)
. applyTyCon tyConName
$ map (VarT . tvbName) remaining
remainingLength :: Int
remainingLength = length tvbs - fromEnum iClass
remaining, dropped :: [TyVarBndr]
(remaining, dropped) = splitAt remainingLength tvbs
droppedKinds :: [Kind]
droppedKinds = map tvbKind dropped
droppedNbs :: [NameBase]
droppedNbs = map (NameBase . tvbName) dropped
-- Data family instance case
buildTypeInstance iClass parentName dataCxt tvbs (Just instTysAndKinds) =
if remainingLength < 0 || not (wellKinded droppedKinds) -- If we have enough well-kinded type variables
then derivingKindError iClass parentName
else if any (`predMentionsNameBase` droppedNbs) dataCxt -- If the last type variable(s) are mentioned in a datatype context
then datatypeContextError parentName instanceType
else if canEtaReduce remaining dropped -- If it is safe to drop the type variables
then (instanceCxt, instanceType, droppedNbs)
else etaReductionError instanceType
where
instanceCxt :: Cxt
instanceCxt = map (applyInvariantConstraint)
$ filter (needsConstraint iClass . tvbKind) lhsTvbs
-- We need to make sure that type variables in the instance head which have
-- Invariant(2) constraints aren't poly-kinded, e.g.,
--
-- @
-- instance Invariant f => Invariant (Foo (f :: k)) where
-- @
--
-- To do this, we remove every kind ascription (i.e., strip off every 'SigT').
instanceType :: Type
instanceType = AppT (ConT $ invariantClassName iClass)
. applyTyCon parentName
$ map unSigT remaining
remainingLength :: Int
remainingLength = length tvbs - fromEnum iClass
remaining, dropped :: [Type]
(remaining, dropped) = splitAt remainingLength rhsTypes
droppedKinds :: [Kind]
droppedKinds = map tvbKind . snd $ splitAt remainingLength tvbs
droppedNbs :: [NameBase]
droppedNbs = map varTToNameBase dropped
-- We need to be mindful of an old GHC bug which causes kind variables to appear in
-- @instTysAndKinds@ (as the name suggests) if
--
-- (1) @PolyKinds@ is enabled
-- (2) either GHC 7.6 or 7.8 is being used (for more info, see
-- https://ghc.haskell.org/trac/ghc/ticket/9692).
--
-- Since Template Haskell doesn't seem to have a mechanism for detecting which
-- language extensions are enabled, we do the next-best thing by counting
-- the number of distinct kind variables in the data family declaration, and
-- then dropping that number of entries from @instTysAndKinds@.
instTypes :: [Type]
instTypes =
#if __GLASGOW_HASKELL__ >= 710 || !(MIN_VERSION_template_haskell(2,8,0))
instTysAndKinds
#else
drop (Set.size . Set.unions $ map (distinctKindVars . tvbKind) tvbs)
instTysAndKinds
#endif
lhsTvbs :: [TyVarBndr]
lhsTvbs = map (uncurry replaceTyVarName)
. filter (isTyVar . snd)
. take remainingLength
$ zip tvbs rhsTypes
-- In GHC 7.8, only the @Type@s up to the rightmost non-eta-reduced type variable
-- in @instTypes@ are provided (as a result of this extremely annoying bug:
-- https://ghc.haskell.org/trac/ghc/ticket/9692). This is pretty inconvenient,
-- as it makes it impossible to come up with the correct Invariant(2)
-- instances in some cases. For example, consider the following code:
--
-- @
-- data family Foo a b c
-- data instance Foo Int y z = Foo Int y z
-- $(deriveInvariant2 'Foo)
-- @
--
-- Due to the aformentioned bug, Template Haskell doesn't tell us the names of
-- either of type variables in the data instance (@y@ and @z@). As a result, we
-- won't know which fields of the 'Foo' constructor to apply the map functions,
-- which will result in an incorrect instance. Urgh.
--
-- A workaround is to ensure that you use the exact same type variables, in the
-- exact same order, in the data family declaration and any data or newtype
-- instances:
--
-- @
-- data family Foo a b c
-- data instance Foo Int b c = Foo Int b c
-- $(deriveInvariant2 'Foo)
-- @
--
-- Thankfully, other versions of GHC don't seem to have this bug.
rhsTypes :: [Type]
rhsTypes =
#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710
instTypes ++ map tvbToType
(drop (length instTypes)
tvbs)
#else
instTypes
#endif
-- | Given a TyVarBndr, apply an Invariant(2) constraint to it, depending
-- on its kind.
applyInvariantConstraint :: TyVarBndr -> Pred
applyInvariantConstraint PlainTV{} = error "Cannot constrain type of kind *"
applyInvariantConstraint (KindedTV name kind) = applyClass className name
where
className :: Name
className = invariantClassName . toEnum $ numKindArrows kind
-- | Can a kind signature inhabit an Invariant constraint?
--
-- Invariant: Kind k1 -> k2
-- Invariant2: Kind k1 -> k2 -> k3
needsConstraint :: InvariantClass -> Kind -> Bool
needsConstraint iClass kind =
fromEnum iClass >= nka
&& nka >= fromEnum Invariant
&& canRealizeKindStarChain kind
where
nka :: Int
nka = numKindArrows kind
-------------------------------------------------------------------------------
-- Error messages
-------------------------------------------------------------------------------
-- | Either the given data type doesn't have enough type variables, or one of
-- the type variables to be eta-reduced cannot realize kind *.
derivingKindError :: InvariantClass -> Name -> a
derivingKindError iClass tyConName = error
. showString "Cannot derive well-kinded instance of form ‘"
. showString className
. showChar ' '
. showParen True
( showString (nameBase tyConName)
. showString " ..."
)
. showString "‘\n\tClass "
. showString className
. showString " expects an argument of kind "
. showString (pprint . createKindChain $ fromEnum iClass)
$ ""
where
className :: String
className = nameBase $ invariantClassName iClass
-- | The data type has a DatatypeContext which mentions one of the eta-reduced
-- type variables.
datatypeContextError :: Name -> Type -> a
datatypeContextError dataName instanceType = error
. showString "Can't make a derived instance of ‘"
. showString (pprint instanceType)
. showString "‘:\n\tData type ‘"
. showString (nameBase dataName)
. showString "‘ must not have a class context involving the last type argument(s)"
$ ""
-- | The data type has an existential constraint which mentions one of the
-- eta-reduced type variables.
existentialContextError :: Name -> a
existentialContextError conName = error
. showString "Constructor ‘"
. showString (nameBase conName)
. showString "‘ must be truly polymorphic in the last argument(s) of the data type"
$ ""
-- | The data type mentions one of the n eta-reduced type variables in a place other
-- than the last nth positions of a data type in a constructor's field.
outOfPlaceTyVarError :: Name -> [NameBase] -> a
outOfPlaceTyVarError conName tyVarNames = error
. showString "Constructor ‘"
. showString (nameBase conName)
. showString "‘ must use the type variable(s) "
. showsPrec 0 tyVarNames
. showString " only in the last argument(s) of a data type"
$ ""
-- | One of the last type variables cannot be eta-reduced (see the canEtaReduce
-- function for the criteria it would have to meet).
etaReductionError :: Type -> a
etaReductionError instanceType = error $
"Cannot eta-reduce to an instance of form \n\tinstance (...) => "
++ pprint instanceType
#if !(MIN_VERSION_template_haskell(2,7,0))
-- | Template Haskell didn't list all of a data family's instances upon reification
-- until template-haskell-2.7.0.0, which is necessary for a derived Invariant instance
-- to work.
dataConIError :: a
dataConIError = error
. showString "Cannot use a data constructor."
. showString "\n\t(Note: if you are trying to derive Invariant for a type family,"
. showString "\n\tuse GHC >= 7.4 instead.)"
$ ""
#endif