module GHC.Tc.Utils.Instantiate (
topSkolemise,
topInstantiate, topInstantiateInferred,
instCall, instDFunType, instStupidTheta, instTyVarsWith,
newWanted, newWanteds,
tcInstType, tcInstTypeBndrs,
tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarsAt,
tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX,
freshenTyVarBndrs, freshenCoVarBndrsX,
tcInstInvisibleTyBindersN, tcInstInvisibleTyBinders, tcInstInvisibleTyBinder,
newOverloadedLit, mkOverLit,
newClsInst,
tcGetInsts, tcGetInstEnvs, getOverlapFlag,
tcExtendLocalInstEnv,
instCallConstraints, newMethodFromName,
tcSyntaxName,
tyCoVarsOfWC,
tyCoVarsOfCt, tyCoVarsOfCts,
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Tc.Gen.Expr( tcCheckPolyExpr, tcSyntaxOp )
import GHC.Tc.Utils.Unify( unifyType, unifyKind )
import GHC.Types.Basic ( IntegralLit(..), SourceText(..) )
import GHC.Hs
import GHC.Tc.Utils.Zonk
import GHC.Tc.Utils.Monad
import GHC.Tc.Types.Constraint
import GHC.Core.Predicate
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.Env
import GHC.Tc.Types.Evidence
import GHC.Core.InstEnv
import GHC.Builtin.Types ( heqDataCon, eqDataCon, integerTyConName )
import GHC.Core ( isOrphan )
import GHC.Tc.Instance.FunDeps
import GHC.Tc.Utils.TcMType
import GHC.Core.Type
import GHC.Core.Multiplicity
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Ppr ( debugPprType )
import GHC.Tc.Utils.TcType
import GHC.Driver.Types
import GHC.Core.Class( Class )
import GHC.Types.Id.Make( mkDictFunId )
import GHC.Core( Expr(..) )
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Var
import GHC.Core.DataCon
import GHC.Types.Var.Env
import GHC.Builtin.Names
import GHC.Types.SrcLoc as SrcLoc
import GHC.Driver.Session
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Types.Basic ( TypeOrKind(..) )
import qualified GHC.LanguageExtensions as LangExt
import Data.List ( sortBy, mapAccumL )
import Control.Monad( unless )
import Data.Function ( on )
newMethodFromName
:: CtOrigin
-> Name
-> [TcRhoType]
-> TcM (HsExpr GhcTc)
newMethodFromName origin name ty_args
= do { id <- tcLookupId name
; let ty = piResultTys (idType id) ty_args
(theta, _caller_knows_this) = tcSplitPhiTy ty
; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta )
instCall origin ty_args theta
; return (mkHsWrap wrap (HsVar noExtField (noLoc id))) }
topSkolemise :: TcSigmaType
-> TcM ( HsWrapper
, [(Name,TyVar)]
, [EvVar]
, TcRhoType )
topSkolemise ty
= go init_subst idHsWrapper [] [] ty
where
init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))
go subst wrap tv_prs ev_vars ty
| (tvs, theta, inner_ty) <- tcSplitSigmaTy ty
, not (null tvs && null theta)
= do { (subst', tvs1) <- tcInstSkolTyVarsX subst tvs
; ev_vars1 <- newEvVars (substTheta subst' theta)
; go subst'
(wrap <.> mkWpTyLams tvs1 <.> mkWpLams ev_vars1)
(tv_prs ++ (map tyVarName tvs `zip` tvs1))
(ev_vars ++ ev_vars1)
inner_ty }
| otherwise
= return (wrap, tv_prs, ev_vars, substTy subst ty)
topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
topInstantiate = top_instantiate True
topInstantiateInferred :: CtOrigin -> TcSigmaType
-> TcM (HsWrapper, TcSigmaType)
topInstantiateInferred = top_instantiate False
top_instantiate :: Bool
-> CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
top_instantiate inst_all orig ty
| (binders, phi) <- tcSplitForAllVarBndrs ty
, (theta, rho) <- tcSplitPhiTy phi
, not (null binders && null theta)
= do { let (inst_bndrs, leave_bndrs) = span should_inst binders
(inst_theta, leave_theta)
| null leave_bndrs = (theta, [])
| otherwise = ([], theta)
in_scope = mkInScopeSet (tyCoVarsOfType ty)
empty_subst = mkEmptyTCvSubst in_scope
inst_tvs = binderVars inst_bndrs
; (subst, inst_tvs') <- mapAccumLM newMetaTyVarX empty_subst inst_tvs
; let inst_theta' = substTheta subst inst_theta
sigma' = substTy subst (mkForAllTys leave_bndrs $
mkPhiTy leave_theta rho)
inst_tv_tys' = mkTyVarTys inst_tvs'
; wrap1 <- instCall orig inst_tv_tys' inst_theta'
; traceTc "Instantiating"
(vcat [ text "all tyvars?" <+> ppr inst_all
, text "origin" <+> pprCtOrigin orig
, text "type" <+> debugPprType ty
, text "theta" <+> ppr theta
, text "leave_bndrs" <+> ppr leave_bndrs
, text "with" <+> vcat (map debugPprType inst_tv_tys')
, text "theta:" <+> ppr inst_theta' ])
; (wrap2, rho2) <-
if null leave_bndrs
then top_instantiate inst_all orig sigma'
else return (idHsWrapper, sigma')
; return (wrap2 <.> wrap1, rho2) }
| otherwise = return (idHsWrapper, ty)
where
should_inst bndr
| inst_all = True
| otherwise = binderArgFlag bndr == Inferred
instTyVarsWith :: CtOrigin -> [TyVar] -> [TcType] -> TcM TCvSubst
instTyVarsWith orig tvs tys
= go emptyTCvSubst tvs tys
where
go subst [] []
= return subst
go subst (tv:tvs) (ty:tys)
| tv_kind `tcEqType` ty_kind
= go (extendTvSubstAndInScope subst tv ty) tvs tys
| otherwise
= do { co <- emitWantedEq orig KindLevel Nominal ty_kind tv_kind
; go (extendTvSubstAndInScope subst tv (ty `mkCastTy` co)) tvs tys }
where
tv_kind = substTy subst (tyVarKind tv)
ty_kind = tcTypeKind ty
go _ _ _ = pprPanic "instTysWith" (ppr tvs $$ ppr tys)
instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
instCall orig tys theta
= do { dict_app <- instCallConstraints orig theta
; return (dict_app <.> mkWpTyApps tys) }
instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper
instCallConstraints orig preds
| null preds
= return idHsWrapper
| otherwise
= do { evs <- mapM go preds
; traceTc "instCallConstraints" (ppr evs)
; return (mkWpEvApps evs) }
where
go :: TcPredType -> TcM EvTerm
go pred
| Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred
= do { co <- unifyType Nothing ty1 ty2
; return (evCoercion co) }
| Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred
, tc `hasKey` heqTyConKey
= do { co <- unifyType Nothing ty1 ty2
; return (evDFunApp (dataConWrapId heqDataCon) args [Coercion co]) }
| otherwise
= emitWanted orig pred
instDFunType :: DFunId -> [DFunInstType]
-> TcM ( [TcType]
, TcThetaType )
instDFunType dfun_id dfun_inst_tys
= do { (subst, inst_tys) <- go empty_subst dfun_tvs dfun_inst_tys
; return (inst_tys, substTheta subst dfun_theta) }
where
dfun_ty = idType dfun_id
(dfun_tvs, dfun_theta, _) = tcSplitSigmaTy dfun_ty
empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType dfun_ty))
go :: TCvSubst -> [TyVar] -> [DFunInstType] -> TcM (TCvSubst, [TcType])
go subst [] [] = return (subst, [])
go subst (tv:tvs) (Just ty : mb_tys)
= do { (subst', tys) <- go (extendTvSubstAndInScope subst tv ty)
tvs
mb_tys
; return (subst', ty : tys) }
go subst (tv:tvs) (Nothing : mb_tys)
= do { (subst', tv') <- newMetaTyVarX subst tv
; (subst'', tys) <- go subst' tvs mb_tys
; return (subst'', mkTyVarTy tv' : tys) }
go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr dfun_inst_tys)
instStupidTheta :: CtOrigin -> TcThetaType -> TcM ()
instStupidTheta orig theta
= do { _co <- instCallConstraints orig theta
; return () }
tcInstInvisibleTyBinders :: TcType -> TcKind -> TcM (TcType, TcKind)
tcInstInvisibleTyBinders ty kind
= do { (extra_args, kind') <- tcInstInvisibleTyBindersN n_invis kind
; return (mkAppTys ty extra_args, kind') }
where
n_invis = invisibleTyBndrCount kind
tcInstInvisibleTyBindersN :: Int -> TcKind -> TcM ([TcType], TcKind)
tcInstInvisibleTyBindersN 0 kind
= return ([], kind)
tcInstInvisibleTyBindersN n ty
= go n empty_subst ty
where
empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))
go n subst kind
| n > 0
, Just (bndr, body) <- tcSplitPiTy_maybe kind
, isInvisibleBinder bndr
= do { (subst', arg) <- tcInstInvisibleTyBinder subst bndr
; (args, inner_ty) <- go (n1) subst' body
; return (arg:args, inner_ty) }
| otherwise
= return ([], substTy subst kind)
tcInstInvisibleTyBinder :: TCvSubst -> TyBinder -> TcM (TCvSubst, TcType)
tcInstInvisibleTyBinder subst (Named (Bndr tv _))
= do { (subst', tv') <- newMetaTyVarX subst tv
; return (subst', mkTyVarTy tv') }
tcInstInvisibleTyBinder subst (Anon af ty)
| Just (mk, k1, k2) <- get_eq_tys_maybe (substTy subst (scaledThing ty))
= ASSERT( af == InvisArg )
do { co <- unifyKind Nothing k1 k2
; arg' <- mk co
; return (subst, arg') }
| otherwise
= pprPanic "tcInvisibleTyBinder" (ppr ty)
get_eq_tys_maybe :: Type
-> Maybe ( Coercion -> TcM Type
, Type
, Type
)
get_eq_tys_maybe ty
| Just (tc, [_, _, k1, k2]) <- splitTyConApp_maybe ty
, tc `hasKey` heqTyConKey
= Just (\co -> mkHEqBoxTy co k1 k2, k1, k2)
| Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty
, tc `hasKey` eqTyConKey
= Just (\co -> mkEqBoxTy co k1 k2, k1, k2)
| otherwise
= Nothing
mkHEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type
mkHEqBoxTy co ty1 ty2
= return $
mkTyConApp (promoteDataCon heqDataCon) [k1, k2, ty1, ty2, mkCoercionTy co]
where k1 = tcTypeKind ty1
k2 = tcTypeKind ty2
mkEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type
mkEqBoxTy co ty1 ty2
= return $
mkTyConApp (promoteDataCon eqDataCon) [k, ty1, ty2, mkCoercionTy co]
where k = tcTypeKind ty1
tcInstType :: ([TyVar] -> TcM (TCvSubst, [TcTyVar]))
-> Id
-> TcM ([(Name, TcTyVar)], TcThetaType, TcType)
tcInstType inst_tyvars id
| null tyvars
= return ([], theta, tau)
| otherwise
= do { (subst, tyvars') <- inst_tyvars tyvars
; let tv_prs = map tyVarName tyvars `zip` tyvars'
subst' = extendTCvInScopeSet subst (tyCoVarsOfType rho)
; return (tv_prs, substTheta subst' theta, substTy subst' tau) }
where
(tyvars, rho) = tcSplitForAllTys (idType id)
(theta, tau) = tcSplitPhiTy rho
tcInstTypeBndrs :: Id -> TcM ([(Name, InvisTVBinder)], TcThetaType, TcType)
tcInstTypeBndrs id
| null tyvars
= return ([], theta, tau)
| otherwise
= do { (subst, tyvars') <- mapAccumLM inst_invis_bndr emptyTCvSubst tyvars
; let tv_prs = map (tyVarName . binderVar) tyvars `zip` tyvars'
subst' = extendTCvInScopeSet subst (tyCoVarsOfType rho)
; return (tv_prs, substTheta subst' theta, substTy subst' tau) }
where
(tyvars, rho) = splitForAllTysInvis (idType id)
(theta, tau) = tcSplitPhiTy rho
inst_invis_bndr :: TCvSubst -> InvisTVBinder
-> TcM (TCvSubst, InvisTVBinder)
inst_invis_bndr subst (Bndr tv spec)
= do { (subst', tv') <- newMetaTyVarTyVarX subst tv
; return (subst', Bndr tv' spec) }
tcSkolDFunType :: DFunId -> TcM ([TcTyVar], TcThetaType, TcType)
tcSkolDFunType dfun
= do { (tv_prs, theta, tau) <- tcInstType tcInstSuperSkolTyVars dfun
; return (map snd tv_prs, theta, tau) }
tcSuperSkolTyVars :: [TyVar] -> (TCvSubst, [TcTyVar])
tcSuperSkolTyVars = mapAccumL tcSuperSkolTyVar emptyTCvSubst
tcSuperSkolTyVar :: TCvSubst -> TyVar -> (TCvSubst, TcTyVar)
tcSuperSkolTyVar subst tv
= (extendTvSubstWithClone subst tv new_tv, new_tv)
where
kind = substTyUnchecked subst (tyVarKind tv)
new_tv = mkTcTyVar (tyVarName tv) kind superSkolemTv
tcInstSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
tcInstSkolTyVars = tcInstSkolTyVarsX emptyTCvSubst
tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])
tcInstSkolTyVarsX = tcInstSkolTyVarsPushLevel False
tcInstSuperSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
tcInstSuperSkolTyVars = tcInstSuperSkolTyVarsX emptyTCvSubst
tcInstSuperSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])
tcInstSuperSkolTyVarsX subst = tcInstSkolTyVarsPushLevel True subst
tcInstSkolTyVarsPushLevel :: Bool -> TCvSubst -> [TyVar]
-> TcM (TCvSubst, [TcTyVar])
tcInstSkolTyVarsPushLevel overlappable subst tvs
= do { tc_lvl <- getTcLevel
; let pushed_lvl = pushTcLevel tc_lvl
; tcInstSkolTyVarsAt pushed_lvl overlappable subst tvs }
tcInstSkolTyVarsAt :: TcLevel -> Bool
-> TCvSubst -> [TyVar]
-> TcM (TCvSubst, [TcTyVar])
tcInstSkolTyVarsAt lvl overlappable subst tvs
= freshenTyCoVarsX new_skol_tv subst tvs
where
details = SkolemTv lvl overlappable
new_skol_tv name kind = mkTcTyVar name kind details
freshenTyVarBndrs :: [TyVar] -> TcM (TCvSubst, [TyVar])
freshenTyVarBndrs = freshenTyCoVars mkTyVar
freshenCoVarBndrsX :: TCvSubst -> [CoVar] -> TcM (TCvSubst, [CoVar])
freshenCoVarBndrsX subst = freshenTyCoVarsX mkCoVar subst
freshenTyCoVars :: (Name -> Kind -> TyCoVar)
-> [TyVar] -> TcM (TCvSubst, [TyCoVar])
freshenTyCoVars mk_tcv = freshenTyCoVarsX mk_tcv emptyTCvSubst
freshenTyCoVarsX :: (Name -> Kind -> TyCoVar)
-> TCvSubst -> [TyCoVar]
-> TcM (TCvSubst, [TyCoVar])
freshenTyCoVarsX mk_tcv = mapAccumLM (freshenTyCoVarX mk_tcv)
freshenTyCoVarX :: (Name -> Kind -> TyCoVar)
-> TCvSubst -> TyCoVar -> TcM (TCvSubst, TyCoVar)
freshenTyCoVarX mk_tcv subst tycovar
= do { loc <- getSrcSpanM
; uniq <- newUnique
; let old_name = tyVarName tycovar
new_name = mkInternalName uniq (getOccName old_name) loc
new_kind = substTyUnchecked subst (tyVarKind tycovar)
new_tcv = mk_tcv new_name new_kind
subst1 = extendTCvSubstWithClone subst tycovar new_tcv
; return (subst1, new_tcv) }
newOverloadedLit :: HsOverLit GhcRn
-> ExpRhoType
-> TcM (HsOverLit GhcTc)
newOverloadedLit
lit@(OverLit { ol_val = val, ol_ext = rebindable }) res_ty
| not rebindable
= do { res_ty <- expTypeToType res_ty
; dflags <- getDynFlags
; let platform = targetPlatform dflags
; case shortCutLit platform val res_ty of
Just expr -> return (lit { ol_witness = expr
, ol_ext = OverLitTc False res_ty })
Nothing -> newNonTrivialOverloadedLit orig lit
(mkCheckExpType res_ty) }
| otherwise
= newNonTrivialOverloadedLit orig lit res_ty
where
orig = LiteralOrigin lit
newNonTrivialOverloadedLit :: CtOrigin
-> HsOverLit GhcRn
-> ExpRhoType
-> TcM (HsOverLit GhcTc)
newNonTrivialOverloadedLit orig
lit@(OverLit { ol_val = val, ol_witness = HsVar _ (L _ meth_name)
, ol_ext = rebindable }) res_ty
= do { hs_lit <- mkOverLit val
; let lit_ty = hsLitType hs_lit
; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name)
[synKnownType lit_ty] res_ty $
\_ _ -> return ()
; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit]
; res_ty <- readExpType res_ty
; return (lit { ol_witness = witness
, ol_ext = OverLitTc rebindable res_ty }) }
newNonTrivialOverloadedLit _ lit _
= pprPanic "newNonTrivialOverloadedLit" (ppr lit)
mkOverLit ::OverLitVal -> TcM (HsLit GhcTc)
mkOverLit (HsIntegral i)
= do { integer_ty <- tcMetaTy integerTyConName
; return (HsInteger (il_text i)
(il_value i) integer_ty) }
mkOverLit (HsFractional r)
= do { rat_ty <- tcMetaTy rationalTyConName
; return (HsRat noExtField r rat_ty) }
mkOverLit (HsIsString src s) = return (HsString src s)
tcSyntaxName :: CtOrigin
-> TcType
-> (Name, HsExpr GhcRn)
-> TcM (Name, HsExpr GhcTc)
tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm))
| std_nm == user_nm
= do rhs <- newMethodFromName orig std_nm [ty]
return (std_nm, rhs)
tcSyntaxName orig ty (std_nm, user_nm_expr) = do
std_id <- tcLookupId std_nm
let
([tv], _, tau) = tcSplitSigmaTy (idType std_id)
sigma1 = substTyWith [tv] [ty] tau
addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
span <- getSrcSpanM
expr <- tcCheckPolyExpr (L span user_nm_expr) sigma1
return (std_nm, unLoc expr)
syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> TidyEnv
-> TcRn (TidyEnv, SDoc)
syntaxNameCtxt name orig ty tidy_env
= do { inst_loc <- getCtLocM orig (Just TypeLevel)
; let msg = vcat [ text "When checking that" <+> quotes (ppr name)
<+> text "(needed by a syntactic construct)"
, nest 2 (text "has the required type:"
<+> ppr (tidyType tidy_env ty))
, nest 2 (pprCtLoc inst_loc) ]
; return (tidy_env, msg) }
getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag
getOverlapFlag overlap_mode
= do { dflags <- getDynFlags
; let overlap_ok = xopt LangExt.OverlappingInstances dflags
incoherent_ok = xopt LangExt.IncoherentInstances dflags
use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags
, overlapMode = x }
default_oflag | incoherent_ok = use (Incoherent NoSourceText)
| overlap_ok = use (Overlaps NoSourceText)
| otherwise = use (NoOverlap NoSourceText)
final_oflag = setOverlapModeMaybe default_oflag overlap_mode
; return final_oflag }
tcGetInsts :: TcM [ClsInst]
tcGetInsts = fmap tcg_insts getGblEnv
newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType
-> Class -> [Type] -> TcM ClsInst
newClsInst overlap_mode dfun_name tvs theta clas tys
= do { (subst, tvs') <- freshenTyVarBndrs tvs
; let tys' = substTys subst tys
dfun = mkDictFunId dfun_name tvs theta clas tys
; oflag <- getOverlapFlag overlap_mode
; let inst = mkLocalInstance dfun oflag tvs' clas tys'
; warnIfFlag Opt_WarnOrphans
(isOrphan (is_orphan inst))
(instOrphWarn inst)
; return inst }
instOrphWarn :: ClsInst -> SDoc
instOrphWarn inst
= hang (text "Orphan instance:") 2 (pprInstanceHdr inst)
$$ text "To avoid this"
$$ nest 4 (vcat possibilities)
where
possibilities =
text "move the instance declaration to the module of the class or of the type, or" :
text "wrap the type with a newtype and declare the instance on the new type." :
[]
tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
tcExtendLocalInstEnv dfuns thing_inside
= do { traceDFuns dfuns
; env <- getGblEnv
; (inst_env', cls_insts') <- foldlM addLocalInst
(tcg_inst_env env, tcg_insts env)
dfuns
; let env' = env { tcg_insts = cls_insts'
, tcg_inst_env = inst_env' }
; setGblEnv env' thing_inside }
addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst])
addLocalInst (home_ie, my_insts) ispec
= do {
; isGHCi <- getIsGHCi
; eps <- getEps
; tcg_env <- getGblEnv
; let home_ie'
| isGHCi = deleteFromInstEnv home_ie ispec
| otherwise = home_ie
global_ie = eps_inst_env eps
inst_envs = InstEnvs { ie_global = global_ie
, ie_local = home_ie'
, ie_visible = tcVisibleOrphanMods tcg_env }
; let inconsistent_ispecs = checkFunDeps inst_envs ispec
; unless (null inconsistent_ispecs) $
funDepErr ispec inconsistent_ispecs
; let (_tvs, cls, tys) = instanceHead ispec
(matches, _, _) = lookupInstEnv False inst_envs cls tys
dups = filter (identicalClsInstHead ispec) (map fst matches)
; unless (null dups) $
dupInstErr ispec (head dups)
; return (extendInstEnv home_ie' ispec, ispec : my_insts) }
traceDFuns :: [ClsInst] -> TcRn ()
traceDFuns ispecs
= traceTc "Adding instances:" (vcat (map pp ispecs))
where
pp ispec = hang (ppr (instanceDFunId ispec) <+> colon)
2 (ppr ispec)
funDepErr :: ClsInst -> [ClsInst] -> TcRn ()
funDepErr ispec ispecs
= addClsInstsErr (text "Functional dependencies conflict between instance declarations:")
(ispec : ispecs)
dupInstErr :: ClsInst -> ClsInst -> TcRn ()
dupInstErr ispec dup_ispec
= addClsInstsErr (text "Duplicate instance declarations:")
[ispec, dup_ispec]
addClsInstsErr :: SDoc -> [ClsInst] -> TcRn ()
addClsInstsErr herald ispecs
= setSrcSpan (getSrcSpan (head sorted)) $
addErr (hang herald 2 (pprInstances sorted))
where
sorted = sortBy (SrcLoc.leftmost_smallest `on` getSrcSpan) ispecs