{-# LANGUAGE CPP, ScopedTypeVariables #-}
module TcErrors(
reportUnsolved, reportAllUnsolved, warnAllUnsolved,
warnDefaulting,
solverDepthErrorTcS
) where
#include "HsVersions.h"
import GhcPrelude
import TcRnTypes
import TcRnMonad
import TcMType
import TcUnify( occCheckForErrors, OccCheckResult(..) )
import TcEnv( tcInitTidyEnv )
import TcType
import RnUnbound ( unknownNameSuggestions )
import Type
import TyCoRep
import Kind
import Unify ( tcMatchTys )
import Module
import FamInst
import FamInstEnv ( flattenTys )
import Inst
import InstEnv
import TyCon
import Class
import DataCon
import TcEvidence
import HsExpr ( UnboundVar(..) )
import HsBinds ( PatSynBind(..) )
import Name
import RdrName ( lookupGlobalRdrEnv, lookupGRE_Name, GlobalRdrEnv
, mkRdrUnqual, isLocalGRE, greSrcSpan, pprNameProvenance
, GlobalRdrElt (..), globalRdrEnvElts )
import PrelNames ( typeableClassName, hasKey, liftedRepDataConKey )
import Id
import Var
import VarSet
import VarEnv
import NameSet
import Bag
import ErrUtils ( ErrMsg, errDoc, pprLocErrMsg )
import BasicTypes
import ConLike ( ConLike(..))
import Util
import TcEnv (tcLookup)
import {-# SOURCE #-} TcSimplify ( tcCheckHoleFit )
import FastString
import Outputable
import SrcLoc
import DynFlags
import ListSetOps ( equivClasses )
import Maybes
import Pair
import qualified GHC.LanguageExtensions as LangExt
import FV ( fvVarList, fvVarSet, unionFV )
import Control.Monad ( when )
import Data.Foldable ( toList )
import Data.List ( partition, mapAccumL, nub, sortBy, unfoldr, foldl')
import qualified Data.Set as Set
import Data.Semigroup ( Semigroup )
import qualified Data.Semigroup as Semigroup
reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)
reportUnsolved wanted
= do { binds_var <- newTcEvBinds
; defer_errors <- goptM Opt_DeferTypeErrors
; warn_errors <- woptM Opt_WarnDeferredTypeErrors
; let type_errors | not defer_errors = TypeError
| warn_errors = TypeWarn
| otherwise = TypeDefer
; defer_holes <- goptM Opt_DeferTypedHoles
; warn_holes <- woptM Opt_WarnTypedHoles
; let expr_holes | not defer_holes = HoleError
| warn_holes = HoleWarn
| otherwise = HoleDefer
; partial_sigs <- xoptM LangExt.PartialTypeSignatures
; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures
; let type_holes | not partial_sigs = HoleError
| warn_partial_sigs = HoleWarn
| otherwise = HoleDefer
; defer_out_of_scope <- goptM Opt_DeferOutOfScopeVariables
; warn_out_of_scope <- woptM Opt_WarnDeferredOutOfScopeVariables
; let out_of_scope_holes | not defer_out_of_scope = HoleError
| warn_out_of_scope = HoleWarn
| otherwise = HoleDefer
; report_unsolved binds_var False type_errors expr_holes
type_holes out_of_scope_holes wanted
; ev_binds <- getTcEvBindsMap binds_var
; return (evBindMapBinds ev_binds)}
reportAllUnsolved :: WantedConstraints -> TcM ()
reportAllUnsolved wanted
= do { ev_binds <- newTcEvBinds
; report_unsolved ev_binds False TypeError
HoleError HoleError HoleError wanted }
warnAllUnsolved :: WantedConstraints -> TcM ()
warnAllUnsolved wanted
= do { ev_binds <- newTcEvBinds
; report_unsolved ev_binds True TypeWarn
HoleWarn HoleWarn HoleWarn wanted }
report_unsolved :: EvBindsVar
-> Bool
-> TypeErrorChoice
-> HoleChoice
-> HoleChoice
-> HoleChoice
-> WantedConstraints -> TcM ()
report_unsolved mb_binds_var err_as_warn type_errors expr_holes
type_holes out_of_scope_holes wanted
| isEmptyWC wanted
= return ()
| otherwise
= do { traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted)
; wanted <- zonkWC wanted
; env0 <- tcInitTidyEnv
; let tidy_env = tidyFreeTyCoVars env0 free_tvs
free_tvs = tyCoVarsOfWCList wanted
; traceTc "reportUnsolved (after zonking):" $
vcat [ text "Free tyvars:" <+> pprTyVars free_tvs
, text "Tidy env:" <+> ppr tidy_env
, text "Wanted:" <+> ppr wanted ]
; warn_redundant <- woptM Opt_WarnRedundantConstraints
; let err_ctxt = CEC { cec_encl = []
, cec_tidy = tidy_env
, cec_defer_type_errors = type_errors
, cec_errors_as_warns = err_as_warn
, cec_expr_holes = expr_holes
, cec_type_holes = type_holes
, cec_out_of_scope_holes = out_of_scope_holes
, cec_suppress = False
, cec_warn_redundant = warn_redundant
, cec_binds = mb_binds_var }
; tc_lvl <- getTcLevel
; reportWanteds err_ctxt tc_lvl wanted }
data Report
= Report { report_important :: [SDoc]
, report_relevant_bindings :: [SDoc]
, report_valid_substitutions :: [SDoc]
}
instance Outputable Report where
ppr (Report { report_important = imp
, report_relevant_bindings = rel
, report_valid_substitutions = val })
= vcat [ text "important:" <+> vcat imp
, text "relevant:" <+> vcat rel
, text "valid:" <+> vcat val ]
instance Semigroup Report where
Report a1 b1 c1 <> Report a2 b2 c2 = Report (a1 ++ a2) (b1 ++ b2) (c1 ++ c2)
instance Monoid Report where
mempty = Report [] [] []
mappend = (Semigroup.<>)
important :: SDoc -> Report
important doc = mempty { report_important = [doc] }
relevant_bindings :: SDoc -> Report
relevant_bindings doc = mempty { report_relevant_bindings = [doc] }
valid_substitutions :: SDoc -> Report
valid_substitutions docs = mempty { report_valid_substitutions = [docs] }
data TypeErrorChoice
= TypeError
| TypeWarn
| TypeDefer
data HoleChoice
= HoleError
| HoleWarn
| HoleDefer
instance Outputable HoleChoice where
ppr HoleError = text "HoleError"
ppr HoleWarn = text "HoleWarn"
ppr HoleDefer = text "HoleDefer"
instance Outputable TypeErrorChoice where
ppr TypeError = text "TypeError"
ppr TypeWarn = text "TypeWarn"
ppr TypeDefer = text "TypeDefer"
data ReportErrCtxt
= CEC { cec_encl :: [Implication]
, cec_tidy :: TidyEnv
, cec_binds :: EvBindsVar
, cec_errors_as_warns :: Bool
, cec_defer_type_errors :: TypeErrorChoice
, cec_expr_holes :: HoleChoice
, cec_type_holes :: HoleChoice
, cec_out_of_scope_holes :: HoleChoice
, cec_warn_redundant :: Bool
, cec_suppress :: Bool
}
instance Outputable ReportErrCtxt where
ppr (CEC { cec_binds = bvar
, cec_errors_as_warns = ew
, cec_defer_type_errors = dte
, cec_expr_holes = eh
, cec_type_holes = th
, cec_out_of_scope_holes = osh
, cec_warn_redundant = wr
, cec_suppress = sup })
= text "CEC" <+> braces (vcat
[ text "cec_binds" <+> equals <+> ppr bvar
, text "cec_errors_as_warns" <+> equals <+> ppr ew
, text "cec_defer_type_errors" <+> equals <+> ppr dte
, text "cec_expr_holes" <+> equals <+> ppr eh
, text "cec_type_holes" <+> equals <+> ppr th
, text "cec_out_of_scope_holes" <+> equals <+> ppr osh
, text "cec_warn_redundant" <+> equals <+> ppr wr
, text "cec_suppress" <+> equals <+> ppr sup ])
reportImplic :: ReportErrCtxt -> Implication -> TcM ()
reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given
, ic_wanted = wanted, ic_binds = evb
, ic_status = status, ic_info = info
, ic_env = tcl_env, ic_tclvl = tc_lvl })
| BracketSkol <- info
, not insoluble
= return ()
| otherwise
= do { traceTc "reportImplic" (ppr implic')
; reportWanteds ctxt' tc_lvl wanted
; when (cec_warn_redundant ctxt) $
warnRedundantConstraints ctxt' tcl_env info' dead_givens }
where
insoluble = isInsolubleStatus status
(env1, tvs') = mapAccumL tidyTyCoVarBndr (cec_tidy ctxt) tvs
info' = tidySkolemInfo env1 info
implic' = implic { ic_skols = tvs'
, ic_given = map (tidyEvVar env1) given
, ic_info = info' }
ctxt' = ctxt { cec_tidy = env1
, cec_encl = implic' : cec_encl ctxt
, cec_suppress = insoluble || cec_suppress ctxt
, cec_binds = evb }
dead_givens = case status of
IC_Solved { ics_dead = dead } -> dead
_ -> []
warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [EvVar] -> TcM ()
warnRedundantConstraints ctxt env info ev_vars
| null redundant_evs
= return ()
| SigSkol {} <- info
= setLclEnv env $
addErrCtxt (text "In" <+> ppr info) $
do { env <- getLclEnv
; msg <- mkErrorReport ctxt env (important doc)
; reportWarning (Reason Opt_WarnRedundantConstraints) msg }
| otherwise
= do { msg <- mkErrorReport ctxt env (important doc)
; reportWarning (Reason Opt_WarnRedundantConstraints) msg }
where
doc = text "Redundant constraint" <> plural redundant_evs <> colon
<+> pprEvVarTheta redundant_evs
redundant_evs = case info of
InstSkol -> filterOut improving ev_vars
_ -> ev_vars
improving ev_var = any isImprovementPred $
transSuperClasses (idType ev_var)
reportWanteds :: ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM ()
reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics })
= do { traceTc "reportWanteds" (vcat [ text "Simples =" <+> ppr simples
, text "Suppress =" <+> ppr (cec_suppress ctxt)])
; traceTc "rw2" (ppr tidy_cts)
; let ctxt_for_insols = ctxt { cec_suppress = False }
; (ctxt1, cts1) <- tryReporters ctxt_for_insols report1 tidy_cts
; let ctxt2 = ctxt { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 }
; (_, leftovers) <- tryReporters ctxt2 report2 cts1
; MASSERT2( null leftovers, ppr leftovers )
; mapBagM_ (reportImplic ctxt2) implics }
where
env = cec_tidy ctxt
tidy_cts = bagToList (mapBag (tidyCt env) simples)
report1 = [ ("custom_error", is_user_type_error,True, mkUserTypeErrorReporter)
, given_eq_spec
, ("insoluble2", utterly_wrong, True, mkGroupReporter mkEqErr)
, ("skolem eq1", very_wrong, True, mkSkolReporter)
, ("skolem eq2", skolem_eq, True, mkSkolReporter)
, ("non-tv eq", non_tv_eq, True, mkSkolReporter)
, ("Out of scope", is_out_of_scope,True, mkHoleReporter tidy_cts)
, ("Holes", is_hole, False, mkHoleReporter tidy_cts)
, ("Homo eqs", is_homo_equality, True, mkGroupReporter mkEqErr)
, ("Other eqs", is_equality, False, mkGroupReporter mkEqErr) ]
report2 = [ ("Implicit params", is_ip, False, mkGroupReporter mkIPErr)
, ("Irreds", is_irred, False, mkGroupReporter mkIrredErr)
, ("Dicts", is_dict, False, mkGroupReporter mkDictErr) ]
is_hole, is_dict,
is_equality, is_ip, is_irred :: Ct -> PredTree -> Bool
is_given_eq ct pred
| EqPred {} <- pred = arisesFromGivens ct
| otherwise = False
utterly_wrong _ (EqPred NomEq ty1 ty2) = isRigidTy ty1 && isRigidTy ty2
utterly_wrong _ _ = False
very_wrong _ (EqPred NomEq ty1 ty2) = isSkolemTy tc_lvl ty1 && isRigidTy ty2
very_wrong _ _ = False
skolem_eq _ (EqPred NomEq ty1 _) = isSkolemTy tc_lvl ty1
skolem_eq _ _ = False
non_tv_eq _ (EqPred NomEq ty1 _) = not (isTyVarTy ty1)
non_tv_eq _ _ = False
is_out_of_scope ct _ = isOutOfScopeCt ct
is_hole ct _ = isHoleCt ct
is_user_type_error ct _ = isUserTypeErrorCt ct
is_homo_equality _ (EqPred _ ty1 ty2) = typeKind ty1 `tcEqType` typeKind ty2
is_homo_equality _ _ = False
is_equality _ (EqPred {}) = True
is_equality _ _ = False
is_dict _ (ClassPred {}) = True
is_dict _ _ = False
is_ip _ (ClassPred cls _) = isIPClass cls
is_ip _ _ = False
is_irred _ (IrredPred {}) = True
is_irred _ _ = False
given_eq_spec = case find_gadt_match (cec_encl ctxt) of
Just imp -> ("insoluble1a", is_given_eq, True, mkGivenErrorReporter imp)
Nothing -> ("insoluble1b", is_given_eq, False, ignoreErrorReporter)
find_gadt_match [] = Nothing
find_gadt_match (implic : implics)
| PatSkol {} <- ic_info implic
, not (ic_no_eqs implic)
= Just implic
| otherwise
= find_gadt_match implics
isSkolemTy :: TcLevel -> Type -> Bool
isSkolemTy tc_lvl ty
| Just tv <- getTyVar_maybe ty
= isSkolemTyVar tv
|| (isSigTyVar tv && isTouchableMetaTyVar tc_lvl tv)
| otherwise
= False
isTyFun_maybe :: Type -> Maybe TyCon
isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of
Just (tc,_) | isTypeFamilyTyCon tc -> Just tc
_ -> Nothing
type Reporter
= ReportErrCtxt -> [Ct] -> TcM ()
type ReporterSpec
= ( String
, Ct -> PredTree -> Bool
, Bool
, Reporter)
mkSkolReporter :: Reporter
mkSkolReporter ctxt cts
= mapM_ (reportGroup mkEqErr ctxt) (group cts)
where
group [] = []
group (ct:cts) = (ct : yeses) : group noes
where
(yeses, noes) = partition (group_with ct) cts
group_with ct1 ct2
| EQ <- cmp_loc ct1 ct2 = True
| eq_lhs_type ct1 ct2 = True
| otherwise = False
mkHoleReporter :: [Ct] -> Reporter
mkHoleReporter tidy_simples ctxt
= mapM_ $ \ct -> do { err <- mkHoleError tidy_simples ctxt ct
; maybeReportHoleError ctxt ct err
; maybeAddDeferredHoleBinding ctxt err ct }
mkUserTypeErrorReporter :: Reporter
mkUserTypeErrorReporter ctxt
= mapM_ $ \ct -> do { err <- mkUserTypeError ctxt ct
; maybeReportError ctxt err
; addDeferredBinding ctxt err ct }
mkUserTypeError :: ReportErrCtxt -> Ct -> TcM ErrMsg
mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct
$ important
$ pprUserTypeErrorTy
$ case getUserTypeErrorMsg ct of
Just msg -> msg
Nothing -> pprPanic "mkUserTypeError" (ppr ct)
mkGivenErrorReporter :: Implication -> Reporter
mkGivenErrorReporter implic ctxt cts
= do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
; dflags <- getDynFlags
; let ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (ic_env implic))
inaccessible_msg = hang (text "Inaccessible code in")
2 (ppr (ic_info implic))
report = important inaccessible_msg `mappend`
relevant_bindings binds_msg
; err <- mkEqErr_help dflags ctxt report ct'
Nothing ty1 ty2
; traceTc "mkGivenErrorReporter" (ppr ct)
; maybeReportError ctxt err }
where
(ct : _ ) = cts
(ty1, ty2) = getEqPredTys (ctPred ct)
ignoreErrorReporter :: Reporter
ignoreErrorReporter ctxt cts
= do { traceTc "mkGivenErrorReporter no" (ppr cts $$ ppr (cec_encl ctxt))
; return () }
mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg)
-> Reporter
mkGroupReporter mk_err ctxt cts
= mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts)
eq_lhs_type :: Ct -> Ct -> Bool
eq_lhs_type ct1 ct2
= case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of
(EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) ->
(eq_rel1 == eq_rel2) && (ty1 `eqType` ty2)
_ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2)
cmp_loc :: Ct -> Ct -> Ordering
cmp_loc ct1 ct2 = ctLocSpan (ctLoc ct1) `compare` ctLocSpan (ctLoc ct2)
reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> ReportErrCtxt
-> [Ct] -> TcM ()
reportGroup mk_err ctxt cts =
case partition isMonadFailInstanceMissing cts of
(monadFailCts, []) ->
do { err <- mk_err ctxt monadFailCts
; reportWarning (Reason Opt_WarnMissingMonadFailInstances) err }
(_, cts') -> do { err <- mk_err ctxt cts'
; maybeReportError ctxt err
; traceTc "reportGroup" (ppr cts')
; mapM_ (addDeferredBinding ctxt err) cts' }
where
isMonadFailInstanceMissing ct =
case ctLocOrigin (ctLoc ct) of
FailablePattern _pat -> True
_otherwise -> False
maybeReportHoleError :: ReportErrCtxt -> Ct -> ErrMsg -> TcM ()
maybeReportHoleError ctxt ct err
| isTypeHoleCt ct
=
case cec_type_holes ctxt of
HoleError -> reportError err
HoleWarn -> reportWarning (Reason Opt_WarnPartialTypeSignatures) err
HoleDefer -> return ()
| isOutOfScopeCt ct
=
case cec_out_of_scope_holes ctxt of
HoleError -> reportError err
HoleWarn ->
reportWarning (Reason Opt_WarnDeferredOutOfScopeVariables) err
HoleDefer -> return ()
| otherwise
=
case cec_expr_holes ctxt of
HoleError -> reportError err
HoleWarn -> reportWarning (Reason Opt_WarnTypedHoles) err
HoleDefer -> return ()
maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM ()
maybeReportError ctxt err
| cec_suppress ctxt
= return ()
| cec_errors_as_warns ctxt
= reportWarning NoReason err
| otherwise
= case cec_defer_type_errors ctxt of
TypeDefer -> return ()
TypeWarn -> reportWarning (Reason Opt_WarnDeferredTypeErrors) err
TypeError -> reportError err
addDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
addDeferredBinding ctxt err ct
| CtWanted { ctev_pred = pred, ctev_dest = dest } <- ctEvidence ct
= do { dflags <- getDynFlags
; let err_msg = pprLocErrMsg err
err_fs = mkFastString $ showSDoc dflags $
err_msg $$ text "(deferred type error)"
err_tm = EvDelayedError pred err_fs
ev_binds_var = cec_binds ctxt
; case dest of
EvVarDest evar
-> addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm
HoleDest hole
-> do {
let co_var = coHoleCoVar hole
; addTcEvBind ev_binds_var $ mkWantedEvBind co_var err_tm
; fillCoercionHole hole (mkTcCoVarCo co_var) }}
| otherwise
= return ()
maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
maybeAddDeferredHoleBinding ctxt err ct
| isExprHoleCt ct
= addDeferredBinding ctxt err ct
| otherwise
= return ()
tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct])
tryReporters ctxt reporters cts
= do { let (vis_cts, invis_cts) = partition (isVisibleOrigin . ctOrigin) cts
; traceTc "tryReporters {" (ppr vis_cts $$ ppr invis_cts)
; (ctxt', cts') <- go ctxt reporters vis_cts invis_cts
; traceTc "tryReporters }" (ppr cts')
; return (ctxt', cts') }
where
go ctxt [] vis_cts invis_cts
= return (ctxt, vis_cts ++ invis_cts)
go ctxt (r : rs) vis_cts invis_cts
= do { (ctxt', vis_cts') <- tryReporter ctxt r vis_cts
; (ctxt'', invis_cts') <- tryReporter ctxt' r invis_cts
; go ctxt'' rs vis_cts' invis_cts' }
tryReporter :: ReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (ReportErrCtxt, [Ct])
tryReporter ctxt (str, keep_me, suppress_after, reporter) cts
| null yeses = return (ctxt, cts)
| otherwise = do { traceTc "tryReporter{ " (text str <+> ppr yeses)
; reporter ctxt yeses
; let ctxt' = ctxt { cec_suppress = suppress_after || cec_suppress ctxt }
; traceTc "tryReporter end }" (text str <+> ppr (cec_suppress ctxt) <+> ppr suppress_after)
; return (ctxt', nos) }
where
(yeses, nos) = partition (\ct -> keep_me ct (classifyPredType (ctPred ct))) cts
pprArising :: CtOrigin -> SDoc
pprArising (TypeEqOrigin {}) = empty
pprArising (KindEqOrigin {}) = empty
pprArising (GivenOrigin {}) = empty
pprArising orig = pprCtOrigin orig
addArising :: CtOrigin -> SDoc -> SDoc
addArising orig msg = hang msg 2 (pprArising orig)
pprWithArising :: [Ct] -> (CtLoc, SDoc)
pprWithArising []
= panic "pprWithArising"
pprWithArising (ct:cts)
| null cts
= (loc, addArising (ctLocOrigin loc)
(pprTheta [ctPred ct]))
| otherwise
= (loc, vcat (map ppr_one (ct:cts)))
where
loc = ctLoc ct
ppr_one ct' = hang (parens (pprType (ctPred ct')))
2 (pprCtLoc (ctLoc ct'))
mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ctxt ct report
= mkErrorReport ctxt (ctLocEnv (ctLoc ct)) report
mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM ErrMsg
mkErrorReport ctxt tcl_env (Report important relevant_bindings valid_subs)
= do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)
; mkErrDocAt (RealSrcSpan (tcl_loc tcl_env))
(errDoc important [context] (relevant_bindings ++ valid_subs))
}
type UserGiven = Implication
getUserGivens :: ReportErrCtxt -> [UserGiven]
getUserGivens (CEC {cec_encl = implics}) = getUserGivensFromImplics implics
getUserGivensFromImplics :: [Implication] -> [UserGiven]
getUserGivensFromImplics implics
= reverse (filterOut (null . ic_given) implics)
mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkIrredErr ctxt cts
= do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1
; let orig = ctOrigin ct1
msg = couldNotDeduce (getUserGivens ctxt) (map ctPred cts, orig)
; mkErrorMsgFromCt ctxt ct1 $
important msg `mappend` relevant_bindings binds_msg }
where
(ct1:_) = cts
mkHoleError :: [Ct] -> ReportErrCtxt -> Ct -> TcM ErrMsg
mkHoleError _ _ ct@(CHoleCan { cc_hole = ExprHole (OutOfScope occ rdr_env0) })
= do { dflags <- getDynFlags
; imp_info <- getImports
; let suggs_msg = unknownNameSuggestions dflags rdr_env0
(tcl_rdr lcl_env) imp_info rdr
; rdr_env <- getGlobalRdrEnv
; splice_locs <- getTopLevelSpliceLocs
; let match_msgs = mk_match_msgs rdr_env splice_locs
; mkErrDocAt (RealSrcSpan err_loc) $
errDoc [out_of_scope_msg] [] (match_msgs ++ [suggs_msg]) }
where
rdr = mkRdrUnqual occ
ct_loc = ctLoc ct
lcl_env = ctLocEnv ct_loc
err_loc = tcl_loc lcl_env
hole_ty = ctEvPred (ctEvidence ct)
boring_type = isTyVarTy hole_ty
out_of_scope_msg
| boring_type = hang herald 2 (ppr occ)
| otherwise = hang herald 2 (pp_with_type occ hole_ty)
herald | isDataOcc occ = text "Data constructor not in scope:"
| otherwise = text "Variable not in scope:"
mk_match_msgs rdr_env splice_locs
= let gres = filter isLocalGRE (lookupGlobalRdrEnv rdr_env occ)
in case gres of
[gre]
| RealSrcSpan bind_loc <- greSrcSpan gre
, Just th_loc <- Set.lookupLE bind_loc splice_locs
, err_loc < th_loc
-> [mk_bind_scope_msg bind_loc th_loc]
_ -> []
mk_bind_scope_msg bind_loc th_loc
| is_th_bind
= hang (quotes (ppr occ) <+> parens (text "splice on" <+> th_rng))
2 (text "is not in scope before line" <+> int th_start_ln)
| otherwise
= hang (quotes (ppr occ) <+> bind_rng <+> text "is not in scope")
2 (text "before the splice on" <+> th_rng)
where
bind_rng = parens (text "line" <+> int bind_ln)
th_rng
| th_start_ln == th_end_ln = single
| otherwise = multi
single = text "line" <+> int th_start_ln
multi = text "lines" <+> int th_start_ln <> text "-" <> int th_end_ln
bind_ln = srcSpanStartLine bind_loc
th_start_ln = srcSpanStartLine th_loc
th_end_ln = srcSpanEndLine th_loc
is_th_bind = th_loc `containsSpan` bind_loc
mkHoleError tidy_simples ctxt ct@(CHoleCan { cc_hole = hole })
= do { (ctxt, binds_msg, ct) <- relevantBindings False ctxt ct
; show_hole_constraints <- goptM Opt_ShowHoleConstraints
; let constraints_msg
| isExprHoleCt ct, show_hole_constraints
= givenConstraintsMsg ctxt
| otherwise = empty
; sub_msg <- validSubstitutions tidy_simples ctxt ct
; mkErrorMsgFromCt ctxt ct $
important hole_msg `mappend`
relevant_bindings (binds_msg $$ constraints_msg) `mappend`
valid_substitutions sub_msg}
where
occ = holeOcc hole
hole_ty = ctEvPred (ctEvidence ct)
hole_kind = typeKind hole_ty
tyvars = tyCoVarsOfTypeList hole_ty
hole_msg = case hole of
ExprHole {} -> vcat [ hang (text "Found hole:")
2 (pp_with_type occ hole_ty)
, tyvars_msg, expr_hole_hint ]
TypeHole {} -> vcat [ hang (text "Found type wildcard" <+>
quotes (ppr occ))
2 (text "standing for" <+>
quotes pp_hole_type_with_kind)
, tyvars_msg, type_hole_hint ]
pp_hole_type_with_kind
| isLiftedTypeKind hole_kind = pprType hole_ty
| otherwise = pprType hole_ty <+> dcolon <+> pprKind hole_kind
tyvars_msg = ppUnless (null tyvars) $
text "Where:" <+> (vcat (map loc_msg other_tvs)
$$ pprSkols ctxt skol_tvs)
where
(skol_tvs, other_tvs) = partition is_skol tyvars
is_skol tv = isTcTyVar tv && isSkolemTyVar tv
type_hole_hint
| HoleError <- cec_type_holes ctxt
= text "To use the inferred type, enable PartialTypeSignatures"
| otherwise
= empty
expr_hole_hint
| lengthFS (occNameFS occ) > 1
= text "Or perhaps" <+> quotes (ppr occ)
<+> text "is mis-spelled, or not in scope"
| otherwise
= empty
loc_msg tv
| isTyVar tv
= case tcTyVarDetails tv of
MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable"
_ -> empty
| otherwise
= sdocWithDynFlags $ \dflags ->
if gopt Opt_PrintExplicitCoercions dflags
then quotes (ppr tv) <+> text "is a coercion variable"
else empty
mkHoleError _ _ ct = pprPanic "mkHoleError" (ppr ct)
validSubstitutions :: [Ct] -> ReportErrCtxt -> Ct -> TcM SDoc
validSubstitutions simples (CEC {cec_encl = implics}) ct | isExprHoleCt ct =
do { rdr_env <- getGlobalRdrEnv
; dflags <- getDynFlags
; traceTc "findingValidSubstitutionsFor {" $ ppr wrapped_hole_ty
; (discards, substitutions) <-
setTcLevel hole_lvl $
go (maxValidSubstitutions dflags) $
localsFirst $ globalRdrEnvElts rdr_env
; traceTc "}" empty
; return $ ppUnless (null substitutions) $
hang (text "Valid substitutions include")
2 (vcat (map ppr_sub substitutions)
$$ ppWhen discards subsDiscardMsg) }
where
hole_ty :: TcPredType
hole_ty = ctPred ct
hole_loc = ctEvLoc $ ctEvidence ct
hole_lvl = ctLocLevel $ hole_loc
hole_fvs = tyCoFVsOfType hole_ty
wrapped_hole_ty :: TcSigmaType
wrapped_hole_ty = foldl' wrapTypeWithImplication hole_ty implics
localsFirst :: [GlobalRdrElt] -> [GlobalRdrElt]
localsFirst elts = lcl ++ gbl
where (lcl, gbl) = partition gre_lcl elts
ppr_sub :: (GlobalRdrElt, Id) -> SDoc
ppr_sub (elt, id) = sep [ idAndTy , nest 2 (parens $ pprNameProvenance elt)]
where name = gre_name elt
ty = varType id
idAndTy = (pprPrefixOcc name <+> dcolon <+> pprType ty)
relevantCts :: [Ct]
relevantCts = if isEmptyVarSet hole_fv then []
else filter isRelevant simples
where hole_fv :: VarSet
hole_fv = fvVarSet hole_fvs
ctFreeVarSet :: Ct -> VarSet
ctFreeVarSet = fvVarSet . tyCoFVsOfType . ctPred
allFVMentioned :: Ct -> Bool
allFVMentioned ct = ctFreeVarSet ct `subVarSet` hole_fv
isRelevant ct = not (isEmptyVarSet (ctFreeVarSet ct))
&& allFVMentioned ct
&& not (isHoleCt ct)
getHoleCloningSubst :: TcM TCvSubst
getHoleCloningSubst = mkTvSubstPrs <$> getClonedVars
where cloneFV :: TyVar -> TcM (TyVar, Type)
cloneFV fv = ((,) fv) <$> newFlexiTyVarTy (varType fv)
getClonedVars :: TcM [(TyVar, Type)]
getClonedVars = mapM cloneFV (fvVarList hole_fvs)
applySubToCt :: TCvSubst -> Ct -> Ct
applySubToCt sub ct = ct {cc_ev = ev {ctev_pred = subbedPredType} }
where subbedPredType = substTy sub $ ctPred ct
ev = ctEvidence ct
fitsHole :: Type -> TcM Bool
fitsHole typ =
do { traceTc "checkingFitOf {" $ ppr typ
; cloneSub <- getHoleCloningSubst
; let cHoleTy = substTy cloneSub wrapped_hole_ty
cCts = map (applySubToCt cloneSub) relevantCts
; fits <- tcCheckHoleFit (listToBag cCts) cHoleTy typ
; traceTc "}" empty
; return fits}
go :: Maybe Int -> [GlobalRdrElt] -> TcM (Bool, [(GlobalRdrElt, Id)])
go = go_ []
go_ :: [(GlobalRdrElt,Id)]
-> Maybe Int
-> [GlobalRdrElt]
-> TcM (Bool, [(GlobalRdrElt, Id)])
go_ subs _ [] = return (False, reverse subs)
go_ subs (Just 0) _ = return (True, reverse subs)
go_ subs maxleft (el:elts) =
do { traceTc "lookingUp" $ ppr el
; maybeThing <- lookup (gre_name el)
; case maybeThing of
Just id -> do { fits <- fitsHole (varType id)
; if fits then (keep_it id) else discard_it }
_ -> discard_it
}
where discard_it = go_ subs maxleft elts
keep_it id = go_ ((el,id):subs) ((\n -> n - 1) <$> maxleft) elts
lookup name =
do { thing <- tcLookup name
; case thing of
ATcId {tct_id = id} -> return $ Just id
AGlobal (AnId id) -> return $ Just id
AGlobal (AConLike (RealDataCon con)) ->
return $ Just (dataConWrapId con)
_ -> return Nothing }
validSubstitutions _ _ _ = return empty
givenConstraintsMsg :: ReportErrCtxt -> SDoc
givenConstraintsMsg ctxt =
let constraints :: [(Type, RealSrcSpan)]
constraints =
do { Implic{ ic_given = given, ic_env = env } <- cec_encl ctxt
; constraint <- given
; return (varType constraint, tcl_loc env) }
pprConstraint (constraint, loc) =
ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc))
in ppUnless (null constraints) $
hang (text "Constraints include")
2 (vcat $ map pprConstraint constraints)
pp_with_type :: OccName -> Type -> SDoc
pp_with_type occ ty = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType ty)
mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkIPErr ctxt cts
= do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1
; let orig = ctOrigin ct1
preds = map ctPred cts
givens = getUserGivens ctxt
msg | null givens
= addArising orig $
sep [ text "Unbound implicit parameter" <> plural cts
, nest 2 (pprParendTheta preds) ]
| otherwise
= couldNotDeduce givens (preds, orig)
; mkErrorMsgFromCt ctxt ct1 $
important msg `mappend` relevant_bindings binds_msg }
where
(ct1:_) = cts
mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct
mkEqErr _ [] = panic "mkEqErr"
mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg
mkEqErr1 ctxt ct
= do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
; rdr_env <- getGlobalRdrEnv
; fam_envs <- tcGetFamInstEnvs
; exp_syns <- goptM Opt_PrintExpandedSynonyms
; let (keep_going, is_oriented, wanted_msg)
= mk_wanted_extra (ctLoc ct) exp_syns
coercible_msg = case ctEqRel ct of
NomEq -> empty
ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2
; dflags <- getDynFlags
; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct) $$ ppr keep_going)
; let report = mconcat [important wanted_msg, important coercible_msg,
relevant_bindings binds_msg]
; if keep_going
then mkEqErr_help dflags ctxt report ct is_oriented ty1 ty2
else mkErrorMsgFromCt ctxt ct report }
where
(ty1, ty2) = getEqPredTys (ctPred ct)
mk_wanted_extra :: CtLoc -> Bool -> (Bool, Maybe SwapFlag, SDoc)
mk_wanted_extra loc expandSyns
= case ctLocOrigin loc of
orig@TypeEqOrigin {} -> mkExpectedActualMsg ty1 ty2 orig
t_or_k expandSyns
where
t_or_k = ctLocTypeOrKind_maybe loc
KindEqOrigin cty1 mb_cty2 sub_o sub_t_or_k
-> (True, Nothing, msg1 $$ msg2)
where
sub_what = case sub_t_or_k of Just KindLevel -> text "kinds"
_ -> text "types"
msg1 = sdocWithDynFlags $ \dflags ->
case mb_cty2 of
Just cty2
| gopt Opt_PrintExplicitCoercions dflags
|| not (cty1 `pickyEqType` cty2)
-> hang (text "When matching" <+> sub_what)
2 (vcat [ ppr cty1 <+> dcolon <+>
ppr (typeKind cty1)
, ppr cty2 <+> dcolon <+>
ppr (typeKind cty2) ])
_ -> text "When matching the kind of" <+> quotes (ppr cty1)
msg2 = case sub_o of
TypeEqOrigin {}
| Just cty2 <- mb_cty2 ->
thdOf3 (mkExpectedActualMsg cty1 cty2 sub_o sub_t_or_k
expandSyns)
_ -> empty
_ -> (True, Nothing, empty)
mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs
-> TcType -> TcType -> SDoc
mkCoercibleExplanation rdr_env fam_envs ty1 ty2
| Just (tc, tys) <- tcSplitTyConApp_maybe ty1
, (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys
, Just msg <- coercible_msg_for_tycon rep_tc
= msg
| Just (tc, tys) <- splitTyConApp_maybe ty2
, (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys
, Just msg <- coercible_msg_for_tycon rep_tc
= msg
| Just (s1, _) <- tcSplitAppTy_maybe ty1
, Just (s2, _) <- tcSplitAppTy_maybe ty2
, s1 `eqType` s2
, has_unknown_roles s1
= hang (text "NB: We cannot know what roles the parameters to" <+>
quotes (ppr s1) <+> text "have;")
2 (text "we must assume that the role is nominal")
| otherwise
= empty
where
coercible_msg_for_tycon tc
| isAbstractTyCon tc
= Just $ hsep [ text "NB: The type constructor"
, quotes (pprSourceTyCon tc)
, text "is abstract" ]
| isNewTyCon tc
, [data_con] <- tyConDataCons tc
, let dc_name = dataConName data_con
, isNothing (lookupGRE_Name rdr_env dc_name)
= Just $ hang (text "The data constructor" <+> quotes (ppr dc_name))
2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc)
, text "is not in scope" ])
| otherwise = Nothing
has_unknown_roles ty
| Just (tc, tys) <- tcSplitTyConApp_maybe ty
= tys `lengthAtLeast` tyConArity tc
| Just (s, _) <- tcSplitAppTy_maybe ty
= has_unknown_roles s
| isTyVarTy ty
= True
| otherwise
= False
mkEqErr_help :: DynFlags -> ReportErrCtxt -> Report
-> Ct
-> Maybe SwapFlag
-> TcType -> TcType -> TcM ErrMsg
mkEqErr_help dflags ctxt report ct oriented ty1 ty2
| Just (tv1, co1) <- tcGetCastedTyVar_maybe ty1
= mkTyVarEqErr dflags ctxt report ct oriented tv1 co1 ty2
| Just (tv2, co2) <- tcGetCastedTyVar_maybe ty2
= mkTyVarEqErr dflags ctxt report ct swapped tv2 co2 ty1
| otherwise
= reportEqErr ctxt report ct oriented ty1 ty2
where
swapped = fmap flipSwap oriented
reportEqErr :: ReportErrCtxt -> Report
-> Ct
-> Maybe SwapFlag
-> TcType -> TcType -> TcM ErrMsg
reportEqErr ctxt report ct oriented ty1 ty2
= mkErrorMsgFromCt ctxt ct (mconcat [misMatch, report, eqInfo])
where misMatch = important $ misMatchOrCND ctxt ct oriented ty1 ty2
eqInfo = important $ mkEqInfoMsg ct ty1 ty2
mkTyVarEqErr, mkTyVarEqErr'
:: DynFlags -> ReportErrCtxt -> Report -> Ct
-> Maybe SwapFlag -> TcTyVar -> TcCoercionN -> TcType -> TcM ErrMsg
mkTyVarEqErr dflags ctxt report ct oriented tv1 co1 ty2
= do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr co1 $$ ppr ty2)
; mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2 }
mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2
| not insoluble_occurs_check
, isUserSkolem ctxt tv1
|| isSigTyVar tv1 && not (isTyVarTy ty2)
|| ctEqRel ct == ReprEq
= mkErrorMsgFromCt ctxt ct $ mconcat
[ important $ misMatchOrCND ctxt ct oriented ty1 ty2
, important $ extraTyVarEqInfo ctxt tv1 ty2
, report
]
| OC_Occurs <- occ_check_expand
= do { let main_msg = addArising (ctOrigin ct) $
hang (text "Occurs check: cannot construct the infinite" <+> what <> colon)
2 (sep [ppr ty1, char '~', ppr ty2])
extra2 = important $ mkEqInfoMsg ct ty1 ty2
interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $
filter isTyVar $
fvVarList $
tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2
extra3 = relevant_bindings $
ppWhen (not (null interesting_tyvars)) $
hang (text "Type variable kinds:") 2 $
vcat (map (tyvar_binding . tidyTyVarOcc (cec_tidy ctxt))
interesting_tyvars)
tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv)
; mkErrorMsgFromCt ctxt ct $
mconcat [important main_msg, extra2, extra3, report] }
| OC_Bad <- occ_check_expand
= do { let msg = vcat [ text "Cannot instantiate unification variable"
<+> quotes (ppr tv1)
, hang (text "with a" <+> what <+> text "involving foralls:") 2 (ppr ty2)
, nest 2 (text "GHC doesn't yet support impredicative polymorphism") ]
; mkErrorMsgFromCt ctxt ct $ report { report_important = [msg] } }
| not (k1 `tcEqType` k2)
= do { let main_msg = addArising (ctOrigin ct) $
vcat [ hang (text "Kind mismatch: cannot unify" <+>
parens (ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1)) <+>
text "with:")
2 (sep [ppr ty2, dcolon, ppr k2])
, text "Their kinds differ." ]
cast_msg
| isTcReflexiveCo co1 = empty
| otherwise = text "NB:" <+> ppr tv1 <+>
text "was casted to have kind" <+>
quotes (ppr k1)
; mkErrorMsgFromCt ctxt ct (mconcat [important main_msg, important cast_msg, report]) }
| (implic:_) <- cec_encl ctxt
, Implic { ic_skols = skols } <- implic
, tv1 `elem` skols
= mkErrorMsgFromCt ctxt ct $ mconcat
[ important $ misMatchMsg ct oriented ty1 ty2
, important $ extraTyVarEqInfo ctxt tv1 ty2
, report
]
| (implic:_) <- cec_encl ctxt
, Implic { ic_env = env, ic_skols = skols, ic_info = skol_info } <- implic
, let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols
, not (null esc_skols)
= do { let msg = important $ misMatchMsg ct oriented ty1 ty2
esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols
<+> pprQuotedList esc_skols
, text "would escape" <+>
if isSingleton esc_skols then text "its scope"
else text "their scope" ]
tv_extra = important $
vcat [ nest 2 $ esc_doc
, sep [ (if isSingleton esc_skols
then text "This (rigid, skolem)" <+>
what <+> text "variable is"
else text "These (rigid, skolem)" <+>
what <+> text "variables are")
<+> text "bound by"
, nest 2 $ ppr skol_info
, nest 2 $ text "at" <+> ppr (tcl_loc env) ] ]
; mkErrorMsgFromCt ctxt ct (mconcat [msg, tv_extra, report]) }
| (implic:_) <- cec_encl ctxt
, Implic { ic_env = env, ic_given = given
, ic_tclvl = lvl, ic_info = skol_info } <- implic
= ASSERT2( not (isTouchableMetaTyVar lvl tv1)
, ppr tv1 $$ ppr lvl )
do { let msg = important $ misMatchMsg ct oriented ty1 ty2
tclvl_extra = important $
nest 2 $
sep [ quotes (ppr tv1) <+> text "is untouchable"
, nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given
, nest 2 $ text "bound by" <+> ppr skol_info
, nest 2 $ text "at" <+> ppr (tcl_loc env) ]
tv_extra = important $ extraTyVarEqInfo ctxt tv1 ty2
add_sig = important $ suggestAddSig ctxt ty1 ty2
; mkErrorMsgFromCt ctxt ct $ mconcat
[msg, tclvl_extra, tv_extra, add_sig, report] }
| otherwise
= reportEqErr ctxt report ct oriented (mkTyVarTy tv1) ty2
where
Pair _ k1 = tcCoercionKind co1
k2 = typeKind ty2
ty1 = mkTyVarTy tv1
occ_check_expand = occCheckForErrors dflags tv1 ty2
insoluble_occurs_check = isInsolubleOccursCheck (ctEqRel ct) tv1 ty2
what = case ctLocTypeOrKind_maybe (ctLoc ct) of
Just KindLevel -> text "kind"
_ -> text "type"
mkEqInfoMsg :: Ct -> TcType -> TcType -> SDoc
mkEqInfoMsg ct ty1 ty2
= tyfun_msg $$ ambig_msg $$ invis_msg
where
mb_fun1 = isTyFun_maybe ty1
mb_fun2 = isTyFun_maybe ty2
ambig_msg | isJust mb_fun1 || isJust mb_fun2
= snd (mkAmbigMsg False ct)
| otherwise = empty
(act_ty, exp_ty) = case ctOrigin ct of
TypeEqOrigin { uo_actual = act
, uo_expected = exp } -> (act, exp)
_ -> (ty1, ty2)
invis_msg | Just vis <- tcEqTypeVis act_ty exp_ty
, not vis
= ppSuggestExplicitKinds
| otherwise
= empty
tyfun_msg | Just tc1 <- mb_fun1
, Just tc2 <- mb_fun2
, tc1 == tc2
, not (isInjectiveTyCon tc1 Nominal)
= text "NB:" <+> quotes (ppr tc1)
<+> text "is a non-injective type family"
| otherwise = empty
isUserSkolem :: ReportErrCtxt -> TcTyVar -> Bool
isUserSkolem ctxt tv
= isSkolemTyVar tv && any is_user_skol_tv (cec_encl ctxt)
where
is_user_skol_tv (Implic { ic_skols = sks, ic_info = skol_info })
= tv `elem` sks && is_user_skol_info skol_info
is_user_skol_info (InferSkol {}) = False
is_user_skol_info _ = True
misMatchOrCND :: ReportErrCtxt -> Ct
-> Maybe SwapFlag -> TcType -> TcType -> SDoc
misMatchOrCND ctxt ct oriented ty1 ty2
| null givens ||
(isRigidTy ty1 && isRigidTy ty2) ||
isGivenCt ct
= misMatchMsg ct oriented ty1 ty2
| otherwise
= couldNotDeduce givens ([eq_pred], orig)
where
ev = ctEvidence ct
eq_pred = ctEvPred ev
orig = ctEvOrigin ev
givens = [ given | given <- getUserGivens ctxt, not (ic_no_eqs given)]
couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc
couldNotDeduce givens (wanteds, orig)
= vcat [ addArising orig (text "Could not deduce:" <+> pprTheta wanteds)
, vcat (pp_givens givens)]
pp_givens :: [UserGiven] -> [SDoc]
pp_givens givens
= case givens of
[] -> []
(g:gs) -> ppr_given (text "from the context:") g
: map (ppr_given (text "or from:")) gs
where
ppr_given herald (Implic { ic_given = gs, ic_info = skol_info
, ic_env = env })
= hang (herald <+> pprEvVarTheta gs)
2 (sep [ text "bound by" <+> ppr skol_info
, text "at" <+> ppr (tcl_loc env) ])
extraTyVarEqInfo :: ReportErrCtxt -> TcTyVar -> TcType -> SDoc
extraTyVarEqInfo ctxt tv1 ty2
= extraTyVarInfo ctxt tv1 $$ ty_extra ty2
where
ty_extra ty = case tcGetTyVar_maybe ty of
Just tv -> extraTyVarInfo ctxt tv
Nothing -> empty
extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> SDoc
extraTyVarInfo ctxt tv
= ASSERT2( isTyVar tv, ppr tv )
case tcTyVarDetails tv of
SkolemTv {} -> pprSkols ctxt [tv]
RuntimeUnk {} -> quotes (ppr tv) <+> text "is an interactive-debugger skolem"
MetaTv {} -> empty
suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> SDoc
suggestAddSig ctxt ty1 ty2
| null inferred_bndrs
= empty
| [bndr] <- inferred_bndrs
= text "Possible fix: add a type signature for" <+> quotes (ppr bndr)
| otherwise
= text "Possible fix: add type signatures for some or all of" <+> (ppr inferred_bndrs)
where
inferred_bndrs = nub (get_inf ty1 ++ get_inf ty2)
get_inf ty | Just tv <- tcGetTyVar_maybe ty
, isSkolemTyVar tv
, (implic, _) : _ <- getSkolemInfo (cec_encl ctxt) [tv]
, InferSkol prs <- ic_info implic
= map fst prs
| otherwise
= []
misMatchMsg :: Ct -> Maybe SwapFlag -> TcType -> TcType -> SDoc
misMatchMsg ct oriented ty1 ty2
| Just NotSwapped <- oriented
= misMatchMsg ct (Just IsSwapped) ty2 ty1
| Just (tc1, []) <- splitTyConApp_maybe ty1
, tc1 `hasKey` liftedRepDataConKey
= lifted_vs_unlifted
| Just (tc2, []) <- splitTyConApp_maybe ty2
, tc2 `hasKey` liftedRepDataConKey
= lifted_vs_unlifted
| otherwise
= addArising orig $
sep [ text herald1 <+> quotes (ppr ty1)
, nest padding $
text herald2 <+> quotes (ppr ty2)
, sameOccExtra ty2 ty1 ]
where
herald1 = conc [ "Couldn't match"
, if is_repr then "representation of" else ""
, if is_oriented then "expected" else ""
, what ]
herald2 = conc [ "with"
, if is_repr then "that of" else ""
, if is_oriented then ("actual " ++ what) else "" ]
padding = length herald1 - length herald2
is_repr = case ctEqRel ct of { ReprEq -> True; NomEq -> False }
is_oriented = isJust oriented
orig = ctOrigin ct
what = case ctLocTypeOrKind_maybe (ctLoc ct) of
Just KindLevel -> "kind"
_ -> "type"
conc :: [String] -> String
conc = foldr1 add_space
add_space :: String -> String -> String
add_space s1 s2 | null s1 = s2
| null s2 = s1
| otherwise = s1 ++ (' ' : s2)
lifted_vs_unlifted
= addArising orig $
text "Couldn't match a lifted type with an unlifted type"
mkExpectedActualMsg :: Type -> Type -> CtOrigin -> Maybe TypeOrKind -> Bool
-> (Bool, Maybe SwapFlag, SDoc)
mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act
, uo_expected = exp
, uo_thing = maybe_thing })
m_level printExpanded
| KindLevel <- level, occurs_check_error = (True, Nothing, empty)
| isUnliftedTypeKind act, isLiftedTypeKind exp = (False, Nothing, msg2)
| isLiftedTypeKind act, isUnliftedTypeKind exp = (False, Nothing, msg3)
| isLiftedTypeKind exp && not (isConstraintKind exp)
= (False, Nothing, msg4)
| Just msg <- num_args_msg = (False, Nothing, msg $$ msg1)
| KindLevel <- level, Just th <- maybe_thing = (False, Nothing, msg5 th)
| act `pickyEqType` ty1, exp `pickyEqType` ty2 = (True, Just NotSwapped, empty)
| exp `pickyEqType` ty1, act `pickyEqType` ty2 = (True, Just IsSwapped, empty)
| otherwise = (True, Nothing, msg1)
where
level = m_level `orElse` TypeLevel
occurs_check_error
| Just act_tv <- tcGetTyVar_maybe act
, act_tv `elemVarSet` tyCoVarsOfType exp
= True
| Just exp_tv <- tcGetTyVar_maybe exp
, exp_tv `elemVarSet` tyCoVarsOfType act
= True
| otherwise
= False
sort = case level of
TypeLevel -> text "type"
KindLevel -> text "kind"
msg1 = case level of
KindLevel
| Just th <- maybe_thing
-> msg5 th
_ | not (act `pickyEqType` exp)
-> vcat [ text "Expected" <+> sort <> colon <+> ppr exp
, text " Actual" <+> sort <> colon <+> ppr act
, if printExpanded then expandedTys else empty ]
| otherwise
-> empty
thing_msg = case maybe_thing of
Just thing -> \_ -> quotes thing <+> text "is"
Nothing -> \vowel -> text "got a" <>
if vowel then char 'n' else empty
msg2 = sep [ text "Expecting a lifted type, but"
, thing_msg True, text "unlifted" ]
msg3 = sep [ text "Expecting an unlifted type, but"
, thing_msg False, text "lifted" ]
msg4 = maybe_num_args_msg $$
sep [ text "Expected a type, but"
, maybe (text "found something with kind")
(\thing -> quotes thing <+> text "has kind")
maybe_thing
, quotes (ppr act) ]
msg5 th = hang (text "Expected" <+> kind_desc <> comma)
2 (text "but" <+> quotes th <+> text "has kind" <+>
quotes (ppr act))
where
kind_desc | isConstraintKind exp = text "a constraint"
| otherwise = text "kind" <+> quotes (ppr exp)
num_args_msg = case level of
KindLevel
| not (isMetaTyVarTy exp) && not (isMetaTyVarTy act)
-> let n_act = count_args act
n_exp = count_args exp in
case n_act - n_exp of
n | n > 0
, Just thing <- maybe_thing
-> Just $ text "Expecting" <+> speakN (abs n) <+>
more <+> quotes thing
where
more
| n == 1 = text "more argument to"
| otherwise = text "more arguments to"
_ -> Nothing
_ -> Nothing
maybe_num_args_msg = case num_args_msg of
Nothing -> empty
Just m -> m
count_args ty = count isVisibleBinder $ fst $ splitPiTys ty
expandedTys =
ppUnless (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act) $ vcat
[ text "Type synonyms expanded:"
, text "Expected type:" <+> ppr expTy1
, text " Actual type:" <+> ppr expTy2
]
(expTy1, expTy2) = expandSynonymsToMatch exp act
mkExpectedActualMsg _ _ _ _ _ = panic "mkExpectedAcutalMsg"
expandSynonymsToMatch :: Type -> Type -> (Type, Type)
expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret)
where
(ty1_ret, ty2_ret) = go ty1 ty2
go :: Type -> Type -> (Type, Type)
go t1 t2
| t1 `pickyEqType` t2 =
(t1, t2)
go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
| tc1 == tc2 =
let (tys1', tys2') =
unzip (zipWith (\ty1 ty2 -> go ty1 ty2) tys1 tys2)
in (TyConApp tc1 tys1', TyConApp tc2 tys2')
go (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) =
let (t1_1', t2_1') = go t1_1 t2_1
(t1_2', t2_2') = go t1_2 t2_2
in (mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2')
go (FunTy t1_1 t1_2) (FunTy t2_1 t2_2) =
let (t1_1', t2_1') = go t1_1 t2_1
(t1_2', t2_2') = go t1_2 t2_2
in (mkFunTy t1_1' t1_2', mkFunTy t2_1' t2_2')
go (ForAllTy b1 t1) (ForAllTy b2 t2) =
let (t1', t2') = go t1 t2
in (ForAllTy b1 t1', ForAllTy b2 t2')
go (CastTy ty1 _) ty2 = go ty1 ty2
go ty1 (CastTy ty2 _) = go ty1 ty2
go t1 t2 =
let
t1_exp_tys = t1 : tyExpansions t1
t2_exp_tys = t2 : tyExpansions t2
t1_exps = length t1_exp_tys
t2_exps = length t2_exp_tys
dif = abs (t1_exps - t2_exps)
in
followExpansions $
zipEqual "expandSynonymsToMatch.go"
(if t1_exps > t2_exps then drop dif t1_exp_tys else t1_exp_tys)
(if t2_exps > t1_exps then drop dif t2_exp_tys else t2_exp_tys)
tyExpansions :: Type -> [Type]
tyExpansions = unfoldr (\t -> (\x -> (x, x)) `fmap` tcView t)
followExpansions :: [(Type, Type)] -> (Type, Type)
followExpansions [] = pprPanic "followExpansions" empty
followExpansions [(t1, t2)]
| sameShapes t1 t2 = go t1 t2
| otherwise = (t1, t2)
followExpansions ((t1, t2) : tss)
| sameShapes t1 t2 = go t1 t2
| otherwise = followExpansions tss
sameShapes :: Type -> Type -> Bool
sameShapes AppTy{} AppTy{} = True
sameShapes (TyConApp tc1 _) (TyConApp tc2 _) = tc1 == tc2
sameShapes (FunTy {}) (FunTy {}) = True
sameShapes (ForAllTy {}) (ForAllTy {}) = True
sameShapes (CastTy ty1 _) ty2 = sameShapes ty1 ty2
sameShapes ty1 (CastTy ty2 _) = sameShapes ty1 ty2
sameShapes _ _ = False
sameOccExtra :: TcType -> TcType -> SDoc
sameOccExtra ty1 ty2
| Just (tc1, _) <- tcSplitTyConApp_maybe ty1
, Just (tc2, _) <- tcSplitTyConApp_maybe ty2
, let n1 = tyConName tc1
n2 = tyConName tc2
same_occ = nameOccName n1 == nameOccName n2
same_pkg = moduleUnitId (nameModule n1) == moduleUnitId (nameModule n2)
, n1 /= n2
, same_occ
= text "NB:" <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2)
| otherwise
= empty
where
ppr_from same_pkg nm
| isGoodSrcSpan loc
= hang (quotes (ppr nm) <+> text "is defined at")
2 (ppr loc)
| otherwise
= hang (quotes (ppr nm))
2 (sep [ text "is defined in" <+> quotes (ppr (moduleName mod))
, ppUnless (same_pkg || pkg == mainUnitId) $
nest 4 $ text "in package" <+> quotes (ppr pkg) ])
where
pkg = moduleUnitId mod
mod = nameModule nm
loc = nameSrcSpan nm
mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkDictErr ctxt cts
= ASSERT( not (null cts) )
do { inst_envs <- tcGetInstEnvs
; let (ct1:_) = cts
min_cts = elim_superclasses cts
lookups = map (lookup_cls_inst inst_envs) min_cts
(no_inst_cts, overlap_cts) = partition is_no_inst lookups
; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts))
; mkErrorMsgFromCt ctxt ct1 (important err) }
where
no_givens = null (getUserGivens ctxt)
is_no_inst (ct, (matches, unifiers, _))
= no_givens
&& null matches
&& (null unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfCtList ct))
lookup_cls_inst inst_envs ct
= (ct, lookupInstEnv True inst_envs clas (flattenTys emptyInScopeSet tys))
where
(clas, tys) = getClassPredTys (ctPred ct)
elim_superclasses cts = mkMinimalBySCs ctPred cts
mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult)
-> TcM (ReportErrCtxt, SDoc)
mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_overlapped))
| null matches
= do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
; candidate_insts <- get_candidate_instances
; return (ctxt, cannot_resolve_msg ct candidate_insts binds_msg) }
| null unsafe_overlapped
= return (ctxt, overlap_msg)
| otherwise
= return (ctxt, safe_haskell_msg)
where
orig = ctOrigin ct
pred = ctPred ct
(clas, tys) = getClassPredTys pred
ispecs = [ispec | (ispec, _) <- matches]
unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped]
useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics)
get_candidate_instances :: TcM [ClsInst]
get_candidate_instances
| [ty] <- tys
= do { instEnvs <- tcGetInstEnvs
; return (filter (is_candidate_inst ty)
(classInstances instEnvs clas)) }
| otherwise = return []
is_candidate_inst ty inst
| [other_ty] <- is_tys inst
, Just (tc1, _) <- tcSplitTyConApp_maybe ty
, Just (tc2, _) <- tcSplitTyConApp_maybe other_ty
= let n1 = tyConName tc1
n2 = tyConName tc2
different_names = n1 /= n2
same_occ_names = nameOccName n1 == nameOccName n2
in different_names && same_occ_names
| otherwise = False
cannot_resolve_msg :: Ct -> [ClsInst] -> SDoc -> SDoc
cannot_resolve_msg ct candidate_insts binds_msg
= vcat [ no_inst_msg
, nest 2 extra_note
, vcat (pp_givens useful_givens)
, mb_patsyn_prov `orElse` empty
, ppWhen (has_ambig_tvs && not (null unifiers && null useful_givens))
(vcat [ ppUnless lead_with_ambig ambig_msg, binds_msg, potential_msg ])
, ppWhen (isNothing mb_patsyn_prov) $
show_fixes (ctxtFixes has_ambig_tvs pred implics
++ drv_fixes)
, ppWhen (not (null candidate_insts))
(hang (text "There are instances for similar types:")
2 (vcat (map ppr candidate_insts))) ]
where
orig = ctOrigin ct
lead_with_ambig = has_ambig_tvs && not (any isRuntimeUnkSkol ambig_tvs)
&& not (null unifiers) && null useful_givens
(has_ambig_tvs, ambig_msg) = mkAmbigMsg lead_with_ambig ct
ambig_tvs = uncurry (++) (getAmbigTkvs ct)
no_inst_msg
| lead_with_ambig
= ambig_msg <+> pprArising orig
$$ text "prevents the constraint" <+> quotes (pprParendType pred)
<+> text "from being solved."
| null useful_givens
= addArising orig $ text "No instance for"
<+> pprParendType pred
| otherwise
= addArising orig $ text "Could not deduce"
<+> pprParendType pred
potential_msg
= ppWhen (not (null unifiers) && want_potential orig) $
sdocWithDynFlags $ \dflags ->
getPprStyle $ \sty ->
pprPotentials dflags sty potential_hdr unifiers
potential_hdr
= vcat [ ppWhen lead_with_ambig $
text "Probable fix: use a type annotation to specify what"
<+> pprQuotedList ambig_tvs <+> text "should be."
, text "These potential instance" <> plural unifiers
<+> text "exist:"]
mb_patsyn_prov :: Maybe SDoc
mb_patsyn_prov
| not lead_with_ambig
, ProvCtxtOrigin PSB{ psb_def = L _ pat } <- orig
= Just (vcat [ text "In other words, a successful match on the pattern"
, nest 2 $ ppr pat
, text "does not provide the constraint" <+> pprParendType pred ])
| otherwise = Nothing
want_potential (TypeEqOrigin {}) = False
want_potential _ = True
extra_note | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys)
= text "(maybe you haven't applied a function to enough arguments?)"
| className clas == typeableClassName
, [_,ty] <- tys
, Just (tc,_) <- tcSplitTyConApp_maybe ty
, not (isTypeFamilyTyCon tc)
= hang (text "GHC can't yet do polykinded")
2 (text "Typeable" <+>
parens (ppr ty <+> dcolon <+> ppr (typeKind ty)))
| otherwise
= empty
drv_fixes = case orig of
DerivOrigin -> [drv_fix]
DerivOriginDC {} -> [drv_fix]
DerivOriginCoerce {} -> [drv_fix]
_ -> []
drv_fix = hang (text "use a standalone 'deriving instance' declaration,")
2 (text "so you can specify the instance context yourself")
overlap_msg
= ASSERT( not (null matches) )
vcat [ addArising orig (text "Overlapping instances for"
<+> pprType (mkClassPred clas tys))
, ppUnless (null matching_givens) $
sep [text "Matching givens (or their superclasses):"
, nest 2 (vcat matching_givens)]
, sdocWithDynFlags $ \dflags ->
getPprStyle $ \sty ->
pprPotentials dflags sty (text "Matching instances:") $
ispecs ++ unifiers
, ppWhen (null matching_givens && isSingleton matches && null unifiers) $
sep [ text "There exists a (perhaps superclass) match:"
, nest 2 (vcat (pp_givens useful_givens))]
, ppWhen (isSingleton matches) $
parens (vcat [ text "The choice depends on the instantiation of" <+>
quotes (pprWithCommas ppr (tyCoVarsOfTypesList tys))
, ppWhen (null (matching_givens)) $
vcat [ text "To pick the first instance above, use IncoherentInstances"
, text "when compiling the other instance declarations"]
])]
matching_givens = mapMaybe matchable useful_givens
matchable (Implic { ic_given = evvars, ic_info = skol_info, ic_env = env })
= case ev_vars_matching of
[] -> Nothing
_ -> Just $ hang (pprTheta ev_vars_matching)
2 (sep [ text "bound by" <+> ppr skol_info
, text "at" <+> ppr (tcl_loc env) ])
where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)
ev_var_matches ty = case getClassPredTys_maybe ty of
Just (clas', tys')
| clas' == clas
, Just _ <- tcMatchTys tys tys'
-> True
| otherwise
-> any ev_var_matches (immSuperClasses clas' tys')
Nothing -> False
safe_haskell_msg
= ASSERT( matches `lengthIs` 1 && not (null unsafe_ispecs) )
vcat [ addArising orig (text "Unsafe overlapping instances for"
<+> pprType (mkClassPred clas tys))
, sep [text "The matching instance is:",
nest 2 (pprInstance $ head ispecs)]
, vcat [ text "It is compiled in a Safe module and as such can only"
, text "overlap instances from the same module, however it"
, text "overlaps the following instances from different" <+>
text "modules:"
, nest 2 (vcat [pprInstances $ unsafe_ispecs])
]
]
ctxtFixes :: Bool -> PredType -> [Implication] -> [SDoc]
ctxtFixes has_ambig_tvs pred implics
| not has_ambig_tvs
, isTyVarClassPred pred
, (skol:skols) <- usefulContext implics pred
, let what | null skols
, SigSkol (PatSynCtxt {}) _ _ <- skol
= text "\"required\""
| otherwise
= empty
= [sep [ text "add" <+> pprParendType pred
<+> text "to the" <+> what <+> text "context of"
, nest 2 $ ppr_skol skol $$
vcat [ text "or" <+> ppr_skol skol
| skol <- skols ] ] ]
| otherwise = []
where
ppr_skol (PatSkol (RealDataCon dc) _) = text "the data constructor" <+> quotes (ppr dc)
ppr_skol (PatSkol (PatSynCon ps) _) = text "the pattern synonym" <+> quotes (ppr ps)
ppr_skol skol_info = ppr skol_info
discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven]
discardProvCtxtGivens orig givens
| ProvCtxtOrigin (PSB {psb_id = L _ name}) <- orig
= filterOut (discard name) givens
| otherwise
= givens
where
discard n (Implic { ic_info = SigSkol (PatSynCtxt n') _ _ }) = n == n'
discard _ _ = False
usefulContext :: [Implication] -> PredType -> [SkolemInfo]
usefulContext implics pred
= go implics
where
pred_tvs = tyCoVarsOfType pred
go [] = []
go (ic : ics)
| implausible ic = rest
| otherwise = ic_info ic : rest
where
rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = []
| otherwise = go ics
implausible ic
| null (ic_skols ic) = True
| implausible_info (ic_info ic) = True
| otherwise = False
implausible_info (SigSkol (InfSigCtxt {}) _ _) = True
implausible_info _ = False
show_fixes :: [SDoc] -> SDoc
show_fixes [] = empty
show_fixes (f:fs) = sep [ text "Possible fix:"
, nest 2 (vcat (f : map (text "or" <+>) fs))]
pprPotentials :: DynFlags -> PprStyle -> SDoc -> [ClsInst] -> SDoc
pprPotentials dflags sty herald insts
| null insts
= empty
| null show_these
= hang herald
2 (vcat [ not_in_scope_msg empty
, flag_hint ])
| otherwise
= hang herald
2 (vcat [ pprInstances show_these
, ppWhen (n_in_scope_hidden > 0) $
text "...plus"
<+> speakNOf n_in_scope_hidden (text "other")
, not_in_scope_msg (text "...plus")
, flag_hint ])
where
n_show = 3 :: Int
show_potentials = gopt Opt_PrintPotentialInstances dflags
(in_scope, not_in_scope) = partition inst_in_scope insts
sorted = sortBy fuzzyClsInstCmp in_scope
show_these | show_potentials = sorted
| otherwise = take n_show sorted
n_in_scope_hidden = length sorted - length show_these
inst_in_scope :: ClsInst -> Bool
inst_in_scope cls_inst = nameSetAll name_in_scope $
orphNamesOfTypes (is_tys cls_inst)
name_in_scope name
| isBuiltInSyntax name
= True
| Just mod <- nameModule_maybe name
= qual_in_scope (qualName sty mod (nameOccName name))
| otherwise
= True
qual_in_scope :: QualifyName -> Bool
qual_in_scope NameUnqual = True
qual_in_scope (NameQual {}) = True
qual_in_scope _ = False
not_in_scope_msg herald
| null not_in_scope
= empty
| otherwise
= hang (herald <+> speakNOf (length not_in_scope) (text "instance")
<+> text "involving out-of-scope types")
2 (ppWhen show_potentials (pprInstances not_in_scope))
flag_hint = ppUnless (show_potentials || equalLength show_these insts) $
text "(use -fprint-potential-instances to see them all)"
mkAmbigMsg :: Bool
-> Ct -> (Bool, SDoc)
mkAmbigMsg prepend_msg ct
| null ambig_kvs && null ambig_tvs = (False, empty)
| otherwise = (True, msg)
where
(ambig_kvs, ambig_tvs) = getAmbigTkvs ct
msg | any isRuntimeUnkSkol ambig_kvs
|| any isRuntimeUnkSkol ambig_tvs
= vcat [ text "Cannot resolve unknown runtime type"
<> plural ambig_tvs <+> pprQuotedList ambig_tvs
, text "Use :print or :force to determine these types"]
| not (null ambig_tvs)
= pp_ambig (text "type") ambig_tvs
| otherwise
= vcat [ pp_ambig (text "kind") ambig_kvs
, ppSuggestExplicitKinds ]
pp_ambig what tkvs
| prepend_msg
= text "Ambiguous" <+> what <+> text "variable"
<> plural tkvs <+> pprQuotedList tkvs
| otherwise
= text "The" <+> what <+> text "variable" <> plural tkvs
<+> pprQuotedList tkvs <+> is_or_are tkvs <+> text "ambiguous"
is_or_are [_] = text "is"
is_or_are _ = text "are"
pprSkols :: ReportErrCtxt -> [TcTyVar] -> SDoc
pprSkols ctxt tvs
= vcat (map pp_one (getSkolemInfo (cec_encl ctxt) tvs))
where
pp_one (Implic { ic_info = skol_info }, tvs)
| UnkSkol <- skol_info
= hang (pprQuotedList tvs)
2 (is_or_are tvs "an" "unknown")
| otherwise
= vcat [ hang (pprQuotedList tvs)
2 (is_or_are tvs "a" "rigid" <+> text "bound by")
, nest 2 (pprSkolInfo skol_info)
, nest 2 (text "at" <+> ppr (foldr1 combineSrcSpans (map getSrcSpan tvs))) ]
is_or_are [_] article adjective = text "is" <+> text article <+> text adjective
<+> text "type variable"
is_or_are _ _ adjective = text "are" <+> text adjective
<+> text "type variables"
getAmbigTkvs :: Ct -> ([Var],[Var])
getAmbigTkvs ct
= partition (`elemVarSet` dep_tkv_set) ambig_tkvs
where
tkvs = tyCoVarsOfCtList ct
ambig_tkvs = filter isAmbiguousTyVar tkvs
dep_tkv_set = tyCoVarsOfTypes (map tyVarKind tkvs)
getSkolemInfo :: [Implication] -> [TcTyVar]
-> [(Implication, [TcTyVar])]
getSkolemInfo _ []
= []
getSkolemInfo [] tvs
= pprPanic "No skolem info:" (ppr tvs)
getSkolemInfo (implic:implics) tvs
| null tvs_here = getSkolemInfo implics tvs
| otherwise = (implic, tvs_here) : getSkolemInfo implics tvs_other
where
(tvs_here, tvs_other) = partition (`elem` ic_skols implic) tvs
relevantBindings :: Bool
-> ReportErrCtxt -> Ct
-> TcM (ReportErrCtxt, SDoc, Ct)
relevantBindings want_filtering ctxt ct
= do { dflags <- getDynFlags
; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc)
; let ct_tvs = tyCoVarsOfCt ct `unionVarSet` extra_tvs
extra_tvs = case tidy_orig of
KindEqOrigin t1 m_t2 _ _ -> tyCoVarsOfTypes $
t1 : maybeToList m_t2
_ -> emptyVarSet
; traceTc "relevantBindings" $
vcat [ ppr ct
, pprCtOrigin (ctLocOrigin loc)
, ppr ct_tvs
, pprWithCommas id [ ppr id <+> dcolon <+> ppr (idType id)
| TcIdBndr id _ <- tcl_bndrs lcl_env ]
, pprWithCommas id
[ ppr id | TcIdBndr_ExpType id _ _ <- tcl_bndrs lcl_env ] ]
; (tidy_env', docs, discards)
<- go dflags env1 ct_tvs (maxRelevantBinds dflags)
emptyVarSet [] False
(remove_shadowing $ tcl_bndrs lcl_env)
; let doc = ppUnless (null docs) $
hang (text "Relevant bindings include")
2 (vcat docs $$ ppWhen discards discardMsg)
loc' = setCtLocOrigin loc tidy_orig
ct' = setCtLoc ct loc'
ctxt' = ctxt { cec_tidy = tidy_env' }
; return (ctxt', doc, ct') }
where
ev = ctEvidence ct
loc = ctEvLoc ev
lcl_env = ctLocEnv loc
run_out :: Maybe Int -> Bool
run_out Nothing = False
run_out (Just n) = n <= 0
dec_max :: Maybe Int -> Maybe Int
dec_max = fmap (\n -> n - 1)
remove_shadowing :: [TcBinder] -> [TcBinder]
remove_shadowing bindings = reverse $ fst $ foldl
(\(bindingAcc, seenNames) binding ->
if (occName binding) `elemOccSet` seenNames
then (bindingAcc, seenNames)
else (binding:bindingAcc, extendOccSet seenNames (occName binding)))
([], emptyOccSet) bindings
go :: DynFlags -> TidyEnv -> TcTyVarSet -> Maybe Int -> TcTyVarSet -> [SDoc]
-> Bool
-> [TcBinder]
-> TcM (TidyEnv, [SDoc], Bool)
go _ tidy_env _ _ _ docs discards []
= return (tidy_env, reverse docs, discards)
go dflags tidy_env ct_tvs n_left tvs_seen docs discards (tc_bndr : tc_bndrs)
= case tc_bndr of
TcTvBndr {} -> discard_it
TcIdBndr id top_lvl -> go2 (idName id) (idType id) top_lvl
TcIdBndr_ExpType name et top_lvl ->
do { mb_ty <- readExpType_maybe et
; case mb_ty of
Just ty -> go2 name ty top_lvl
Nothing -> discard_it
}
where
discard_it = go dflags tidy_env ct_tvs n_left tvs_seen docs
discards tc_bndrs
go2 id_name id_type top_lvl
= do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env id_type
; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty)
; let id_tvs = tyCoVarsOfType tidy_ty
doc = sep [ pprPrefixOcc id_name <+> dcolon <+> ppr tidy_ty
, nest 2 (parens (text "bound at"
<+> ppr (getSrcLoc id_name)))]
new_seen = tvs_seen `unionVarSet` id_tvs
; if (want_filtering && not (hasPprDebug dflags)
&& id_tvs `disjointVarSet` ct_tvs)
then discard_it
else if isTopLevel top_lvl && not (isNothing n_left)
then discard_it
else if run_out n_left && id_tvs `subVarSet` tvs_seen
then go dflags tidy_env ct_tvs n_left tvs_seen docs
True
tc_bndrs
else go dflags tidy_env' ct_tvs (dec_max n_left) new_seen
(doc:docs) discards tc_bndrs }
discardMsg :: SDoc
discardMsg = text "(Some bindings suppressed;" <+>
text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)"
subsDiscardMsg :: SDoc
subsDiscardMsg =
text "(Some substitutions suppressed;" <+>
text "use -fmax-valid-substitutions=N or -fno-max-valid-substitutions)"
warnDefaulting :: [Ct] -> Type -> TcM ()
warnDefaulting wanteds default_ty
= do { warn_default <- woptM Opt_WarnTypeDefaults
; env0 <- tcInitTidyEnv
; let tidy_env = tidyFreeTyCoVars env0 $
tyCoVarsOfCtsList (listToBag wanteds)
tidy_wanteds = map (tidyCt tidy_env) wanteds
(loc, ppr_wanteds) = pprWithArising tidy_wanteds
warn_msg =
hang (hsep [ text "Defaulting the following"
, text "constraint" <> plural tidy_wanteds
, text "to type"
, quotes (ppr default_ty) ])
2
ppr_wanteds
; setCtLocM loc $ warnTc (Reason Opt_WarnTypeDefaults) warn_default warn_msg }
solverDepthErrorTcS :: CtLoc -> TcType -> TcM a
solverDepthErrorTcS loc ty
= setCtLocM loc $
do { ty <- zonkTcType