{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Constraint.Deriving.DeriveAll
( DeriveAll (..), DeriveContext
, deriveAllPass
, CorePluginEnvRef, initCorePluginEnv
) where
import Class (Class, classTyCon)
import CoAxiom (CoAxBranch, coAxBranchIncomps,
coAxBranchLHS, coAxBranchRHS,
coAxiomBranches, coAxiomSingleBranch,
fromBranches)
import Control.Applicative (Alternative (..))
import Control.Arrow (second)
import Control.Monad (join, unless)
import Data.Data (Data)
import Data.Either (partitionEithers)
import qualified Data.Kind (Constraint, Type)
import Data.List (groupBy, isPrefixOf, nubBy, sortOn)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Monoid (First (..), Monoid (..))
import qualified FamInstEnv
import GhcPlugins hiding (OverlapMode (..), overlapMode,
(<>))
import qualified GhcPlugins
import InstEnv (ClsInst, DFunInstType)
import qualified InstEnv
import qualified OccName
import Panic (panicDoc)
import TcType (tcSplitDFunTy)
import qualified Unify
import Data.Constraint.Deriving.CorePluginM
data DeriveAll
= DeriveAll
| DeriveAllBut [String]
deriving (Eq, Show, Read, Data)
type family DeriveContext (t :: Data.Kind.Type) :: Data.Kind.Constraint
deriveAllPass :: CorePluginEnvRef -> CoreToDo
deriveAllPass eref = CoreDoPluginPass "Data.Constraint.Deriving.DeriveAll"
(\x -> fromMaybe x <$> runCorePluginM (deriveAllPass' x) eref)
deriveAllPass' :: ModGuts -> CorePluginM ModGuts
deriveAllPass' gs = go (mg_tcs gs) annotateds gs
where
annotateds :: UniqFM [(Name, DeriveAll)]
annotateds = getModuleAnns gs
go :: [TyCon] -> UniqFM [(Name, DeriveAll)] -> ModGuts -> CorePluginM ModGuts
go [] anns guts = do
unless (isNullUFM anns) $
pluginWarning $ "One or more DeriveAll annotations are ignored:"
$+$ vcat
(map (pprBulletNameLoc . fst) . join $ eltsUFM anns)
$+$ "Note, DeriveAll is meant to be used only on type declarations."
return guts
go (x:xs) anns guts
| Just ((xn, da):ds) <- lookupUFM anns x = do
unless (null ds) $
pluginLocatedWarning (nameSrcSpan xn) $
"Ignoring redundant DeriveAll annotions" $$
hcat
[ "(the plugin needs only one annotation per type declaration, but got "
, speakN (length ds + 1)
, ")"
]
pluginDebug $ "DeriveAll invoked on TyCon" <+> ppr x
(newInstances, newBinds) <- unzip . fromMaybe [] <$> try (deriveAll da x guts)
go xs (delFromUFM anns x) guts
{ mg_insts = newInstances ++ mg_insts guts
, mg_binds = newBinds ++ mg_binds guts
}
go (_:xs) anns guts = go xs anns guts
pprBulletNameLoc n = hsep
[" ", bullet, ppr $ occName n, ppr $ nameSrcSpan n]
deriveAll :: DeriveAll -> TyCon -> ModGuts -> CorePluginM [(InstEnv.ClsInst, CoreBind)]
deriveAll da tyCon guts
| True <- isNewTyCon tyCon
, False <- isClassTyCon tyCon
, [dataCon] <- tyConDataCons tyCon
= do
dcInsts <- lookupDeriveContextInstances guts tyCon
pluginDebug
. hang "DeriveAll (1): DeriveContext instances:" 2
. vcat $ map ppr dcInsts
unpackedInsts <-
if null dcInsts
then (:[]) <$> mockInstance tyCon
else return $ map unpackInstance dcInsts
pluginDebug
. hang "DeriveAll (1): DeriveContext instance parameters and RHSs:" 2
. vcat $ map ppr unpackedInsts
allMatchingTypes <- join <$>
traverse (lookupMatchingBaseTypes guts tyCon dataCon) unpackedInsts
pluginDebug
. hang "DeriveAll (2): matching base types:" 2
. vcat $ map ppr allMatchingTypes
r <- join <$> traverse (lookupMatchingInstances da guts) allMatchingTypes
pluginDebug
. hang "DeriveAll (3): matching class instances:" 2
. vcat $ map (ppr . fst) r
return $ filterDupInsts r
| otherwise
= pluginLocatedError
(nameSrcSpan $ tyConName tyCon)
"DeriveAll works only on plain newtype declarations"
where
filterDupInsts = nubBy $ \(x,_) (y, _) -> InstEnv.identicalClsInstHead x y
mockInstance tc = do
let tvs = tyConTyVars tc
tys = mkTyVarTys tvs
rhs <- ask tyEmptyConstraint
return (tys, rhs)
unpackInstance i
= let tys = case tyConAppArgs_maybe <$> FamInstEnv.fi_tys i of
[Just ts] -> ts
_ -> panicDoc "DeriveAll" $
hsep
[ "I faced an impossible type when"
<+> "matching an instance of type family DeriveContext:"
, ppr i, "at"
, ppr $ nameSrcSpan $ getName i]
rhs = FamInstEnv.fi_rhs i
in (tys, rhs)
lookupTyFamInstances :: ModGuts -> TyCon -> CorePluginM [FamInstEnv.FamInst]
lookupTyFamInstances guts fTyCon = do
pkgFamInstEnv <- liftCoreM getPackageFamInstEnv
return $ FamInstEnv.lookupFamInstEnvByTyCon
(pkgFamInstEnv, mg_fam_inst_env guts) fTyCon
lookupDeriveContextInstances :: ModGuts -> TyCon -> CorePluginM [FamInstEnv.FamInst]
lookupDeriveContextInstances guts tyCon = do
allInsts <- ask tyConDeriveContext >>= lookupTyFamInstances guts
return $ filter check allInsts
where
check fi = case tyConAppTyCon_maybe <$> FamInstEnv.fi_tys fi of
Just tc : _ -> tc == tyCon
_ -> False
data MatchingType
= MatchingType
{ mtCtxEqs :: [(TyVar, Type)]
, mtTheta :: ThetaType
, mtOverlapMode :: OverlapMode
, mtBaseType :: Type
, mtNewType :: Type
, mtIgnoreList :: [Type]
}
instance Outputable MatchingType where
ppr MatchingType {..} = vcat
[ "MatchingType"
, "{ mtCtxEqs = " GhcPlugins.<> ppr mtCtxEqs
, ", mtTheta = " GhcPlugins.<> ppr mtTheta
, ", mtOverlapMode = " GhcPlugins.<> text (show mtOverlapMode)
, ", mtBaseType = " GhcPlugins.<> ppr mtBaseType
, ", mtNewType = " GhcPlugins.<> ppr mtNewType
, ", mtIgnorelist = " GhcPlugins.<> ppr mtIgnoreList
, "}"
]
substMatchingType :: TCvSubst -> MatchingType -> MatchingType
substMatchingType sub MatchingType {..} = MatchingType
{ mtCtxEqs = map (second $ substTyAddInScope sub) mtCtxEqs
, mtTheta = map (substTyAddInScope sub) mtTheta
, mtOverlapMode = mtOverlapMode
, mtBaseType = substTyAddInScope sub mtBaseType
, mtNewType = substTyAddInScope sub mtNewType
, mtIgnoreList = map (substTyAddInScope sub) mtIgnoreList
}
replaceTyMatchingType :: Type -> Type -> MatchingType -> MatchingType
replaceTyMatchingType oldt newt MatchingType {..} = MatchingType
{ mtCtxEqs = map (second rep) mtCtxEqs
, mtTheta = map rep mtTheta
, mtOverlapMode = mtOverlapMode
, mtBaseType = rep mtBaseType
, mtNewType = rep mtNewType
, mtIgnoreList = map rep mtIgnoreList
}
where
rep = replaceTypeOccurrences oldt newt
cleanupMatchingType :: MatchingType -> MatchingType
cleanupMatchingType mt0 = go (groupLists $ mtCtxEqs mt0) mt0 { mtCtxEqs = []}
where
groupOn f = groupBy (\x y -> f x == f y)
flattenSnd [] = []
flattenSnd ([]:xs) = flattenSnd xs
flattenSnd (ts@((tv,_):_):xs) = (tv, map snd ts): flattenSnd xs
groupLists = flattenSnd . groupOn fst . sortOn fst
go :: [(TyVar, [Type])] -> MatchingType -> MatchingType
go [] mt = mt
go ((_, []):xs) mt = go xs mt
go ((tv,[ty]):xs) mt
= let sub = extendTCvSubst emptyTCvSubst tv ty
in go (map (second (map $ substTyAddInScope sub)) xs)
$ substMatchingType sub mt
go ((tv, tys):xs) mt
= case removeEqualTypes tys of
[] -> go xs mt
[t] -> go ((tv, [t]):xs) mt
ts -> go xs mt { mtCtxEqs = mtCtxEqs mt ++ map ((,) tv) ts }
removeEqualTypes [] = []
removeEqualTypes [t] = [t]
removeEqualTypes (t:ts)
| any (eqType t) ts = removeEqualTypes ts
| otherwise = t : removeEqualTypes ts
tryHigherRanks :: MatchingType -> [MatchingType]
tryHigherRanks mt@MatchingType {..}
| Just (mtBaseType', bt) <- splitAppTy_maybe mtBaseType
, Just (mtNewType' , nt) <- splitAppTy_maybe mtNewType
, Just btv <- getTyVar_maybe bt
, Just ntv <- getTyVar_maybe nt
, btv == ntv
, not . elem btv
. (map fst mtCtxEqs ++)
. tyCoVarsOfTypesWellScoped
$ [mtBaseType', mtNewType']
++ map snd mtCtxEqs
++ mtTheta
++ mtIgnoreList
= let mt' = mt
{ mtBaseType = mtBaseType'
, mtNewType = mtNewType'
}
in mt : tryHigherRanks mt'
tryHigherRanks mt = [mt]
lookupMatchingBaseTypes :: ModGuts
-> TyCon
-> DataCon
-> ([Type], Type)
-> CorePluginM [MatchingType]
lookupMatchingBaseTypes guts tyCon dataCon (tys, constraints) = do
ftheta <- filterTheta theta
let initMt = MatchingType
{ mtCtxEqs = fst ftheta
, mtTheta = snd ftheta
, mtOverlapMode = NoOverlap
, mtBaseType = baseType
, mtNewType = newType
, mtIgnoreList = []
}
(>>= tryHigherRanks . cleanupMatchingType)
. take 1000
<$> go (cleanupMatchingType initMt)
where
go :: MatchingType -> CorePluginM [MatchingType]
go mt = expandOneFamily guts mt >>= \case
Nothing -> pure [mt]
Just mts -> join <$> traverse go mts
newType = mkTyConApp tyCon tys
theta = splitCts constraints ++ dataConstraints
splitCts c = case splitTyConApp_maybe c of
Nothing -> [c]
Just (tc, ts) ->
if isCTupleTyConName $ getName tc
then foldMap splitCts ts
else [c]
(dataConstraints, baseType) = case dataConInstSig dataCon tys of
([], cts, [bt]) -> (cts, bt)
_ -> panicDoc "DeriveAll" $ hsep
[ "Impossible happened:"
, "expected a newtype constructor"
, "with no existential tyvars and a single type argument,"
, "but got", ppr dataCon
, "at", ppr $ nameSrcSpan $ getName dataCon ]
filterTheta :: ThetaType -> CorePluginM ([(TyVar, Type)], ThetaType)
filterTheta = fmap (partitionEithers . join) . traverse
(\t -> do
teqClass <- ask classTypeEq
filterTheta' teqClass t
)
filterTheta' :: Class -> Type -> CorePluginM [Either (TyVar, Type) PredType]
filterTheta' teqClass t = go (classifyPredType t)
where
go (EqPred _ t1 t2)
| Just tv <- getTyVar_maybe t1
= return [Left (tv, t2)]
| Just tv <- getTyVar_maybe t2
= return [Left (tv, t1)]
| otherwise
= do
tv <- newTyVar (typeKind t1)
return [Left (tv, t1), Left (tv, t2)]
go (ClassPred c ts)
| c == heqClass
, [_, _, t1, t2] <- ts
= go (EqPred ReprEq t1 t2)
| c == teqClass
, [_, t1, t2] <- ts
= go (EqPred ReprEq t1 t2)
| otherwise
= return [Right t]
go _ = return [Right t]
expandOneFamily :: ModGuts -> MatchingType -> CorePluginM (Maybe [MatchingType])
expandOneFamily guts mt@MatchingType{..} = case mfam of
Nothing -> return Nothing
Just (ff, t) -> expandFamily guts ff t >>= \case
Nothing -> return $ Just [mt { mtIgnoreList = t : mtIgnoreList }]
Just es -> return $ Just $ map (toMT t) es
where
toMT ft (omode, rezt, subst)
= let famOcc = substTyAddInScope subst ft
newMt = substMatchingType subst mt
in if eqType ft rezt
then mt { mtIgnoreList = ft : mtIgnoreList }
else replaceTyMatchingType famOcc rezt newMt
{ mtOverlapMode = omode }
look = First . lookupFamily mtIgnoreList
First mfam = mconcat
[ foldMap (look . snd) mtCtxEqs
, foldMap look mtTheta
, look mtBaseType
, look mtNewType
]
lookupFamily :: [Type] -> Type -> Maybe (FamTyConFlav, Type)
lookupFamily ignoreLst t
| Just (tyCon, tys) <- splitTyConApp_maybe t
= case foldMap (First . lookupFamily ignoreLst) tys of
First (Just r) -> Just r
First Nothing -> famTyConFlav_maybe tyCon >>= \ff ->
if any (eqType t) ignoreLst
then Nothing
else Just (ff, t)
| (_:_, t') <- splitForAllTys t
= lookupFamily ignoreLst t'
| Just (at, rt) <- splitFunTy_maybe t
= lookupFamily ignoreLst at <|> lookupFamily ignoreLst rt
| otherwise
= Nothing
expandFamily :: ModGuts
-> FamTyConFlav
-> Type
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
expandFamily _ AbstractClosedSynFamilyTyCon{} _ = pure Nothing
expandFamily _ BuiltInSynFamTyCon{} _ = pure Nothing
expandFamily _ (ClosedSynFamilyTyCon Nothing) _ = pure Nothing
expandFamily _ (ClosedSynFamilyTyCon (Just coax)) ft
= withFamily ft (pure Nothing) $ const $ expandClosedFamily os bcs
where
bcs = fromBranches $ coAxiomBranches coax
os = if any (not . null . coAxBranchIncomps) bcs
then map overlap bcs else repeat NoOverlap
overlap cb = if null $ coAxBranchIncomps cb
then Overlapping
else Incoherent
expandFamily guts DataFamilyTyCon{} ft
= withFamily ft (pure Nothing) $ expandDataFamily guts
expandFamily guts OpenSynFamilyTyCon ft
= withFamily ft (pure Nothing) $ expandOpenFamily guts
withFamily :: Type -> a -> (TyCon -> [Type] -> a) -> a
withFamily ft def f = case splitTyConApp_maybe ft of
Nothing -> def
Just (tc, ts) -> f tc ts
expandClosedFamily :: [OverlapMode]
-> [CoAxBranch]
-> [Type] -> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
expandClosedFamily _ [] _ = pure Nothing
expandClosedFamily os bs fTyArgs = fmap (Just . catMaybes) $ traverse go $ zip os bs
where
go (om, cb) = do
let flhs' = coAxBranchLHS cb
n = length flhs'
tvs' = tyCoVarsOfTypesWellScoped flhs'
tvs <- traverse freshenTyVar tvs'
let freshenSub = zipTvSubst tvs' $ map mkTyVarTy tvs
flhs = substTys freshenSub flhs'
frhs = substTyAddInScope freshenSub $ coAxBranchRHS cb
t = foldl mkAppTy frhs $ drop n fTyArgs
msub = Unify.tcMatchTys (take n fTyArgs) flhs
return $ (,,) om t <$> msub
expandOpenFamily :: ModGuts
-> TyCon
-> [Type]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
expandOpenFamily guts fTyCon fTyArgs = do
tfInsts <- lookupTyFamInstances guts fTyCon
if null tfInsts
then pure $ Just []
else expandClosedFamily
(repeat NoOverlap)
(coAxiomSingleBranch . FamInstEnv.famInstAxiom <$> tfInsts)
fTyArgs
expandDataFamily :: ModGuts
-> TyCon
-> [Type]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
expandDataFamily guts fTyCon fTyArgs = do
tfInsts <- lookupTyFamInstances guts fTyCon
if null tfInsts
then pure $ Just []
else sequence <$> traverse expandDInstance tfInsts
where
expandDInstance inst
| fitvs <- FamInstEnv.fi_tvs inst
= do
tvs <- traverse freshenTyVar $ fitvs
let freshenSub = zipTvSubst fitvs $ map mkTyVarTy tvs
fitys = substTys freshenSub $ FamInstEnv.fi_tys inst
instTyArgs = align fTyArgs fitys
return $ (,,) NoOverlap (mkTyConApp fTyCon instTyArgs)
<$> Unify.tcMatchTys fTyArgs instTyArgs
align [] _ = []
align xs [] = xs
align (_:xs) (y:ys) = y : align xs ys
data MatchingInstance = MatchingInstance
{ miInst :: ClsInst
, miInstTyVars :: [DFunInstType]
, miTheta :: [(PredType, MatchingPredType)]
}
instance Outputable MatchingInstance where
ppr MatchingInstance {..} = hang "MatchingInstance" 2 $ vcat
[ "{ miInst =" <+> ppr miInst
, ", miInstTyVars =" <+> ppr miInstTyVars
, ", miTheta =" <+> ppr miTheta
]
data MatchingPredType
= MptInstance MatchingInstance
| MptReflexive Coercion
| MptPropagateAs PredType
instance Outputable MatchingPredType where
ppr (MptInstance x) = "MptInstance" <+> ppr x
ppr (MptReflexive x) = "MptReflexive" <+> ppr x
ppr (MptPropagateAs x) = "MptPropagateAs" <+> ppr x
findInstance :: InstEnv.InstEnvs
-> Type
-> ClsInst
-> Maybe MatchingInstance
findInstance ie t i
|
Just sub <- getFirst $ foldMap (First . flip (recMatchTyKi False) t) iTyPams
, newTyPams <- map (substTyAddInScope sub) iTyPams
= matchInstance ie iClass newTyPams
| otherwise
= Nothing
where
(_, _, iClass, iTyPams) = InstEnv.instanceSig i
matchInstance :: InstEnv.InstEnvs
-> Class
-> [Type]
-> Maybe MatchingInstance
matchInstance ie cls ts
| ([(i, tyVarSubs)], _notMatchButUnify, _safeHaskellStuff)
<- InstEnv.lookupInstEnv False ie cls ts
, (iTyVars, iTheta, _, _) <- InstEnv.instanceSig i
, sub <- mkTvSubstPrs
. catMaybes $ zipWith (fmap . (,)) iTyVars tyVarSubs
= do
mpts <- traverse (matchPredType ie . substTyAddInScope sub) iTheta
return MatchingInstance
{ miInst = i
, miInstTyVars = tyVarSubs
, miTheta = zip iTheta mpts
}
| otherwise
= Nothing
matchPredType :: InstEnv.InstEnvs
-> PredType
-> Maybe MatchingPredType
matchPredType ie pt = go $ classifyPredType pt
where
go (ClassPred cls ts)
| Just mi <- matchInstance ie cls ts
= Just $ MptInstance mi
| [] <- tyCoVarsOfTypesWellScoped ts
= Nothing
| otherwise = Just $ MptPropagateAs pt
go (EqPred rel t1 t2)
| eqType t1 t2 = Just . MptReflexive $ case rel of
NomEq -> mkReflCo Nominal t1
ReprEq -> mkReflCo Representational t1
| Unify.typesCantMatch [(t1,t2)]
= Nothing
| otherwise = Just $ MptPropagateAs pt
go _ = Just $ MptPropagateAs pt
type TyExp = (Type, CoreExpr)
type TyBndr = (Type, CoreBndr)
mtmiToExpression :: MatchingType
-> MatchingInstance
-> CorePluginM TyExp
mtmiToExpression MatchingType {..} mi = do
(bndrs, (tOrig, e)) <- miToExpression' [] mi
let extraTheta
= filter (\t -> not $ any (eqType t . fst) bndrs) mtTheta
tRepl = replaceTypeOccurrences mtBaseType mtNewType tOrig
tFun = mkFunTys (extraTheta ++ map fst bndrs) tRepl
tvs = tyCoVarsOfTypeWellScoped tFun
return
( mkSpecForAllTys tvs tFun
, mkCoreLams (tvs ++ map mkWildValBinder extraTheta ++ map snd bndrs)
$ mkCast e
$ mkUnsafeCo Representational tOrig tRepl
)
miToExpression' :: [TyExp]
-> MatchingInstance
-> CorePluginM ([TyBndr], TyExp)
miToExpression' availPTs MatchingInstance {..} = do
(bndrs, eArgs) <- addArgs availPTs $ map snd miTheta
return
( bndrs
, ( newIHead
, mkCoreApps eDFunWithTyPams eArgs
)
)
where
(iTyVars, _, iClass, iTyPams) = InstEnv.instanceSig miInst
tyVarVals = zipWith (fromMaybe . mkTyVarTy) iTyVars miInstTyVars
sub = mkTvSubstPrs . catMaybes
$ zipWith (fmap . (,)) iTyVars miInstTyVars
newTyPams = map (substTyAddInScope sub) iTyPams
newIHead = mkTyConApp (classTyCon iClass) newTyPams
eDFun = Var $ InstEnv.instanceDFunId miInst
eDFunWithTyPams = mkTyApps eDFun tyVarVals
addArgs :: [TyExp]
-> [MatchingPredType]
-> CorePluginM ([TyBndr], [CoreExpr])
addArgs _ [] = pure ([], [])
addArgs ps (x:xs) = do
(tbdrs, e) <- mptToExpression ps x
let ps' = ps ++ map (Var <$>) tbdrs
(tbdrs', es) <- addArgs ps' xs
return
( tbdrs ++ tbdrs'
, e:es
)
mptToExpression :: [TyExp]
-> MatchingPredType
-> CorePluginM ([TyBndr], CoreExpr)
mptToExpression ps (MptInstance mi)
= fmap snd <$> miToExpression' ps mi
mptToExpression _ (MptReflexive c)
= pure ([], Coercion c)
mptToExpression ps (MptPropagateAs pt)
= case mte of
Just e -> pure ([], e)
Nothing -> do
loc <- liftCoreM getSrcSpanM
u <- getUniqueM
let n = mkInternalName u
(mkOccName OccName.varName $ "dFunArg_" ++ show u) loc
v = mkLocalIdOrCoVar n pt
return ([(pt,v)], Var v)
where
mte = getFirst $ foldMap getSamePT ps
getSamePT (t, e)
| eqType t pt = First $ Just e
| otherwise = First Nothing
lookupMatchingInstances :: DeriveAll
-> ModGuts
-> MatchingType
-> CorePluginM [(ClsInst, CoreBind)]
lookupMatchingInstances da guts mt
| Just bTyCon <- tyConAppTyCon_maybe $ mtBaseType mt = do
ie <- getInstEnvs guts
let clsInsts = lookupClsInsts ie bTyCon
pluginDebug $ hang "lookupMatchingInstances candidate instances:" 2 $
vcat $ map ppr clsInsts
catMaybes <$> traverse (lookupMatchingInstance da ie mt) clsInsts
| otherwise = fmap (const []) . pluginDebug $ hcat
[ text "DeriveAll.lookupMatchingInstances found no class instances for "
, ppr (mtBaseType mt)
, text ", because it could not get the type constructor."
]
lookupMatchingInstance :: DeriveAll
-> InstEnv.InstEnvs
-> MatchingType
-> ClsInst
-> CorePluginM (Maybe (ClsInst, CoreBind))
lookupMatchingInstance da ie mt@MatchingType {..} baseInst
| not . unwantedName da $ getName iClass
, all (noneTy (unwantedName DeriveAll)) iTyPams
= case findInstance ie mtBaseType baseInst of
Just mi -> do
(t, e) <- mtmiToExpression mt mi
newN <- newName (occNameSpace baseDFunName)
$ occNameString baseDFunName
++ show (getUnique baseDFunId)
++ newtypeNameS
let (newTyVars, _, _, newTyPams) = tcSplitDFunTy t
newDFunId = mkExportedLocalId
(DFunId isNewType) newN t
return $ Just
( InstEnv.mkLocalInstance
newDFunId
( toOverlapFlag $ mappend mtOverlapMode baseOM )
newTyVars iClass newTyPams
, NonRec newDFunId e
)
Nothing
| Just sub <- getFirst
$ foldMap (First . flip (recMatchTyKi True) mtBaseType) iTyPams
-> lookupMatchingInstance da ie (substMatchingType sub mt) baseInst
| otherwise
-> do
pluginDebug $ hang "Ignored instance" 2
$ ppr mtBaseType <+> ppr baseInst
pure Nothing
| otherwise
= pure Nothing
where
baseOM = instanceOverlapMode baseInst
baseDFunId = InstEnv.instanceDFunId baseInst
(_, _, iClass, iTyPams) = InstEnv.instanceSig baseInst
isNewType = isNewTyCon (classTyCon iClass)
baseDFunName = occName . idName $ baseDFunId
newtypeNameS = case tyConAppTyCon_maybe mtNewType of
Nothing -> "DeriveAll-generated"
Just tc -> occNameString $ occName $ tyConName tc
noneTy :: (Name -> Bool) -> Type -> Bool
noneTy f = not . uniqSetAny f . orphNamesOfType
#if __GLASGOW_HASKELL__ < 802
where
uniqSetAny g = foldl (\a -> (||) a . g) False
#endif
unwantedName :: DeriveAll -> Name -> Bool
unwantedName da n
| modName == "GHC.Generics" = True
| modName == "Data.Typeable" = True
| modName == "Data.Data" = True
| "Language.Haskell.TH"
`isPrefixOf` modName = True
| valName == "Coercible" = True
| DeriveAllBut xs <- da
, valName `elem` xs = True
| otherwise = False
where
modName = moduleNameString . moduleName $ nameModule n
valName = occNameString $ getOccName n