module Data.Functor.Invariant.TH (
deriveInvariant
, deriveInvariant2
, 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
deriveInvariant :: Name -> Q [Dec]
deriveInvariant = deriveInvariantClass Invariant
deriveInvariant2 :: Name -> Q [Dec]
deriveInvariant2 = deriveInvariantClass Invariant2
makeInvmap :: Name -> Q Exp
makeInvmap = makeInvmapClass Invariant
makeInvmap2 :: Name -> Q Exp
makeInvmap2 = makeInvmapClass Invariant2
deriveInvariantClass :: InvariantClass -> Name -> Q [Dec]
deriveInvariantClass iClass tyConName = do
info <- reify tyConName
case info of
TyConI{} -> deriveInvariantPlainTy iClass tyConName
#if MIN_VERSION_template_haskell(2,7,0)
DataConI{} -> deriveInvariantDataFamInst iClass tyConName
FamilyI (FamilyD DataFam _ _ _) _ ->
error $ ns ++ "Cannot use a data family name. Use a data family instance constructor instead."
FamilyI (FamilyD TypeFam _ _ _) _ ->
error $ ns ++ "Cannot use a type family name."
_ -> error $ ns ++ "The name must be of a plain type constructor or 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.deriveInvariant: "
deriveInvariantPlainTy :: InvariantClass -> Name -> Q [Dec]
deriveInvariantPlainTy iClass tyConName =
withTyCon tyConName fromCons
where
className :: Name
className = invariantClassNameTable iClass
fromCons :: Cxt -> [TyVarBndr] -> [Con] -> Q [Dec]
fromCons ctxt tvbs cons = (:[]) `fmap`
instanceD (return instanceCxt)
(return $ AppT (ConT className) instanceType)
(invmapDecs droppedNbs cons)
where
(instanceCxt, instanceType, droppedNbs) =
cxtAndTypePlainTy iClass tyConName ctxt tvbs
#if MIN_VERSION_template_haskell(2,7,0)
deriveInvariantDataFamInst :: InvariantClass -> Name -> Q [Dec]
deriveInvariantDataFamInst iClass dataFamInstName =
withDataFamInstCon dataFamInstName fromDec
where
className :: Name
className = invariantClassNameTable iClass
fromDec :: [TyVarBndr] -> Cxt -> Name -> [Type] -> [Con] -> Q [Dec]
fromDec famTvbs ctxt parentName instTys cons = (:[]) `fmap`
instanceD (return instanceCxt)
(return $ AppT (ConT className) instanceType)
(invmapDecs droppedNbs cons)
where
(instanceCxt, instanceType, droppedNbs) =
cxtAndTypeDataFamInstCon iClass parentName ctxt famTvbs instTys
#endif
invmapDecs :: [NameBase] -> [Con] -> [Q Dec]
invmapDecs nbs cons =
[ funD classFuncName
[ clause []
(normalB $ makeInvmapForCons nbs cons)
[]
]
]
where
classFuncName :: Name
classFuncName = invmapNameTable . toEnum $ length nbs
makeInvmapClass :: InvariantClass -> Name -> Q Exp
makeInvmapClass iClass tyConName = do
info <- reify tyConName
case info of
TyConI{} -> withTyCon tyConName $ \ctxt tvbs decs ->
let nbs = thd3 $ cxtAndTypePlainTy iClass tyConName ctxt tvbs
in nbs `seq` makeInvmapForCons nbs decs
#if MIN_VERSION_template_haskell(2,7,0)
DataConI{} -> withDataFamInstCon tyConName $ \famTvbs ctxt parentName instTys cons ->
let nbs = thd3 $ cxtAndTypeDataFamInstCon iClass parentName ctxt famTvbs instTys
in nbs `seq` makeInvmapForCons nbs cons
FamilyI (FamilyD DataFam _ _ _) _ ->
error $ ns ++ "Cannot use a data family name. Use a data family instance constructor instead."
FamilyI (FamilyD TypeFam _ _ _) _ ->
error $ ns ++ "Cannot use a type family name."
_ -> error $ ns ++ "The name must be of a plain type constructor or 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.makeInvmap: "
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 $ invmapConstNameTable iClass
, if null cons
then appE (varE errorValName)
(stringE $ "Void " ++ nameBase (invmapNameTable iClass))
else caseE (varE value)
(map (makeInvmapForCon iClass tvis) cons)
] ++ map varE argNames
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)
[]
makeInvmapForArg :: InvariantClass
-> Name
-> [TyVarInfo]
-> Type
-> Name
-> Q Exp
makeInvmapForArg iClass conName tvis ty tyExpName = do
ty' <- expandSyn ty
makeInvmapForArg' iClass conName tvis ty' tyExpName
makeInvmapForArg' :: InvariantClass
-> Name
-> [TyVarInfo]
-> Type
-> Name
-> Q Exp
makeInvmapForArg' iClass conName tvis ty tyExpName =
appE (makeInvmapForType iClass conName tvis True ty) (varE tyExpName)
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
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 (invmapNameTable (toEnum numLastArgs))
: doubleMap (makeInvmapForType iClass conName tvis) rhsArgs
)
else do x <- newName "x"
lamE [varP x] $ varE x
withTyCon :: Name
-> (Cxt -> [TyVarBndr] -> [Con] -> Q a)
-> Q a
withTyCon name f = do
info <- reify name
case info of
TyConI dec ->
case dec of
DataD ctxt _ tvbs cons _ -> f ctxt tvbs cons
NewtypeD ctxt _ tvbs con _ -> f ctxt tvbs [con]
other -> error $ ns ++ "Unsupported type " ++ show other ++ ". Must be a data type or newtype."
_ -> error $ ns ++ "The name must be of a plain type constructor."
where
ns :: String
ns = "Data.Functor.Invariant.TH.withTyCon: "
#if MIN_VERSION_template_haskell(2,7,0)
withDataFam :: Name
-> ([TyVarBndr] -> [Dec] -> Q a)
-> Q a
withDataFam name f = do
info <- reify name
case info of
FamilyI (FamilyD DataFam _ tvbs _) decs -> f tvbs decs
FamilyI (FamilyD TypeFam _ _ _) _ ->
error $ ns ++ "Cannot use a type family name."
other -> error $ ns ++ "Unsupported type " ++ show other ++ ". Must be a data family name."
where
ns :: String
ns = "Data.Functor.Invariant.TH.withDataFam: "
withDataFamInstCon :: Name
-> ([TyVarBndr] -> Cxt -> Name -> [Type] -> [Con] -> Q a)
-> Q a
withDataFamInstCon dficName f = do
dficInfo <- reify dficName
case dficInfo of
DataConI _ _ parentName _ -> do
parentInfo <- reify parentName
case parentInfo of
FamilyI (FamilyD DataFam _ _ _) _ -> withDataFam parentName $ \famTvbs decs ->
let sameDefDec = flip find decs $ \dec ->
case dec of
DataInstD _ _ _ cons' _ -> any ((dficName ==) . constructorName) cons'
NewtypeInstD _ _ _ con _ -> dficName == constructorName con
_ -> error $ ns ++ "Must be a data or newtype instance."
(ctxt, instTys, cons) = case sameDefDec of
Just (DataInstD ctxt' _ instTys' cons' _) -> (ctxt', instTys', cons')
Just (NewtypeInstD ctxt' _ instTys' con _) -> (ctxt', instTys', [con])
_ -> error $ ns ++ "Could not find data or newtype instance constructor."
in f famTvbs ctxt parentName instTys cons
_ -> error $ ns ++ "Data constructor " ++ show dficName ++ " is not from a data family instance."
other -> error $ ns ++ "Unsupported type " ++ show other ++ ". Must be a data family instance constructor."
where
ns :: String
ns = "Data.Functor.Invariant.TH.withDataFamInstCon: "
#endif
cxtAndTypePlainTy :: InvariantClass
-> Name
-> Cxt
-> [TyVarBndr]
-> (Cxt, Type, [NameBase])
cxtAndTypePlainTy iClass tyConName dataCxt tvbs =
if remainingLength < 0 || not (wellKinded droppedKinds)
then derivingKindError iClass tyConName
else if any (`predMentionsNameBase` droppedNbs) dataCxt
then datatypeContextError tyConName instanceType
else (instanceCxt, instanceType, droppedNbs)
where
instanceCxt :: Cxt
instanceCxt = map (applyInvariantConstraint)
$ filter (needsConstraint iClass . tvbKind) remaining
instanceType :: Type
instanceType = 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
#if MIN_VERSION_template_haskell(2,7,0)
cxtAndTypeDataFamInstCon :: InvariantClass
-> Name
-> Cxt
-> [TyVarBndr]
-> [Type]
-> (Cxt, Type, [NameBase])
cxtAndTypeDataFamInstCon iClass parentName dataCxt famTvbs instTysAndKinds =
if remainingLength < 0 || not (wellKinded droppedKinds)
then derivingKindError iClass parentName
else if any (`predMentionsNameBase` droppedNbs) dataCxt
then datatypeContextError parentName instanceType
else if canEtaReduce remaining dropped
then (instanceCxt, instanceType, droppedNbs)
else etaReductionError instanceType
where
instanceCxt :: Cxt
instanceCxt = map (applyInvariantConstraint)
$ filter (needsConstraint iClass . tvbKind) lhsTvbs
instanceType :: Type
instanceType = applyTyCon parentName
$ map unSigT remaining
remainingLength :: Int
remainingLength = length famTvbs fromEnum iClass
remaining, dropped :: [Type]
(remaining, dropped) = splitAt remainingLength rhsTypes
droppedKinds :: [Kind]
droppedKinds = map tvbKind . snd $ splitAt remainingLength famTvbs
droppedNbs :: [NameBase]
droppedNbs = map varTToNameBase dropped
instTypes :: [Type]
instTypes =
# if __GLASGOW_HASKELL__ >= 710 || !(MIN_VERSION_template_haskell(2,8,0))
instTysAndKinds
# else
drop (Set.size . Set.unions $ map (distinctKindVars . tvbKind) famTvbs)
instTysAndKinds
# endif
lhsTvbs :: [TyVarBndr]
lhsTvbs = map (uncurry replaceTyVarName)
. filter (isTyVar . snd)
. take remainingLength
$ zip famTvbs rhsTypes
rhsTypes :: [Type]
rhsTypes =
# if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710
instTypes ++ map tvbToType
(drop (length instTypes)
famTvbs)
# else
instTypes
# endif
#endif
applyInvariantConstraint :: TyVarBndr -> Pred
applyInvariantConstraint (PlainTV _) = error "Cannot constrain type of kind *"
applyInvariantConstraint (KindedTV name kind) = applyClass className name
where
className :: Name
className = invariantClassNameTable . toEnum $ numKindArrows kind
needsConstraint :: InvariantClass -> Kind -> Bool
needsConstraint iClass kind =
fromEnum iClass >= nka
&& nka >= fromEnum Invariant
&& canRealizeKindStarChain kind
where
nka :: Int
nka = numKindArrows 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 $ invariantClassNameTable iClass
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)"
$ ""
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"
$ ""
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"
$ ""
#if MIN_VERSION_template_haskell(2,7,0)
etaReductionError :: Type -> a
etaReductionError instanceType = error $
"Cannot eta-reduce to an instance of form \n\tinstance (...) => "
++ pprint instanceType
#else
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