{-# LANGUAGE CPP #-}
module Data.Functor.Invariant.TH (
deriveInvariant
, deriveInvariantOptions
, deriveInvariant2
, deriveInvariant2Options
, makeInvmap
, makeInvmapOptions
, makeInvmap2
, makeInvmap2Options
, Options(..)
, defaultOptions
) where
import Control.Monad (unless, when)
import Data.Functor.Invariant.TH.Internal
import Data.List
import qualified Data.Map as Map (fromList, keys, lookup, size)
import Data.Maybe
import Language.Haskell.TH.Datatype
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Ppr
import Language.Haskell.TH.Syntax
newtype Options = Options
{ Options -> Bool
emptyCaseBehavior :: Bool
} deriving (Options -> Options -> Bool
(Options -> Options -> Bool)
-> (Options -> Options -> Bool) -> Eq Options
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Options -> Options -> Bool
$c/= :: Options -> Options -> Bool
== :: Options -> Options -> Bool
$c== :: Options -> Options -> Bool
Eq, Eq Options
Eq Options
-> (Options -> Options -> Ordering)
-> (Options -> Options -> Bool)
-> (Options -> Options -> Bool)
-> (Options -> Options -> Bool)
-> (Options -> Options -> Bool)
-> (Options -> Options -> Options)
-> (Options -> Options -> Options)
-> Ord Options
Options -> Options -> Bool
Options -> Options -> Ordering
Options -> Options -> Options
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Options -> Options -> Options
$cmin :: Options -> Options -> Options
max :: Options -> Options -> Options
$cmax :: Options -> Options -> Options
>= :: Options -> Options -> Bool
$c>= :: Options -> Options -> Bool
> :: Options -> Options -> Bool
$c> :: Options -> Options -> Bool
<= :: Options -> Options -> Bool
$c<= :: Options -> Options -> Bool
< :: Options -> Options -> Bool
$c< :: Options -> Options -> Bool
compare :: Options -> Options -> Ordering
$ccompare :: Options -> Options -> Ordering
$cp1Ord :: Eq Options
Ord, ReadPrec [Options]
ReadPrec Options
Int -> ReadS Options
ReadS [Options]
(Int -> ReadS Options)
-> ReadS [Options]
-> ReadPrec Options
-> ReadPrec [Options]
-> Read Options
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Options]
$creadListPrec :: ReadPrec [Options]
readPrec :: ReadPrec Options
$creadPrec :: ReadPrec Options
readList :: ReadS [Options]
$creadList :: ReadS [Options]
readsPrec :: Int -> ReadS Options
$creadsPrec :: Int -> ReadS Options
Read, Int -> Options -> ShowS
[Options] -> ShowS
Options -> String
(Int -> Options -> ShowS)
-> (Options -> String) -> ([Options] -> ShowS) -> Show Options
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Options] -> ShowS
$cshowList :: [Options] -> ShowS
show :: Options -> String
$cshow :: Options -> String
showsPrec :: Int -> Options -> ShowS
$cshowsPrec :: Int -> Options -> ShowS
Show)
defaultOptions :: Options
defaultOptions :: Options
defaultOptions = Options :: Bool -> Options
Options { emptyCaseBehavior :: Bool
emptyCaseBehavior = Bool
False }
deriveInvariant :: Name -> Q [Dec]
deriveInvariant :: Name -> Q [Dec]
deriveInvariant = Options -> Name -> Q [Dec]
deriveInvariantOptions Options
defaultOptions
deriveInvariantOptions :: Options -> Name -> Q [Dec]
deriveInvariantOptions :: Options -> Name -> Q [Dec]
deriveInvariantOptions = InvariantClass -> Options -> Name -> Q [Dec]
deriveInvariantClass InvariantClass
Invariant
deriveInvariant2 :: Name -> Q [Dec]
deriveInvariant2 :: Name -> Q [Dec]
deriveInvariant2 = Options -> Name -> Q [Dec]
deriveInvariant2Options Options
defaultOptions
deriveInvariant2Options :: Options -> Name -> Q [Dec]
deriveInvariant2Options :: Options -> Name -> Q [Dec]
deriveInvariant2Options = InvariantClass -> Options -> Name -> Q [Dec]
deriveInvariantClass InvariantClass
Invariant2
makeInvmap :: Name -> Q Exp
makeInvmap :: Name -> Q Exp
makeInvmap = Options -> Name -> Q Exp
makeInvmapOptions Options
defaultOptions
makeInvmapOptions :: Options -> Name -> Q Exp
makeInvmapOptions :: Options -> Name -> Q Exp
makeInvmapOptions = InvariantClass -> Options -> Name -> Q Exp
makeInvmapClass InvariantClass
Invariant
makeInvmap2 :: Name -> Q Exp
makeInvmap2 :: Name -> Q Exp
makeInvmap2 = Options -> Name -> Q Exp
makeInvmap2Options Options
defaultOptions
makeInvmap2Options :: Options -> Name -> Q Exp
makeInvmap2Options :: Options -> Name -> Q Exp
makeInvmap2Options = InvariantClass -> Options -> Name -> Q Exp
makeInvmapClass InvariantClass
Invariant2
deriveInvariantClass :: InvariantClass -> Options -> Name -> Q [Dec]
deriveInvariantClass :: InvariantClass -> Options -> Name -> Q [Dec]
deriveInvariantClass InvariantClass
iClass Options
opts Name
name = do
DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
case DatatypeInfo
info of
DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
datatypeContext = Cxt
ctxt
, datatypeName :: DatatypeInfo -> Name
datatypeName = Name
parentName
#if MIN_VERSION_th_abstraction(0,3,0)
, datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
instTys
#else
, datatypeVars = instTys
#endif
, datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant = DatatypeVariant
variant
, datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons
} -> do
(Cxt
instanceCxt, Type
instanceType)
<- InvariantClass
-> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance InvariantClass
iClass Name
parentName Cxt
ctxt Cxt
instTys DatatypeVariant
variant
(Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD (Cxt -> CxtQ
forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
instanceCxt)
(Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
instanceType)
(InvariantClass
-> Options -> Name -> Cxt -> [ConstructorInfo] -> [Q Dec]
invmapDecs InvariantClass
iClass Options
opts Name
parentName Cxt
instTys [ConstructorInfo]
cons)
invmapDecs :: InvariantClass -> Options -> Name -> [Type] -> [ConstructorInfo]
-> [Q Dec]
invmapDecs :: InvariantClass
-> Options -> Name -> Cxt -> [ConstructorInfo] -> [Q Dec]
invmapDecs InvariantClass
iClass Options
opts Name
parentName Cxt
instTys [ConstructorInfo]
cons =
[ Name -> [ClauseQ] -> Q Dec
funD (InvariantClass -> Name
invmapName InvariantClass
iClass)
[ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
(Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ InvariantClass
-> Options -> Name -> Cxt -> [ConstructorInfo] -> Q Exp
makeInvmapForCons InvariantClass
iClass Options
opts Name
parentName Cxt
instTys [ConstructorInfo]
cons)
[]
]
]
makeInvmapClass :: InvariantClass -> Options -> Name -> Q Exp
makeInvmapClass :: InvariantClass -> Options -> Name -> Q Exp
makeInvmapClass InvariantClass
iClass Options
opts Name
name = do
DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
case DatatypeInfo
info of
DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
datatypeContext = Cxt
ctxt
, datatypeName :: DatatypeInfo -> Name
datatypeName = Name
parentName
#if MIN_VERSION_th_abstraction(0,3,0)
, datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
instTys
#else
, datatypeVars = instTys
#endif
, datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant = DatatypeVariant
variant
, datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons
} ->
InvariantClass
-> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance InvariantClass
iClass Name
parentName Cxt
ctxt Cxt
instTys DatatypeVariant
variant
Q (Cxt, Type) -> Q Exp -> Q Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InvariantClass
-> Options -> Name -> Cxt -> [ConstructorInfo] -> Q Exp
makeInvmapForCons InvariantClass
iClass Options
opts Name
parentName Cxt
instTys [ConstructorInfo]
cons
makeInvmapForCons :: InvariantClass -> Options -> Name -> [Type] -> [ConstructorInfo]
-> Q Exp
makeInvmapForCons :: InvariantClass
-> Options -> Name -> Cxt -> [ConstructorInfo] -> Q Exp
makeInvmapForCons InvariantClass
iClass Options
opts Name
_parentName Cxt
instTys [ConstructorInfo]
cons = do
Name
value <- String -> Q Name
newName String
"value"
[Name]
covMaps <- String -> Int -> Q [Name]
newNameList String
"covMap" Int
numNbs
[Name]
contraMaps <- String -> Int -> Q [Name]
newNameList String
"contraMap" Int
numNbs
let mapFuns :: [(Name, Name)]
mapFuns = [Name] -> [Name] -> [(Name, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
covMaps [Name]
contraMaps
lastTyVars :: [Name]
lastTyVars = (Type -> Name) -> Cxt -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Name
varTToName (Cxt -> [Name]) -> Cxt -> [Name]
forall a b. (a -> b) -> a -> b
$ Int -> Cxt -> Cxt
forall a. Int -> [a] -> [a]
drop (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
instTys Int -> Int -> Int
forall a. Num a => a -> a -> a
- InvariantClass -> Int
forall a. Enum a => a -> Int
fromEnum InvariantClass
iClass) Cxt
instTys
tvMap :: Map Name (Name, Name)
tvMap = [(Name, (Name, Name))] -> Map Name (Name, Name)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, (Name, Name))] -> Map Name (Name, Name))
-> [(Name, (Name, Name))] -> Map Name (Name, Name)
forall a b. (a -> b) -> a -> b
$ [Name] -> [(Name, Name)] -> [(Name, (Name, Name))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
lastTyVars [(Name, Name)]
mapFuns
argNames :: [Name]
argNames = [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Name]] -> [[Name]]
forall a. [[a]] -> [[a]]
transpose [[Name]
covMaps, [Name]
contraMaps]) [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name
value]
[PatQ] -> Q Exp -> Q Exp
lamE ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
argNames)
(Q Exp -> Q Exp) -> ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q Exp] -> Q Exp
appsE
([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [ Name -> Q Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ InvariantClass -> Name
invmapConstName InvariantClass
iClass
, Name -> Map Name (Name, Name) -> Q Exp
makeFun Name
value Map Name (Name, Name)
tvMap
] [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
varE [Name]
argNames
where
numNbs :: Int
numNbs :: Int
numNbs = InvariantClass -> Int
forall a. Enum a => a -> Int
fromEnum InvariantClass
iClass
makeFun :: Name -> TyVarMap -> Q Exp
makeFun :: Name -> Map Name (Name, Name) -> Q Exp
makeFun Name
value Map Name (Name, Name)
tvMap = do
#if MIN_VERSION_template_haskell(2,9,0)
[Role]
roles <- Name -> Q [Role]
reifyRoles Name
_parentName
let rroles :: [Role]
rroles = [Role]
roles
#endif
case () of
()
_
#if MIN_VERSION_template_haskell(2,9,0)
| ([Role] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Role]
rroles Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
numNbs) Bool -> Bool -> Bool
&&
((Role -> Bool) -> [Role] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
PhantomR) (Int -> [Role] -> [Role]
forall a. Int -> [a] -> [a]
take Int
numNbs [Role]
rroles))
-> Name -> Q Exp
varE Name
coerceValName Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
value
#endif
| [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
cons Bool -> Bool -> Bool
&& Options -> Bool
emptyCaseBehavior Options
opts Bool -> Bool -> Bool
&& Bool
ghc7'8OrLater
-> Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
value) []
| [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
cons
-> Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE Name
seqValName) (Name -> Q Exp
varE Name
value) Q Exp -> Q Exp -> Q Exp
`appE`
Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE Name
errorValName)
(String -> Q Exp
stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"Void " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase (InvariantClass -> Name
invmapName InvariantClass
iClass))
| Bool
otherwise
-> Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
value)
((ConstructorInfo -> MatchQ) -> [ConstructorInfo] -> [MatchQ]
forall a b. (a -> b) -> [a] -> [b]
map (InvariantClass
-> Map Name (Name, Name) -> ConstructorInfo -> MatchQ
makeInvmapForCon InvariantClass
iClass Map Name (Name, Name)
tvMap) [ConstructorInfo]
cons)
ghc7'8OrLater :: Bool
#if __GLASGOW_HASKELL__ >= 708
ghc7'8OrLater :: Bool
ghc7'8OrLater = Bool
True
#else
ghc7'8OrLater = False
#endif
makeInvmapForCon :: InvariantClass -> TyVarMap -> ConstructorInfo -> Q Match
makeInvmapForCon :: InvariantClass
-> Map Name (Name, Name) -> ConstructorInfo -> MatchQ
makeInvmapForCon InvariantClass
iClass Map Name (Name, Name)
tvMap
(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
conName
, constructorContext :: ConstructorInfo -> Cxt
constructorContext = Cxt
ctxt
, constructorFields :: ConstructorInfo -> Cxt
constructorFields = Cxt
ts })= do
Cxt
ts' <- (Type -> TypeQ) -> Cxt -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TypeQ
resolveTypeSynonyms Cxt
ts
[Name]
argNames <- String -> Int -> Q [Name]
newNameList String
"arg" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
ts'
if (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`predMentionsName` Map Name (Name, Name) -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name (Name, Name)
tvMap) Cxt
ctxt
Bool -> Bool -> Bool
|| Map Name (Name, Name) -> Int
forall k a. Map k a -> Int
Map.size Map Name (Name, Name)
tvMap Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< InvariantClass -> Int
forall a. Enum a => a -> Int
fromEnum InvariantClass
iClass
then Name -> MatchQ
forall a. Name -> a
existentialContextError Name
conName
else InvariantClass
-> Map Name (Name, Name) -> Name -> Cxt -> [Name] -> MatchQ
makeInvmapForArgs InvariantClass
iClass Map Name (Name, Name)
tvMap Name
conName Cxt
ts' [Name]
argNames
makeInvmapForArgs :: InvariantClass
-> TyVarMap
-> Name
-> [Type]
-> [Name]
-> Q Match
makeInvmapForArgs :: InvariantClass
-> Map Name (Name, Name) -> Name -> Cxt -> [Name] -> MatchQ
makeInvmapForArgs InvariantClass
iClass Map Name (Name, Name)
tvMap Name
conName Cxt
tys [Name]
args =
let mappedArgs :: [Q Exp]
mappedArgs :: [Q Exp]
mappedArgs = (Type -> Name -> Q Exp) -> Cxt -> [Name] -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (InvariantClass
-> Name -> Map Name (Name, Name) -> Type -> Name -> Q Exp
makeInvmapForArg InvariantClass
iClass Name
conName Map Name (Name, Name)
tvMap) Cxt
tys [Name]
args
in PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP Name
conName ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
args)
(Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> ([Q Exp] -> Q Exp) -> [Q Exp] -> BodyQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q Exp] -> Q Exp
appsE ([Q Exp] -> BodyQ) -> [Q Exp] -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
conE Name
conNameQ Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
:[Q Exp]
mappedArgs)
[]
makeInvmapForArg :: InvariantClass
-> Name
-> TyVarMap
-> Type
-> Name
-> Q Exp
makeInvmapForArg :: InvariantClass
-> Name -> Map Name (Name, Name) -> Type -> Name -> Q Exp
makeInvmapForArg InvariantClass
iClass Name
conName Map Name (Name, Name)
tvis Type
ty Name
tyExpName =
Q Exp -> Q Exp -> Q Exp
appE (InvariantClass
-> Name -> Map Name (Name, Name) -> Bool -> Type -> Q Exp
makeInvmapForType InvariantClass
iClass Name
conName Map Name (Name, Name)
tvis Bool
True Type
ty) (Name -> Q Exp
varE Name
tyExpName)
makeInvmapForType :: InvariantClass
-> Name
-> TyVarMap
-> Bool
-> Type
-> Q Exp
makeInvmapForType :: InvariantClass
-> Name -> Map Name (Name, Name) -> Bool -> Type -> Q Exp
makeInvmapForType InvariantClass
_ Name
_ Map Name (Name, Name)
tvMap Bool
covariant (VarT Name
tyName) =
case Name -> Map Name (Name, Name) -> Maybe (Name, Name)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
tyName Map Name (Name, Name)
tvMap of
Just (Name
covMap, Name
contraMap) ->
Name -> Q Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ if Bool
covariant then Name
covMap else Name
contraMap
Maybe (Name, Name)
Nothing -> do
Name
x <- String -> Q Name
newName String
"x"
[PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
x] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE Name
x
makeInvmapForType InvariantClass
iClass Name
conName Map Name (Name, Name)
tvMap Bool
covariant (SigT Type
ty Type
_) =
InvariantClass
-> Name -> Map Name (Name, Name) -> Bool -> Type -> Q Exp
makeInvmapForType InvariantClass
iClass Name
conName Map Name (Name, Name)
tvMap Bool
covariant Type
ty
makeInvmapForType InvariantClass
iClass Name
conName Map Name (Name, Name)
tvMap Bool
covariant (ForallT [TyVarBndr]
_ Cxt
_ Type
ty)
= InvariantClass
-> Name -> Map Name (Name, Name) -> Bool -> Type -> Q Exp
makeInvmapForType InvariantClass
iClass Name
conName Map Name (Name, Name)
tvMap Bool
covariant Type
ty
makeInvmapForType InvariantClass
iClass Name
conName Map Name (Name, Name)
tvMap Bool
covariant Type
ty =
let tyCon :: Type
tyArgs :: [Type]
Type
tyCon:Cxt
tyArgs = Type -> Cxt
unapplyTy Type
ty
numLastArgs :: Int
numLastArgs :: Int
numLastArgs = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (InvariantClass -> Int
forall a. Enum a => a -> Int
fromEnum InvariantClass
iClass) (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tyArgs)
lhsArgs, rhsArgs :: [Type]
(Cxt
lhsArgs, Cxt
rhsArgs) = Int -> Cxt -> (Cxt, Cxt)
forall a. Int -> [a] -> ([a], [a])
splitAt (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tyArgs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numLastArgs) Cxt
tyArgs
tyVarNames :: [Name]
tyVarNames :: [Name]
tyVarNames = Map Name (Name, Name) -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name (Name, Name)
tvMap
doubleMap :: (Bool -> Type -> Q Exp) -> [Type] -> [Q Exp]
doubleMap :: (Bool -> Type -> Q Exp) -> Cxt -> [Q Exp]
doubleMap Bool -> Type -> Q Exp
_ [] = []
doubleMap Bool -> Type -> Q Exp
f (Type
t:Cxt
ts) = Bool -> Type -> Q Exp
f Bool
covariant Type
t Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: Bool -> Type -> Q Exp
f (Bool -> Bool
not Bool
covariant) Type
t Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: (Bool -> Type -> Q Exp) -> Cxt -> [Q Exp]
doubleMap Bool -> Type -> Q Exp
f Cxt
ts
mentionsTyArgs :: Bool
mentionsTyArgs :: Bool
mentionsTyArgs = (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
tyArgs
makeInvmapTuple :: ([Q Pat] -> Q Pat) -> ([Q Exp] -> Q Exp) -> Int -> Q Exp
makeInvmapTuple :: ([PatQ] -> PatQ) -> ([Q Exp] -> Q Exp) -> Int -> Q Exp
makeInvmapTuple [PatQ] -> PatQ
mkTupP [Q Exp] -> Q Exp
mkTupE Int
n = do
Name
x <- String -> Q Name
newName String
"x"
[Name]
xs <- String -> Int -> Q [Name]
newNameList String
"x" Int
n
[PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
x] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
x)
[ PatQ -> BodyQ -> [Q Dec] -> MatchQ
match ([PatQ] -> PatQ
mkTupP ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
xs)
(Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> ([Q Exp] -> Q Exp) -> [Q Exp] -> BodyQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q Exp] -> Q Exp
mkTupE ([Q Exp] -> BodyQ) -> [Q Exp] -> BodyQ
forall a b. (a -> b) -> a -> b
$ (Type -> Name -> Q Exp) -> Cxt -> [Name] -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Type -> Name -> Q Exp
makeInvmapTupleField Cxt
tyArgs [Name]
xs)
[]
]
makeInvmapTupleField :: Type -> Name -> Q Exp
makeInvmapTupleField :: Type -> Name -> Q Exp
makeInvmapTupleField Type
fieldTy Name
fieldName =
Q Exp -> Q Exp -> Q Exp
appE (InvariantClass
-> Name -> Map Name (Name, Name) -> Bool -> Type -> Q Exp
makeInvmapForType InvariantClass
iClass Name
conName Map Name (Name, Name)
tvMap Bool
covariant Type
fieldTy) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE Name
fieldName
in case Type
tyCon of
Type
ArrowT | Bool
mentionsTyArgs ->
let [Type
argTy, Type
resTy] = Cxt
tyArgs
in do Name
x <- String -> Q Name
newName String
"x"
Name
b <- String -> Q Name
newName String
"b"
[PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
x, Name -> PatQ
varP Name
b] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
InvariantClass
-> Name -> Map Name (Name, Name) -> Bool -> Type -> Q Exp
makeInvmapForType InvariantClass
iClass Name
conName Map Name (Name, Name)
tvMap Bool
covariant Type
resTy Q Exp -> Q Exp -> Q Exp
`appE` (Name -> Q Exp
varE Name
x Q Exp -> Q Exp -> Q Exp
`appE`
(InvariantClass
-> Name -> Map Name (Name, Name) -> Bool -> Type -> Q Exp
makeInvmapForType InvariantClass
iClass Name
conName Map Name (Name, Name)
tvMap (Bool -> Bool
not Bool
covariant) Type
argTy Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
b))
#if MIN_VERSION_template_haskell(2,6,0)
UnboxedTupleT Int
n
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Bool
mentionsTyArgs -> ([PatQ] -> PatQ) -> ([Q Exp] -> Q Exp) -> Int -> Q Exp
makeInvmapTuple [PatQ] -> PatQ
unboxedTupP [Q Exp] -> Q Exp
unboxedTupE Int
n
#endif
TupleT Int
n
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Bool
mentionsTyArgs -> ([PatQ] -> PatQ) -> ([Q Exp] -> Q Exp) -> Int -> Q Exp
makeInvmapTuple [PatQ] -> PatQ
tupP [Q Exp] -> Q Exp
tupE Int
n
Type
_ -> do
Bool
itf <- Type -> Q Bool
isTyFamily Type
tyCon
if (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
lhsArgs Bool -> Bool -> Bool
|| (Bool
itf Bool -> Bool -> Bool
&& Bool
mentionsTyArgs)
then Name -> [Name] -> Q Exp
forall a. Name -> a
outOfPlaceTyVarError Name
conName [Name]
tyVarNames
else if (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
rhsArgs
then [Q Exp] -> Q Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$
( Name -> Q Exp
varE (InvariantClass -> Name
invmapName (Int -> InvariantClass
forall a. Enum a => Int -> a
toEnum Int
numLastArgs))
Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: (Bool -> Type -> Q Exp) -> Cxt -> [Q Exp]
doubleMap (InvariantClass
-> Name -> Map Name (Name, Name) -> Bool -> Type -> Q Exp
makeInvmapForType InvariantClass
iClass Name
conName Map Name (Name, Name)
tvMap) Cxt
rhsArgs
)
else do Name
x <- String -> Q Name
newName String
"x"
[PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
x] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE Name
x
buildTypeInstance :: InvariantClass
-> Name
-> Cxt
-> [Type]
-> DatatypeVariant
-> Q (Cxt, Type)
buildTypeInstance :: InvariantClass
-> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance InvariantClass
iClass Name
tyConName Cxt
dataCxt Cxt
varTysOrig DatatypeVariant
variant = do
Cxt
varTysExp <- (Type -> TypeQ) -> Cxt -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TypeQ
resolveTypeSynonyms Cxt
varTysOrig
let remainingLength :: Int
remainingLength :: Int
remainingLength = Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
varTysOrig Int -> Int -> Int
forall a. Num a => a -> a -> a
- InvariantClass -> Int
forall a. Enum a => a -> Int
fromEnum InvariantClass
iClass
droppedTysExp :: [Type]
droppedTysExp :: Cxt
droppedTysExp = Int -> Cxt -> Cxt
forall a. Int -> [a] -> [a]
drop Int
remainingLength Cxt
varTysExp
droppedStarKindStati :: [StarKindStatus]
droppedStarKindStati :: [StarKindStatus]
droppedStarKindStati = (Type -> StarKindStatus) -> Cxt -> [StarKindStatus]
forall a b. (a -> b) -> [a] -> [b]
map Type -> StarKindStatus
canRealizeKindStar Cxt
droppedTysExp
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
remainingLength Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| (StarKindStatus -> Bool) -> [StarKindStatus] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (StarKindStatus -> StarKindStatus -> Bool
forall a. Eq a => a -> a -> Bool
== StarKindStatus
NotKindStar) [StarKindStatus]
droppedStarKindStati) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
InvariantClass -> Name -> Q ()
forall a. InvariantClass -> Name -> a
derivingKindError InvariantClass
iClass Name
tyConName
let droppedKindVarNames :: [Name]
droppedKindVarNames :: [Name]
droppedKindVarNames = [StarKindStatus] -> [Name]
catKindVarNames [StarKindStatus]
droppedStarKindStati
varTysExpSubst :: [Type]
varTysExpSubst :: Cxt
varTysExpSubst = (Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Type
substNamesWithKindStar [Name]
droppedKindVarNames) Cxt
varTysExp
remainingTysExpSubst, droppedTysExpSubst :: [Type]
(Cxt
remainingTysExpSubst, Cxt
droppedTysExpSubst) =
Int -> Cxt -> (Cxt, Cxt)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
remainingLength Cxt
varTysExpSubst
droppedTyVarNames :: [Name]
droppedTyVarNames :: [Name]
droppedTyVarNames = Cxt -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Cxt
droppedTysExpSubst
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
hasKindStar Cxt
droppedTysExpSubst) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
InvariantClass -> Name -> Q ()
forall a. InvariantClass -> Name -> a
derivingKindError InvariantClass
iClass Name
tyConName
let preds :: [Maybe Pred]
kvNames :: [[Name]]
kvNames' :: [Name]
([Maybe Type]
preds, [[Name]]
kvNames) = [(Maybe Type, [Name])] -> ([Maybe Type], [[Name]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Maybe Type, [Name])] -> ([Maybe Type], [[Name]]))
-> [(Maybe Type, [Name])] -> ([Maybe Type], [[Name]])
forall a b. (a -> b) -> a -> b
$ (Type -> (Maybe Type, [Name])) -> Cxt -> [(Maybe Type, [Name])]
forall a b. (a -> b) -> [a] -> [b]
map (InvariantClass -> Type -> (Maybe Type, [Name])
deriveConstraint InvariantClass
iClass) Cxt
remainingTysExpSubst
kvNames' :: [Name]
kvNames' = [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Name]]
kvNames
remainingTysExpSubst' :: [Type]
remainingTysExpSubst' :: Cxt
remainingTysExpSubst' =
(Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Type
substNamesWithKindStar [Name]
kvNames') Cxt
remainingTysExpSubst
remainingTysOrigSubst :: [Type]
remainingTysOrigSubst :: Cxt
remainingTysOrigSubst =
(Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Type
substNamesWithKindStar ([Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
union [Name]
droppedKindVarNames [Name]
kvNames'))
(Cxt -> Cxt) -> Cxt -> Cxt
forall a b. (a -> b) -> a -> b
$ Int -> Cxt -> Cxt
forall a. Int -> [a] -> [a]
take Int
remainingLength Cxt
varTysOrig
isDataFamily :: Bool
isDataFamily :: Bool
isDataFamily = case DatatypeVariant
variant of
DatatypeVariant
Datatype -> Bool
False
DatatypeVariant
Newtype -> Bool
False
DatatypeVariant
DataInstance -> Bool
True
DatatypeVariant
NewtypeInstance -> Bool
True
remainingTysOrigSubst' :: [Type]
remainingTysOrigSubst' :: Cxt
remainingTysOrigSubst' =
if Bool
isDataFamily
then Cxt
remainingTysOrigSubst
else (Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
unSigT Cxt
remainingTysOrigSubst
instanceCxt :: Cxt
instanceCxt :: Cxt
instanceCxt = [Maybe Type] -> Cxt
forall a. [Maybe a] -> [a]
catMaybes [Maybe Type]
preds
instanceType :: Type
instanceType :: Type
instanceType = Type -> Type -> Type
AppT (Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ InvariantClass -> Name
invariantClassName InvariantClass
iClass)
(Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Name -> Cxt -> Type
applyTyCon Name
tyConName Cxt
remainingTysOrigSubst'
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`predMentionsName` [Name]
droppedTyVarNames) Cxt
dataCxt) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
Name -> Type -> Q ()
forall a. Name -> Type -> a
datatypeContextError Name
tyConName Type
instanceType
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Cxt -> Cxt -> Bool
canEtaReduce Cxt
remainingTysExpSubst' Cxt
droppedTysExpSubst) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
Type -> Q ()
forall a. Type -> a
etaReductionError Type
instanceType
(Cxt, Type) -> Q (Cxt, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Cxt
instanceCxt, Type
instanceType)
deriveConstraint :: InvariantClass -> Type -> (Maybe Pred, [Name])
deriveConstraint :: InvariantClass -> Type -> (Maybe Type, [Name])
deriveConstraint InvariantClass
iClass Type
t
| Bool -> Bool
not (Type -> Bool
isTyVar Type
t) = (Maybe Type
forall a. Maybe a
Nothing, [])
| Bool
otherwise = case Int -> Type -> Maybe [Name]
hasKindVarChain Int
1 Type
t of
Just [Name]
ns | InvariantClass
iClass InvariantClass -> InvariantClass -> Bool
forall a. Ord a => a -> a -> Bool
>= InvariantClass
Invariant
-> (Type -> Maybe Type
forall a. a -> Maybe a
Just (Name -> Name -> Type
applyClass Name
invariantTypeName Name
tName), [Name]
ns)
Maybe [Name]
_ -> case Int -> Type -> Maybe [Name]
hasKindVarChain Int
2 Type
t of
Just [Name]
ns | InvariantClass
iClass InvariantClass -> InvariantClass -> Bool
forall a. Eq a => a -> a -> Bool
== InvariantClass
Invariant2
-> (Type -> Maybe Type
forall a. a -> Maybe a
Just (Name -> Name -> Type
applyClass Name
invariant2TypeName Name
tName), [Name]
ns)
Maybe [Name]
_ -> (Maybe Type
forall a. Maybe a
Nothing, [])
where
tName :: Name
tName :: Name
tName = Type -> Name
varTToName Type
t
derivingKindError :: InvariantClass -> Name -> a
derivingKindError :: InvariantClass -> Name -> a
derivingKindError InvariantClass
iClass Name
tyConName = String -> a
forall a. HasCallStack => String -> a
error
(String -> a) -> ShowS -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"Cannot derive well-kinded instance of form ‘"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
className
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' '
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ShowS -> ShowS
showParen Bool
True
( String -> ShowS
showString (Name -> String
nameBase Name
tyConName)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" ..."
)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"‘\n\tClass "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
className
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" expects an argument of kind "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Type -> String
forall a. Ppr a => a -> String
pprint (Type -> String) -> (Int -> Type) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Type
createKindChain (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ InvariantClass -> Int
forall a. Enum a => a -> Int
fromEnum InvariantClass
iClass)
(String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
""
where
className :: String
className :: String
className = Name -> String
nameBase (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ InvariantClass -> Name
invariantClassName InvariantClass
iClass
datatypeContextError :: Name -> Type -> a
datatypeContextError :: Name -> Type -> a
datatypeContextError Name
dataName Type
instanceType = String -> a
forall a. HasCallStack => String -> a
error
(String -> a) -> ShowS -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"Can't make a derived instance of ‘"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Type -> String
forall a. Ppr a => a -> String
pprint Type
instanceType)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"‘:\n\tData type ‘"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Name -> String
nameBase Name
dataName)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"‘ must not have a class context involving the last type argument(s)"
(String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
""
existentialContextError :: Name -> a
existentialContextError :: Name -> a
existentialContextError Name
conName = String -> a
forall a. HasCallStack => String -> a
error
(String -> a) -> ShowS -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"Constructor ‘"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Name -> String
nameBase Name
conName)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"‘ must be truly polymorphic in the last argument(s) of the data type"
(String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
""
outOfPlaceTyVarError :: Name -> a
outOfPlaceTyVarError :: Name -> a
outOfPlaceTyVarError Name
conName = String -> a
forall a. HasCallStack => String -> a
error
(String -> a) -> ShowS -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"Constructor ‘"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Name -> String
nameBase Name
conName)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"‘ must only use its last two type variable(s) within"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" the last two argument(s) of a data type"
(String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
""
etaReductionError :: Type -> a
etaReductionError :: Type -> a
etaReductionError Type
instanceType = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$
String
"Cannot eta-reduce to an instance of form \n\tinstance (...) => "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
instanceType