module GHC.Tc.Errors(
reportUnsolved, reportAllUnsolved, warnAllUnsolved,
warnDefaulting,
solverReportMsg_ExpectedActuals,
solverReportInfo_ExpectedActuals
) where
import GHC.Prelude
import GHC.Driver.Env (hsc_units)
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Driver.Config.Diagnostic
import GHC.Rename.Unbound
import GHC.Tc.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Errors.Types
import GHC.Tc.Errors.Ppr
import GHC.Tc.Types.Constraint
import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.Env( tcInitTidyEnv )
import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.Unify ( checkTyVarEq )
import GHC.Tc.Types.Origin
import GHC.Tc.Types.Evidence
import GHC.Tc.Types.EvTerm
import GHC.Tc.Instance.Family
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Errors.Hole ( findValidHoleFits, getHoleFitDispConfig, pprHoleFit )
import GHC.Types.Name
import GHC.Types.Name.Reader ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual
, emptyLocalRdrEnv, lookupGlobalRdrEnv , lookupLocalRdrOcc )
import GHC.Types.Id
import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Types.Name.Env
import GHC.Types.SrcLoc
import GHC.Types.Basic
import GHC.Types.Error
import qualified GHC.Types.Unique.Map as UM
import GHC.Unit.Module
import qualified GHC.LanguageExtensions as LangExt
import GHC.Core.Predicate
import GHC.Core.Type
import GHC.Core.Coercion
import GHC.Core.TyCo.Ppr ( pprTyVars
)
import GHC.Core.InstEnv
import GHC.Core.TyCon
import GHC.Core.DataCon
import GHC.Utils.Error (diagReasonSeverity, pprLocMsgEnvelope )
import GHC.Utils.Misc
import GHC.Utils.Outputable as O
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.FV ( fvVarList, unionFV )
import GHC.Data.Bag
import GHC.Data.List.SetOps ( equivClasses, nubOrdBy )
import GHC.Data.Maybe
import qualified GHC.Data.Strict as Strict
import Control.Monad ( unless, when, foldM, forM_ )
import Data.Foldable ( toList )
import Data.Function ( on )
import Data.List ( partition, sort, sortBy )
import Data.List.NonEmpty ( NonEmpty(..), (<|) )
import qualified Data.List.NonEmpty as NE ( map, reverse )
import Data.Ord ( comparing )
import qualified Data.Semigroup as S
reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)
reportUnsolved wanted
= do { binds_var <- newTcEvBinds
; defer_errors <- goptM Opt_DeferTypeErrors
; let type_errors | not defer_errors = ErrorWithoutFlag
| otherwise = WarningWithFlag Opt_WarnDeferredTypeErrors
; defer_holes <- goptM Opt_DeferTypedHoles
; let expr_holes | not defer_holes = ErrorWithoutFlag
| otherwise = WarningWithFlag Opt_WarnTypedHoles
; partial_sigs <- xoptM LangExt.PartialTypeSignatures
; let type_holes | not partial_sigs
= ErrorWithoutFlag
| otherwise
= WarningWithFlag Opt_WarnPartialTypeSignatures
; defer_out_of_scope <- goptM Opt_DeferOutOfScopeVariables
; let out_of_scope_holes | not defer_out_of_scope
= ErrorWithoutFlag
| otherwise
= WarningWithFlag Opt_WarnDeferredOutOfScopeVariables
; report_unsolved type_errors expr_holes
type_holes out_of_scope_holes
binds_var wanted
; ev_binds <- getTcEvBindsMap binds_var
; return (evBindMapBinds ev_binds)}
reportAllUnsolved :: WantedConstraints -> TcM ()
reportAllUnsolved wanted
= do { ev_binds <- newNoTcEvBinds
; partial_sigs <- xoptM LangExt.PartialTypeSignatures
; let type_holes | not partial_sigs = ErrorWithoutFlag
| otherwise = WarningWithFlag Opt_WarnPartialTypeSignatures
; report_unsolved ErrorWithoutFlag
ErrorWithoutFlag type_holes ErrorWithoutFlag
ev_binds wanted }
warnAllUnsolved :: WantedConstraints -> TcM ()
warnAllUnsolved wanted
= do { ev_binds <- newTcEvBinds
; report_unsolved WarningWithoutFlag
WarningWithoutFlag
WarningWithoutFlag
WarningWithoutFlag
ev_binds wanted }
report_unsolved :: DiagnosticReason
-> DiagnosticReason
-> DiagnosticReason
-> DiagnosticReason
-> EvBindsVar
-> WantedConstraints -> TcM ()
report_unsolved type_errors expr_holes
type_holes out_of_scope_holes binds_var wanted
| isEmptyWC wanted
= return ()
| otherwise
= do { traceTc "reportUnsolved {" $
vcat [ text "type errors:" <+> ppr type_errors
, text "expr holes:" <+> ppr expr_holes
, text "type holes:" <+> ppr type_holes
, text "scope holes:" <+> ppr out_of_scope_holes ]
; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted)
; wanted <- zonkWC wanted
; let tidy_env = tidyFreeTyCoVars emptyTidyEnv free_tvs
free_tvs = filterOut isCoVar $
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
; exp_syns <- goptM Opt_PrintExpandedSynonyms
; let err_ctxt = CEC { cec_encl = []
, cec_tidy = tidy_env
, cec_defer_type_errors = type_errors
, cec_expr_holes = expr_holes
, cec_type_holes = type_holes
, cec_out_of_scope_holes = out_of_scope_holes
, cec_suppress = insolubleWC wanted
, cec_warn_redundant = warn_redundant
, cec_expand_syns = exp_syns
, cec_binds = binds_var }
; tc_lvl <- getTcLevel
; reportWanteds err_ctxt tc_lvl wanted
; traceTc "reportUnsolved }" empty }
important :: SolverReportErrCtxt -> TcSolverReportMsg -> SolverReport
important ctxt doc = mempty { sr_important_msgs = [SolverReportWithCtxt ctxt doc] }
mk_relevant_bindings :: RelevantBindings -> SolverReport
mk_relevant_bindings binds = mempty { sr_supplementary = [SupplementaryBindings binds] }
mk_report_hints :: [GhcHint] -> SolverReport
mk_report_hints hints = mempty { sr_hints = hints }
deferringAnyBindings :: SolverReportErrCtxt -> Bool
deferringAnyBindings (CEC { cec_defer_type_errors = ErrorWithoutFlag
, cec_expr_holes = ErrorWithoutFlag
, cec_out_of_scope_holes = ErrorWithoutFlag }) = False
deferringAnyBindings _ = True
maybeSwitchOffDefer :: EvBindsVar -> SolverReportErrCtxt -> SolverReportErrCtxt
maybeSwitchOffDefer evb ctxt
| CoEvBindsVar{} <- evb
= ctxt { cec_defer_type_errors = ErrorWithoutFlag
, cec_expr_holes = ErrorWithoutFlag
, cec_out_of_scope_holes = ErrorWithoutFlag }
| otherwise
= ctxt
reportImplic :: SolverReportErrCtxt -> 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" $ vcat
[ text "tidy env:" <+> ppr (cec_tidy ctxt)
, text "skols: " <+> pprTyVars tvs
, text "tidy skols:" <+> pprTyVars tvs' ]
; when bad_telescope $ reportBadTelescope ctxt tcl_env info tvs
; reportWanteds ctxt' tc_lvl wanted
; when (cec_warn_redundant ctxt) $
warnRedundantConstraints ctxt' tcl_env info' dead_givens }
where
insoluble = isInsolubleStatus status
(env1, tvs') = tidyVarBndrs (cec_tidy ctxt) $
scopedSort tvs
info' = tidySkolemInfoAnon env1 info
implic' = implic { ic_skols = tvs'
, ic_given = map (tidyEvVar env1) given
, ic_info = info' }
ctxt1 = maybeSwitchOffDefer evb ctxt
ctxt' = ctxt1 { 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
_ -> []
bad_telescope = case status of
IC_BadTelescope -> True
_ -> False
warnRedundantConstraints :: SolverReportErrCtxt -> TcLclEnv -> SkolemInfoAnon -> [EvVar] -> TcM ()
warnRedundantConstraints ctxt env info ev_vars
| null redundant_evs
= return ()
| SigSkol user_ctxt _ _ <- info
= restoreLclEnv env $
setSrcSpan (redundantConstraintsSpan user_ctxt) $
report_redundant_msg True
| otherwise
= restoreLclEnv env
$ report_redundant_msg False
where
report_redundant_msg :: Bool
-> TcRn ()
report_redundant_msg show_info
= do { lcl_env <- getLclEnv
; msg <-
mkErrorReport
lcl_env
(TcRnRedundantConstraints redundant_evs (info, show_info))
(Just ctxt)
[]
; reportDiagnostic msg }
redundant_evs =
filterOut is_type_error $
case info of
InstSkol -> filterOut (improving . idType) ev_vars
_ -> ev_vars
is_type_error = isJust . userTypeError_maybe . idType
improving pred
= any isImprovementPred (pred : transSuperClasses pred)
reportBadTelescope :: SolverReportErrCtxt -> TcLclEnv -> SkolemInfoAnon -> [TcTyVar] -> TcM ()
reportBadTelescope ctxt env (ForAllSkol telescope) skols
= do { msg <- mkErrorReport
env
(TcRnSolverReport [report] ErrorWithoutFlag noHints)
(Just ctxt)
[]
; reportDiagnostic msg }
where
report = SolverReportWithCtxt ctxt $ BadTelescope telescope skols
reportBadTelescope _ _ skol_info skols
= pprPanic "reportBadTelescope" (ppr skol_info $$ ppr skols)
ignoreConstraint :: Ct -> Bool
ignoreConstraint ct
| AssocFamPatOrigin <- ctOrigin ct
= True
| otherwise
= False
mkErrorItem :: Ct -> TcM (Maybe ErrorItem)
mkErrorItem ct
| ignoreConstraint ct
= do { traceTc "Ignoring constraint:" (ppr ct)
; return Nothing }
| otherwise
= do { let loc = ctLoc ct
flav = ctFlavour ct
; (suppress, m_evdest) <- case ctEvidence ct of
CtGiven {} -> return (False, Nothing)
CtWanted { ctev_rewriters = rewriters, ctev_dest = dest }
-> do { supp <- anyUnfilledCoercionHoles rewriters
; return (supp, Just dest) }
; let m_reason = case ct of CIrredCan { cc_reason = reason } -> Just reason
_ -> Nothing
; return $ Just $ EI { ei_pred = ctPred ct
, ei_evdest = m_evdest
, ei_flavour = flav
, ei_loc = loc
, ei_m_reason = m_reason
, ei_suppress = suppress }}
reportWanteds :: SolverReportErrCtxt -> TcLevel -> WantedConstraints -> TcM ()
reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics
, wc_errors = errs })
| isEmptyWC wc = traceTc "reportWanteds empty WC" empty
| otherwise
= do { tidy_items <- mapMaybeM mkErrorItem tidy_cts
; traceTc "reportWanteds 1" (vcat [ text "Simples =" <+> ppr simples
, text "Suppress =" <+> ppr (cec_suppress ctxt)
, text "tidy_cts =" <+> ppr tidy_cts
, text "tidy_items =" <+> ppr tidy_items
, text "tidy_errs =" <+> ppr tidy_errs ])
; assertPprM
( do { errs_already <- ifErrsM (return True) (return False)
; return $
errs_already ||
null simples ||
any ignoreConstraint simples ||
not (all ei_suppress tidy_items)
} )
(vcat [text "reportWanteds is suppressing all errors"])
; let (out_of_scope, other_holes, not_conc_errs) = partition_errors tidy_errs
ctxt_for_scope_errs = ctxt { cec_suppress = False }
; (_, no_out_of_scope) <- askNoErrs $
reportHoles tidy_items ctxt_for_scope_errs out_of_scope
; let ctxt_for_insols = ctxt { cec_suppress = not no_out_of_scope }
; reportHoles tidy_items ctxt_for_insols other_holes
; reportNotConcreteErrs ctxt_for_insols not_conc_errs
; let (suppressed_items, items0) = partition suppress tidy_items
; traceTc "reportWanteds suppressed:" (ppr suppressed_items)
; (ctxt1, items1) <- tryReporters ctxt_for_insols report1 items0
; let ctxt2 = ctxt1 { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 }
; (ctxt3, leftovers) <- tryReporters ctxt2 report2 items1
; massertPpr (null leftovers)
(text "The following unsolved Wanted constraints \
\have not been reported to the user:"
$$ ppr leftovers)
; mapBagM_ (reportImplic ctxt2) implics
; whenNoErrs $
do { (_, more_leftovers) <- tryReporters ctxt3 report3 suppressed_items
; massertPpr (null more_leftovers) (ppr more_leftovers) } }
where
env = cec_tidy ctxt
tidy_cts = bagToList (mapBag (tidyCt env) simples)
tidy_errs = bagToList (mapBag (tidyDelayedError env) errs)
partition_errors :: [DelayedError] -> ([Hole], [Hole], [NotConcreteError])
partition_errors = go [] [] []
where
go out_of_scope other_holes syn_eqs []
= (out_of_scope, other_holes, syn_eqs)
go es1 es2 es3 (err:errs)
| (es1, es2, es3) <- go es1 es2 es3 errs
= case err of
DE_Hole hole
| isOutOfScopeHole hole
-> (hole : es1, es2, es3)
| otherwise
-> (es1, hole : es2, es3)
DE_NotConcrete err
-> (es1, es2, err : es3)
suppress :: ErrorItem -> Bool
suppress item
| Wanted <- ei_flavour item
= is_ww_fundep_item item
| otherwise
= False
report1 = [ ("custom_error", is_user_type_error, True, mkUserTypeErrorReporter)
, given_eq_spec
, ("insoluble2", utterly_wrong, True, mkGroupReporter mkEqErr)
, ("skolem eq1", very_wrong, True, mkSkolReporter)
, ("FixedRuntimeRep", is_FRR, True, mkGroupReporter mkFRRErr)
, ("skolem eq2", skolem_eq, True, mkSkolReporter)
, ("non-tv eq", non_tv_eq, True, mkSkolReporter)
, ("Homo eqs", is_homo_equality, True, mkGroupReporter mkEqErr)
, ("Other eqs", is_equality, True, mkGroupReporter mkEqErr)
]
report2 = [ ("Implicit params", is_ip, False, mkGroupReporter mkIPErr)
, ("Irreds", is_irred, False, mkGroupReporter mkIrredErr)
, ("Dicts", is_dict, False, mkGroupReporter mkDictErr) ]
report3 = [ ("wanted/wanted fundeps", is_ww_fundep, True, mkGroupReporter mkEqErr)
]
is_dict, is_equality, is_ip, is_FRR, is_irred :: ErrorItem -> Pred -> Bool
is_given_eq item pred
| Given <- ei_flavour item
, EqPred {} <- pred = True
| 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
is_FRR item _ = isJust $ fixedRuntimeRepOrigin_maybe item
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_user_type_error item _ = isUserTypeError (errorItemPred item)
is_homo_equality _ (EqPred _ ty1 ty2)
= tcTypeKind ty1 `tcEqType` tcTypeKind 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
is_ww_fundep item _ = is_ww_fundep_item item
is_ww_fundep_item = isWantedWantedFunDepOrigin . errorItemOrigin
given_eq_spec
| has_gadt_match_here
= ("insoluble1a", is_given_eq, True, mkGivenErrorReporter)
| otherwise
= ("insoluble1b", is_given_eq, False, ignoreErrorReporter)
has_gadt_match_here = has_gadt_match (cec_encl ctxt)
has_gadt_match [] = False
has_gadt_match (implic : implics)
| PatSkol {} <- ic_info implic
, ic_given_eqs implic /= NoGivenEqs
, ic_warn_inaccessible implic
= True
| otherwise
= has_gadt_match implics
isSkolemTy :: TcLevel -> Type -> Bool
isSkolemTy tc_lvl ty
| Just tv <- getTyVar_maybe ty
= isSkolemTyVar tv
|| (isTyVarTyVar 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
= SolverReportErrCtxt -> [ErrorItem] -> TcM ()
type ReporterSpec
= ( String
, ErrorItem -> Pred -> Bool
, Bool
, Reporter)
mkSkolReporter :: Reporter
mkSkolReporter ctxt items
= mapM_ (reportGroup mkEqErr ctxt) (group items)
where
group [] = []
group (item:items) = (item : yeses) : group noes
where
(yeses, noes) = partition (group_with item) items
group_with item1 item2
| EQ <- cmp_loc item1 item2 = True
| eq_lhs_type item1 item2 = True
| otherwise = False
reportHoles :: [ErrorItem]
-> SolverReportErrCtxt -> [Hole] -> TcM ()
reportHoles tidy_items ctxt holes
= do
diag_opts <- initDiagOpts <$> getDynFlags
let severity = diagReasonSeverity diag_opts (cec_type_holes ctxt)
holes' = filter (keepThisHole severity) holes
(tidy_env', lcl_name_cache) <- zonkTidyTcLclEnvs (cec_tidy ctxt) (map (ctl_env . hole_loc) holes')
let ctxt' = ctxt { cec_tidy = tidy_env' }
forM_ holes' $ \hole -> do { msg <- mkHoleError lcl_name_cache tidy_items ctxt' hole
; reportDiagnostic msg }
keepThisHole :: Severity -> Hole -> Bool
keepThisHole sev hole
= case hole_sort hole of
ExprHole {} -> True
TypeHole -> keep_type_hole
ConstraintHole -> keep_type_hole
where
keep_type_hole = case sev of
SevIgnore -> False
_ -> True
zonkTidyTcLclEnvs :: TidyEnv -> [TcLclEnv] -> TcM (TidyEnv, NameEnv Type)
zonkTidyTcLclEnvs tidy_env lcls = foldM go (tidy_env, emptyNameEnv) (concatMap tcl_bndrs lcls)
where
go envs tc_bndr = case tc_bndr of
TcTvBndr {} -> return envs
TcIdBndr id _top_lvl -> go_one (idName id) (idType id) envs
TcIdBndr_ExpType name et _top_lvl ->
do { mb_ty <- readExpType_maybe et
; case mb_ty of
Just ty -> go_one name ty envs
Nothing -> return envs
}
go_one name ty (tidy_env, name_env) = do
if name `elemNameEnv` name_env
then return (tidy_env, name_env)
else do
(tidy_env', tidy_ty) <- zonkTidyTcType tidy_env ty
return (tidy_env', extendNameEnv name_env name tidy_ty)
reportNotConcreteErrs :: SolverReportErrCtxt -> [NotConcreteError] -> TcM ()
reportNotConcreteErrs _ [] = return ()
reportNotConcreteErrs ctxt errs@(err0:_)
= do { msg <- mkErrorReport (ctLocEnv (nce_loc err0)) diag (Just ctxt) []
; reportDiagnostic msg }
where
frr_origins = acc_errors errs
diag = TcRnSolverReport
[SolverReportWithCtxt ctxt (FixedRuntimeRepError frr_origins)]
ErrorWithoutFlag noHints
acc_errors = go []
where
go frr_errs [] = frr_errs
go frr_errs (err:errs)
| frr_errs <- go frr_errs errs
= case err of
NCE_FRR
{ nce_frr_origin = frr_orig
, nce_reasons = _not_conc } ->
FRR_Info
{ frr_info_origin = frr_orig
, frr_info_not_concrete = Nothing }
: frr_errs
mkUserTypeErrorReporter :: Reporter
mkUserTypeErrorReporter ctxt
= mapM_ $ \item -> do { let err = important ctxt $ mkUserTypeError item
; maybeReportError ctxt [item] err
; addDeferredBinding ctxt err item }
mkUserTypeError :: ErrorItem -> TcSolverReportMsg
mkUserTypeError item =
case getUserTypeErrorMsg (errorItemPred item) of
Just msg -> UserTypeError msg
Nothing -> pprPanic "mkUserTypeError" (ppr item)
mkGivenErrorReporter :: Reporter
mkGivenErrorReporter ctxt items
= do { (ctxt, relevant_binds, item) <- relevantBindings True ctxt item
; let (implic:_) = cec_encl ctxt
loc' = setCtLocEnv (ei_loc item) (ic_env implic)
item' = item { ei_loc = loc' }
; (eq_err_msgs, _hints) <- mkEqErr_help ctxt item' ty1 ty2
; let supplementary = [ SupplementaryBindings relevant_binds ]
msg = TcRnInaccessibleCode implic (NE.reverse . NE.map (SolverReportWithCtxt ctxt) $ eq_err_msgs)
; msg <- mkErrorReport (ctLocEnv loc') msg (Just ctxt) supplementary
; reportDiagnostic msg }
where
(item : _ ) = items
(ty1, ty2) = getEqPredTys (errorItemPred item)
ignoreErrorReporter :: Reporter
ignoreErrorReporter ctxt items
= do { traceTc "mkGivenErrorReporter no" (ppr items $$ ppr (cec_encl ctxt))
; return () }
mkGroupReporter :: (SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport)
-> Reporter
mkGroupReporter mk_err ctxt items
= mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc items)
eq_lhs_type :: ErrorItem -> ErrorItem -> Bool
eq_lhs_type item1 item2
= case (classifyPredType (errorItemPred item1), classifyPredType (errorItemPred item2)) of
(EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) ->
(eq_rel1 == eq_rel2) && (ty1 `eqType` ty2)
_ -> pprPanic "mkSkolReporter" (ppr item1 $$ ppr item2)
cmp_loc :: ErrorItem -> ErrorItem -> Ordering
cmp_loc item1 item2 = get item1 `compare` get item2
where
get ei = realSrcSpanStart (ctLocSpan (errorItemCtLoc ei))
reportGroup :: (SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport) -> Reporter
reportGroup mk_err ctxt items
= do { err <- mk_err ctxt items
; traceTc "About to maybeReportErr" $
vcat [ text "Constraint:" <+> ppr items
, text "cec_suppress =" <+> ppr (cec_suppress ctxt)
, text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ]
; maybeReportError ctxt items err
; traceTc "reportGroup" (ppr items)
; mapM_ (addDeferredBinding ctxt err) items }
nonDeferrableOrigin :: CtOrigin -> Bool
nonDeferrableOrigin NonLinearPatternOrigin = True
nonDeferrableOrigin (UsageEnvironmentOf {}) = True
nonDeferrableOrigin (FRROrigin {}) = True
nonDeferrableOrigin _ = False
maybeReportError :: SolverReportErrCtxt
-> [ErrorItem]
-> SolverReport -> TcM ()
maybeReportError ctxt items@(item1:_) (SolverReport { sr_important_msgs = important
, sr_supplementary = supp
, sr_hints = hints })
= unless (cec_suppress ctxt
|| all ei_suppress items) $
do let reason | any (nonDeferrableOrigin . errorItemOrigin) items = ErrorWithoutFlag
| otherwise = cec_defer_type_errors ctxt
diag = TcRnSolverReport important reason hints
msg <- mkErrorReport (ctLocEnv (errorItemCtLoc item1)) diag (Just ctxt) supp
reportDiagnostic msg
maybeReportError _ _ _ = panic "maybeReportError"
addDeferredBinding :: SolverReportErrCtxt -> SolverReport -> ErrorItem -> TcM ()
addDeferredBinding ctxt err (EI { ei_evdest = Just dest, ei_pred = item_ty
, ei_loc = loc })
| deferringAnyBindings ctxt
= do { err_tm <- mkErrorTerm ctxt loc item_ty err
; let 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) } }
addDeferredBinding _ _ _ = return ()
mkErrorTerm :: SolverReportErrCtxt -> CtLoc -> Type
-> SolverReport -> TcM EvTerm
mkErrorTerm ctxt ct_loc ty (SolverReport { sr_important_msgs = important, sr_supplementary = supp })
= do { msg <- mkErrorReport
(ctLocEnv ct_loc)
(TcRnSolverReport important ErrorWithoutFlag noHints) (Just ctxt) supp
; dflags <- getDynFlags
; let err_msg = pprLocMsgEnvelope msg
err_str = showSDoc dflags $
err_msg $$ text "(deferred type error)"
; return $ evDelayedError ty err_str }
tryReporters :: SolverReportErrCtxt -> [ReporterSpec] -> [ErrorItem] -> TcM (SolverReportErrCtxt, [ErrorItem])
tryReporters ctxt reporters items
= do { let (vis_items, invis_items)
= partition (isVisibleOrigin . errorItemOrigin) items
; traceTc "tryReporters {" (ppr vis_items $$ ppr invis_items)
; (ctxt', items') <- go ctxt reporters vis_items invis_items
; traceTc "tryReporters }" (ppr items')
; return (ctxt', items') }
where
go ctxt [] vis_items invis_items
= return (ctxt, vis_items ++ invis_items)
go ctxt (r : rs) vis_items invis_items
= do { (ctxt', vis_items') <- tryReporter ctxt r vis_items
; (ctxt'', invis_items') <- tryReporter ctxt' r invis_items
; go ctxt'' rs vis_items' invis_items' }
tryReporter :: SolverReportErrCtxt -> ReporterSpec -> [ErrorItem] -> TcM (SolverReportErrCtxt, [ErrorItem])
tryReporter ctxt (str, keep_me, suppress_after, reporter) items
| null yeses
= return (ctxt, items)
| otherwise
= do { traceTc "tryReporter{ " (text str <+> ppr yeses)
; (_, no_errs) <- askNoErrs (reporter ctxt yeses)
; let suppress_now = not no_errs && suppress_after
ctxt' = ctxt { cec_suppress = suppress_now || cec_suppress ctxt }
; traceTc "tryReporter end }" (text str <+> ppr (cec_suppress ctxt) <+> ppr suppress_after)
; return (ctxt', nos) }
where
(yeses, nos) = partition keep items
keep item = keep_me item (classifyPredType (errorItemPred item))
mkErrorReport :: TcLclEnv
-> TcRnMessage
-> Maybe SolverReportErrCtxt
-> [SolverReportSupplementary]
-> TcM (MsgEnvelope TcRnMessage)
mkErrorReport tcl_env msg mb_ctxt supplementary
= do { mb_context <- traverse (\ ctxt -> mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)) mb_ctxt
; unit_state <- hsc_units <$> getTopEnv
; hfdc <- getHoleFitDispConfig
; let
err_info =
ErrInfo
(fromMaybe empty mb_context)
(vcat $ map (pprSolverReportSupplementary hfdc) supplementary)
; mkTcRnMessage
(RealSrcSpan (tcl_loc tcl_env) Strict.Nothing)
(TcRnMessageWithInfo unit_state $ TcRnMessageDetailed err_info msg) }
pprSolverReportSupplementary :: HoleFitDispConfig -> SolverReportSupplementary -> SDoc
pprSolverReportSupplementary hfdc = \case
SupplementaryBindings binds -> pprRelevantBindings binds
SupplementaryHoleFits fits -> pprValidHoleFits hfdc fits
SupplementaryCts cts -> pprConstraintsInclude cts
pprValidHoleFits :: HoleFitDispConfig -> ValidHoleFits -> SDoc
pprValidHoleFits hfdc (ValidHoleFits (Fits fits discarded_fits) (Fits refs discarded_refs))
= fits_msg $$ refs_msg
where
fits_msg, refs_msg, fits_discard_msg, refs_discard_msg :: SDoc
fits_msg = ppUnless (null fits) $
hang (text "Valid hole fits include") 2 $
vcat (map (pprHoleFit hfdc) fits)
$$ ppWhen discarded_fits fits_discard_msg
refs_msg = ppUnless (null refs) $
hang (text "Valid refinement hole fits include") 2 $
vcat (map (pprHoleFit hfdc) refs)
$$ ppWhen discarded_refs refs_discard_msg
fits_discard_msg =
text "(Some hole fits suppressed;" <+>
text "use -fmax-valid-hole-fits=N" <+>
text "or -fno-max-valid-hole-fits)"
refs_discard_msg =
text "(Some refinement hole fits suppressed;" <+>
text "use -fmax-refinement-hole-fits=N" <+>
text "or -fno-max-refinement-hole-fits)"
pprConstraintsInclude :: [(PredType, RealSrcSpan)] -> SDoc
pprConstraintsInclude cts
= ppUnless (null cts) $
hang (text "Constraints include")
2 (vcat $ map pprConstraint cts)
where
pprConstraint (constraint, loc) =
ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc))
mkIrredErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport
mkIrredErr ctxt items
= do { (ctxt, binds_msg, item1) <- relevantBindings True ctxt item1
; let msg = important ctxt $
CouldNotDeduce (getUserGivens ctxt) (item1 :| others) Nothing
; return $ msg `mappend` mk_relevant_bindings binds_msg }
where
(item1:others) = final_items
filtered_items = filter (not . ei_suppress) items
final_items | null filtered_items = items
| otherwise = filtered_items
mkHoleError :: NameEnv Type -> [ErrorItem] -> SolverReportErrCtxt -> Hole -> TcM (MsgEnvelope TcRnMessage)
mkHoleError _ _tidy_simples ctxt hole@(Hole { hole_occ = occ, hole_loc = ct_loc })
| isOutOfScopeHole hole
= do { dflags <- getDynFlags
; rdr_env <- getGlobalRdrEnv
; imp_info <- getImports
; curr_mod <- getModule
; hpt <- getHpt
; let (imp_errs, hints)
= unknownNameSuggestions WL_Anything
dflags hpt curr_mod rdr_env
(tcl_rdr lcl_env) imp_info (mkRdrUnqual occ)
errs = [SolverReportWithCtxt ctxt (ReportHoleError hole $ OutOfScopeHole imp_errs)]
report = SolverReport errs [] hints
; maybeAddDeferredBindings ctxt hole report
; mkErrorReport lcl_env (TcRnSolverReport errs (cec_out_of_scope_holes ctxt) hints) Nothing []
}
where
lcl_env = ctLocEnv ct_loc
mkHoleError lcl_name_cache tidy_simples ctxt
hole@(Hole { hole_ty = hole_ty
, hole_sort = sort
, hole_loc = ct_loc })
= do { rel_binds
<- relevant_bindings False lcl_env lcl_name_cache (tyCoVarsOfType hole_ty)
; show_hole_constraints <- goptM Opt_ShowHoleConstraints
; let relevant_cts
| ExprHole _ <- sort, show_hole_constraints
= givenConstraints ctxt
| otherwise
= []
; show_valid_hole_fits <- goptM Opt_ShowValidHoleFits
; (ctxt, hole_fits) <- if show_valid_hole_fits
then validHoleFits ctxt tidy_simples hole
else return (ctxt, noValidHoleFits)
; (grouped_skvs, other_tvs) <- zonkAndGroupSkolTvs hole_ty
; let reason | ExprHole _ <- sort = cec_expr_holes ctxt
| otherwise = cec_type_holes ctxt
errs = [SolverReportWithCtxt ctxt $ ReportHoleError hole $ HoleError sort other_tvs grouped_skvs]
supp = [ SupplementaryBindings rel_binds
, SupplementaryCts relevant_cts
, SupplementaryHoleFits hole_fits ]
; maybeAddDeferredBindings ctxt hole (SolverReport errs supp [])
; mkErrorReport lcl_env (TcRnSolverReport errs reason noHints) (Just ctxt) supp
}
where
lcl_env = ctLocEnv ct_loc
zonkAndGroupSkolTvs :: Type -> TcM ([(SkolemInfoAnon, [TcTyVar])], [TcTyVar])
zonkAndGroupSkolTvs hole_ty = do
zonked_info <- mapM (\(sk, tv) -> (,) <$> (zonkSkolemInfoAnon . getSkolemInfo $ sk) <*> pure (fst <$> tv)) skolem_list
return (zonked_info, other_tvs)
where
tvs = tyCoVarsOfTypeList hole_ty
(skol_tvs, other_tvs) = partition (\tv -> isTcTyVar tv && isSkolemTyVar tv) tvs
group_skolems :: UM.UniqMap SkolemInfo ([(TcTyVar, Int)])
group_skolems = bagToList <$> UM.listToUniqMap_C unionBags [(skolemSkolInfo tv, unitBag (tv, n)) | tv <- skol_tvs | n <- [0..]]
skolem_list = sortBy (comparing (sort . map snd . snd)) (UM.nonDetEltsUniqMap group_skolems)
maybeAddDeferredBindings :: SolverReportErrCtxt
-> Hole
-> SolverReport
-> TcM ()
maybeAddDeferredBindings ctxt hole report = do
case hole_sort hole of
ExprHole (HER ref ref_ty _) -> do
when (deferringAnyBindings ctxt) $ do
err_tm <- mkErrorTerm ctxt (hole_loc hole) ref_ty report
writeMutVar ref err_tm
_ -> pure ()
validHoleFits :: SolverReportErrCtxt
-> [ErrorItem]
-> Hole
-> TcM (SolverReportErrCtxt, ValidHoleFits)
validHoleFits ctxt@(CEC { cec_encl = implics
, cec_tidy = lcl_env}) simps hole
= do { (tidy_env, fits) <- findValidHoleFits lcl_env implics (map mk_wanted simps) hole
; return (ctxt {cec_tidy = tidy_env}, fits) }
where
mk_wanted :: ErrorItem -> CtEvidence
mk_wanted (EI { ei_pred = pred, ei_evdest = Just dest, ei_loc = loc })
= CtWanted { ctev_pred = pred
, ctev_dest = dest
, ctev_loc = loc
, ctev_rewriters = emptyRewriterSet }
mk_wanted item = pprPanic "validHoleFits no evdest" (ppr item)
givenConstraints :: SolverReportErrCtxt -> [(Type, RealSrcSpan)]
givenConstraints ctxt
= do { implic@Implic{ ic_given = given } <- cec_encl ctxt
; constraint <- given
; return (varType constraint, tcl_loc (ic_env implic)) }
mkIPErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport
mkIPErr ctxt items
= do { (ctxt, binds_msg, item1) <- relevantBindings True ctxt item1
; let msg = important ctxt $ UnboundImplicitParams (item1 :| others)
; return $ msg `mappend` mk_relevant_bindings binds_msg }
where
item1:others = items
mkFRRErr :: HasDebugCallStack => SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport
mkFRRErr ctxt items
= do {
; (_tidy_env, frr_infos) <-
zonkTidyFRRInfos (cec_tidy ctxt) $
nubOrdBy (nonDetCmpType `on` (frr_type . frr_info_origin)) $
map (expectJust "mkFRRErr" . fixedRuntimeRepOrigin_maybe)
items
; return $ important ctxt $ FixedRuntimeRepError frr_infos }
fixedRuntimeRepOrigin_maybe :: HasDebugCallStack => ErrorItem -> Maybe FixedRuntimeRepErrorInfo
fixedRuntimeRepOrigin_maybe item
| FRROrigin frr_orig <- errorItemOrigin item
= Just $ FRR_Info { frr_info_origin = frr_orig
, frr_info_not_concrete = Nothing }
| otherwise
= Nothing
mkEqErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport
mkEqErr ctxt items
| item:_ <- filter (not . ei_suppress) items
= mkEqErr1 ctxt item
| item:_ <- items
= mkEqErr1 ctxt item
| otherwise
= panic "mkEqErr"
mkEqErr1 :: SolverReportErrCtxt -> ErrorItem -> TcM SolverReport
mkEqErr1 ctxt item
= do { (ctxt, binds_msg, item) <- relevantBindings True ctxt item
; rdr_env <- getGlobalRdrEnv
; fam_envs <- tcGetFamInstEnvs
; let mb_coercible_msg = case errorItemEqRel item of
NomEq -> Nothing
ReprEq -> ReportCoercibleMsg <$> mkCoercibleExplanation rdr_env fam_envs ty1 ty2
; traceTc "mkEqErr1" (ppr item $$ pprCtOrigin (errorItemOrigin item))
; (last_msg :| prev_msgs, hints) <- mkEqErr_help ctxt item ty1 ty2
; let
report = foldMap (important ctxt) (reverse prev_msgs)
`mappend` (important ctxt $ mkTcReportWithInfo last_msg $ maybeToList mb_coercible_msg)
`mappend` (mk_relevant_bindings binds_msg)
`mappend` (mk_report_hints hints)
; return report }
where
(ty1, ty2) = getEqPredTys (errorItemPred item)
mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs
-> TcType -> TcType -> Maybe CoercibleMsg
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
= Just msg
| Just (tc, tys) <- splitTyConApp_maybe ty2
, (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys
, Just msg <- coercible_msg_for_tycon rep_tc
= Just msg
| Just (s1, _) <- tcSplitAppTy_maybe ty1
, Just (s2, _) <- tcSplitAppTy_maybe ty2
, s1 `eqType` s2
, has_unknown_roles s1
= Just $ UnknownRoles s1
| otherwise
= Nothing
where
coercible_msg_for_tycon tc
| isAbstractTyCon tc
= Just $ TyConIsAbstract tc
| isNewTyCon tc
, [data_con] <- tyConDataCons tc
, let dc_name = dataConName data_con
, isNothing (lookupGRE_Name rdr_env dc_name)
= Just $ OutOfScopeNewtypeConstructor tc data_con
| 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
type AccReportMsgs = NonEmpty TcSolverReportMsg
mkEqErr_help :: SolverReportErrCtxt
-> ErrorItem
-> TcType -> TcType -> TcM (AccReportMsgs, [GhcHint])
mkEqErr_help ctxt item ty1 ty2
| Just casted_tv1 <- tcGetCastedTyVar_maybe ty1
= mkTyVarEqErr ctxt item casted_tv1 ty2
| Just casted_tv2 <- tcGetCastedTyVar_maybe ty2
= mkTyVarEqErr ctxt item casted_tv2 ty1
| otherwise
= return (reportEqErr ctxt item ty1 ty2 :| [], [])
reportEqErr :: SolverReportErrCtxt
-> ErrorItem
-> TcType -> TcType -> TcSolverReportMsg
reportEqErr ctxt item ty1 ty2
= mkTcReportWithInfo mismatch eqInfos
where
mismatch = misMatchOrCND False ctxt item ty1 ty2
eqInfos = eqInfoMsgs ty1 ty2
mkTyVarEqErr :: SolverReportErrCtxt -> ErrorItem
-> (TcTyVar, TcCoercionN) -> TcType -> TcM (AccReportMsgs, [GhcHint])
mkTyVarEqErr ctxt item casted_tv1 ty2
= do { traceTc "mkTyVarEqErr" (ppr item $$ ppr casted_tv1 $$ ppr ty2)
; mkTyVarEqErr' ctxt item casted_tv1 ty2 }
mkTyVarEqErr' :: SolverReportErrCtxt -> ErrorItem
-> (TcTyVar, TcCoercionN) -> TcType -> TcM (AccReportMsgs, [GhcHint])
mkTyVarEqErr' ctxt item (tv1, co1) ty2
| Just frr_info <- mb_concrete_reason
= do
(_, infos) <- zonkTidyFRRInfos (cec_tidy ctxt) [frr_info]
return (FixedRuntimeRepError infos :| [], [])
| check_eq_result `cterHasProblem` cteImpredicative
= do
tyvar_eq_info <- extraTyVarEqInfo tv1 ty2
let
poly_msg = CannotUnifyWithPolytype item tv1 ty2
poly_msg_with_info
| isSkolemTyVar tv1
= mkTcReportWithInfo poly_msg tyvar_eq_info
| otherwise
= poly_msg
return (poly_msg_with_info <| headline_msg :| [], [])
| isSkolemTyVar tv1
|| isTyVarTyVar tv1 && not (isTyVarTy ty2)
|| errorItemEqRel item == ReprEq
= do
tv_extra <- extraTyVarEqInfo tv1 ty2
return (mkTcReportWithInfo headline_msg tv_extra :| [], add_sig)
| cterHasOccursCheck check_eq_result
= let extras2 = eqInfoMsgs ty1 ty2
interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $
filter isTyVar $
fvVarList $
tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2
extras3 = case interesting_tyvars of
[] -> []
(tv : tvs) -> [OccursCheckInterestingTyVars (tv :| tvs)]
in return (mkTcReportWithInfo headline_msg (extras2 ++ extras3) :| [], [])
| hasCoercionHoleCo co1 || hasCoercionHoleTy ty2
= return (mkBlockedEqErr item :| [], [])
| (implic:_) <- cec_encl ctxt
, Implic { ic_skols = skols } <- implic
, tv1 `elem` skols
= do
tv_extra <- extraTyVarEqInfo tv1 ty2
return (mkTcReportWithInfo mismatch_msg tv_extra :| [], [])
| (implic:_) <- cec_encl ctxt
, Implic { ic_skols = skols } <- implic
, let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols
, not (null esc_skols)
= return (SkolemEscape item implic esc_skols :| [mismatch_msg], [])
| (implic:_) <- cec_encl ctxt
, Implic { ic_tclvl = lvl } <- implic
= assertPpr (not (isTouchableMetaTyVar lvl tv1))
(ppr tv1 $$ ppr lvl) $ do
let tclvl_extra = UntouchableVariable tv1 implic
tv_extra <- extraTyVarEqInfo tv1 ty2
return (mkTcReportWithInfo tclvl_extra tv_extra :| [mismatch_msg], add_sig)
| otherwise
= return (reportEqErr ctxt item (mkTyVarTy tv1) ty2 :| [], [])
where
headline_msg = misMatchOrCND insoluble_occurs_check ctxt item ty1 ty2
mismatch_msg = mkMismatchMsg item ty1 ty2
add_sig = maybeToList $ suggestAddSig ctxt ty1 ty2
mb_concrete_reason
| Just frr_orig <- isConcreteTyVar_maybe tv1
, not (isConcrete ty2)
= Just $ frr_reason frr_orig tv1 ty2
| Just (tv2, frr_orig) <- isConcreteTyVarTy_maybe ty2
, not (isConcreteTyVar tv1)
= Just $ frr_reason frr_orig tv2 ty1
| otherwise
= Nothing
frr_reason (ConcreteFRR frr_orig) conc_tv not_conc
= FRR_Info { frr_info_origin = frr_orig
, frr_info_not_concrete = Just (conc_tv, not_conc) }
ty1 = mkTyVarTy tv1
check_eq_result = case ei_m_reason item of
Just (NonCanonicalReason result) -> result
_ -> checkTyVarEq tv1 ty2
insoluble_occurs_check = check_eq_result `cterHasProblem` cteInsolubleOccurs
eqInfoMsgs :: TcType -> TcType -> [TcSolverReportInfo]
eqInfoMsgs ty1 ty2
= catMaybes [tyfun_msg, ambig_msg]
where
mb_fun1 = isTyFun_maybe ty1
mb_fun2 = isTyFun_maybe ty2
ambig_tkvs1 = maybe mempty (\_ -> ambigTkvsOfTy ty1) mb_fun1
ambig_tkvs2 = maybe mempty (\_ -> ambigTkvsOfTy ty2) mb_fun2
ambig_tkvs@(ambig_kvs, ambig_tvs) = ambig_tkvs1 S.<> ambig_tkvs2
ambig_msg | isJust mb_fun1 || isJust mb_fun2
, not (null ambig_kvs && null ambig_tvs)
= Just $ Ambiguity False ambig_tkvs
| otherwise
= Nothing
tyfun_msg | Just tc1 <- mb_fun1
, Just tc2 <- mb_fun2
, tc1 == tc2
, not (isInjectiveTyCon tc1 Nominal)
= Just $ NonInjectiveTyFam tc1
| otherwise
= Nothing
misMatchOrCND :: Bool -> SolverReportErrCtxt -> ErrorItem
-> TcType -> TcType -> TcSolverReportMsg
misMatchOrCND insoluble_occurs_check ctxt item ty1 ty2
| insoluble_occurs_check
|| (isRigidTy ty1 && isRigidTy ty2)
|| (ei_flavour item == Given)
|| null givens
=
mkMismatchMsg item ty1 ty2
| otherwise
= CouldNotDeduce givens (item :| []) (Just $ CND_Extra level ty1 ty2)
where
level = ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel
givens = [ given | given <- getUserGivens ctxt, ic_given_eqs given /= NoGivenEqs ]
mkBlockedEqErr :: ErrorItem -> TcSolverReportMsg
mkBlockedEqErr item = BlockedEquality item
extraTyVarEqInfo :: TcTyVar -> TcType -> TcM [TcSolverReportInfo]
extraTyVarEqInfo tv1 ty2
= (:) <$> extraTyVarInfo tv1 <*> ty_extra ty2
where
ty_extra ty = case tcGetCastedTyVar_maybe ty of
Just (tv, _) -> (:[]) <$> extraTyVarInfo tv
Nothing -> return []
extraTyVarInfo :: TcTyVar -> TcM TcSolverReportInfo
extraTyVarInfo tv = assertPpr (isTyVar tv) (ppr tv) $
case tcTyVarDetails tv of
SkolemTv skol_info lvl overlaps -> do
new_skol_info <- zonkSkolemInfo skol_info
return $ TyVarInfo (mkTcTyVar (tyVarName tv) (tyVarKind tv) (SkolemTv new_skol_info lvl overlaps))
_ -> return $ TyVarInfo tv
suggestAddSig :: SolverReportErrCtxt -> TcType -> TcType -> Maybe GhcHint
suggestAddSig ctxt ty1 _ty2
| bndr : bndrs <- inferred_bndrs
= Just $ SuggestAddTypeSignatures $ NamedBindings (bndr :| bndrs)
| otherwise
= Nothing
where
inferred_bndrs =
case tcGetTyVar_maybe ty1 of
Just tv | isSkolemTyVar tv -> find (cec_encl ctxt) False tv
_ -> []
find [] _ _ = []
find (implic:implics) seen_eqs tv
| tv `elem` ic_skols implic
, InferSkol prs <- ic_info implic
, seen_eqs
= map fst prs
| otherwise
= find implics (seen_eqs || ic_given_eqs implic /= NoGivenEqs) tv
mkMismatchMsg :: ErrorItem -> Type -> Type -> TcSolverReportMsg
mkMismatchMsg item ty1 ty2 =
case orig of
TypeEqOrigin { uo_actual, uo_expected, uo_thing = mb_thing } ->
mkTcReportWithInfo
(TypeEqMismatch
{ teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds
, teq_mismatch_item = item
, teq_mismatch_ty1 = ty1
, teq_mismatch_ty2 = ty2
, teq_mismatch_actual = uo_actual
, teq_mismatch_expected = uo_expected
, teq_mismatch_what = mb_thing})
extras
KindEqOrigin cty1 cty2 sub_o mb_sub_t_or_k ->
mkTcReportWithInfo (Mismatch False item ty1 ty2)
(WhenMatching cty1 cty2 sub_o mb_sub_t_or_k : extras)
_ ->
mkTcReportWithInfo
(Mismatch False item ty1 ty2)
extras
where
orig = errorItemOrigin item
extras = sameOccExtras ty2 ty1
ppr_explicit_kinds = shouldPprWithExplicitKinds ty1 ty2 orig
shouldPprWithExplicitKinds :: Type -> Type -> CtOrigin -> Bool
shouldPprWithExplicitKinds _ty1 _ty2 (TypeEqOrigin { uo_actual = act
, uo_expected = exp
, uo_visible = vis })
| not vis = True
| otherwise = tcEqTypeVis act exp
shouldPprWithExplicitKinds ty1 ty2 _ct
= tcEqTypeVis ty1 ty2
sameOccExtras :: TcType -> TcType -> [TcSolverReportInfo]
sameOccExtras 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 = moduleUnit (nameModule n1) == moduleUnit (nameModule n2)
, n1 /= n2
, same_occ
= [SameOcc same_pkg n1 n2]
| otherwise
= []
mkDictErr :: HasDebugCallStack => SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport
mkDictErr ctxt orig_items
= assert (not (null items)) $
do { inst_envs <- tcGetInstEnvs
; let min_items = elim_superclasses items
lookups = map (lookup_cls_inst inst_envs) min_items
(no_inst_items, overlap_items) = partition is_no_inst lookups
; err <- mk_dict_err ctxt (head (no_inst_items ++ overlap_items))
; return $ important ctxt err }
where
filtered_items = filter (not . ei_suppress) orig_items
items | null filtered_items = orig_items
| otherwise = filtered_items
no_givens = null (getUserGivens ctxt)
is_no_inst (item, (matches, unifiers, _))
= no_givens
&& null matches
&& (nullUnifiers unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfTypeList (errorItemPred item)))
lookup_cls_inst inst_envs item
= (item, lookupInstEnv True inst_envs clas tys)
where
(clas, tys) = getClassPredTys (errorItemPred item)
elim_superclasses items = mkMinimalBySCs errorItemPred items
mk_dict_err :: HasCallStack => SolverReportErrCtxt -> (ErrorItem, ClsInstLookupResult)
-> TcM TcSolverReportMsg
mk_dict_err ctxt (item, (matches, unifiers, unsafe_overlapped))
| null matches
= do { (_, rel_binds, item) <- relevantBindings True ctxt item
; candidate_insts <- get_candidate_instances
; (imp_errs, field_suggestions) <- record_field_suggestions
; return (cannot_resolve_msg item candidate_insts rel_binds imp_errs field_suggestions) }
| null unsafe_overlapped
= return $ overlap_msg
| otherwise
= return $ safe_haskell_msg
where
orig = errorItemOrigin item
pred = errorItemPred item
(clas, tys) = getClassPredTys pred
ispecs = [ispec | (ispec, _) <- matches]
unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped]
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
record_field_suggestions :: TcM ([ImportError], [GhcHint])
record_field_suggestions = flip (maybe $ return ([], noHints)) record_field $ \name ->
do { glb_env <- getGlobalRdrEnv
; lcl_env <- getLocalRdrEnv
; if occ_name_in_scope glb_env lcl_env name
then return ([], noHints)
else do { dflags <- getDynFlags
; imp_info <- getImports
; curr_mod <- getModule
; hpt <- getHpt
; return (unknownNameSuggestions WL_RecField dflags hpt curr_mod
glb_env emptyLocalRdrEnv imp_info (mkRdrUnqual name)) } }
occ_name_in_scope glb_env lcl_env occ_name = not $
null (lookupGlobalRdrEnv glb_env occ_name) &&
isNothing (lookupLocalRdrOcc lcl_env occ_name)
record_field = case orig of
HasFieldOrigin name -> Just (mkVarOccFS name)
_ -> Nothing
cannot_resolve_msg :: ErrorItem -> [ClsInst] -> RelevantBindings
-> [ImportError] -> [GhcHint] -> TcSolverReportMsg
cannot_resolve_msg item candidate_insts binds imp_errs field_suggestions
= CannotResolveInstance item (getPotentialUnifiers unifiers) candidate_insts imp_errs field_suggestions binds
overlap_msg, safe_haskell_msg :: TcSolverReportMsg
overlap_msg
= assert (not (null matches)) $ OverlappingInstances item ispecs (getPotentialUnifiers unifiers)
safe_haskell_msg
= assert (matches `lengthIs` 1 && not (null unsafe_ispecs)) $
UnsafeOverlap item ispecs unsafe_ispecs
relevantBindings :: Bool
-> SolverReportErrCtxt -> ErrorItem
-> TcM (SolverReportErrCtxt, RelevantBindings, ErrorItem)
relevantBindings want_filtering ctxt item
= do { traceTc "relevantBindings" (ppr item)
; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc)
; let extra_tvs = case tidy_orig of
KindEqOrigin t1 t2 _ _ -> tyCoVarsOfTypes [t1,t2]
_ -> emptyVarSet
ct_fvs = tyCoVarsOfType (errorItemPred item) `unionVarSet` extra_tvs
loc' = setCtLocOrigin loc tidy_orig
item' = item { ei_loc = loc' }
; (env2, lcl_name_cache) <- zonkTidyTcLclEnvs env1 [lcl_env]
; relev_bds <- relevant_bindings want_filtering lcl_env lcl_name_cache ct_fvs
; let ctxt' = ctxt { cec_tidy = env2 }
; return (ctxt', relev_bds, item') }
where
loc = errorItemCtLoc item
lcl_env = ctLocEnv loc
relevant_bindings :: Bool
-> TcLclEnv
-> NameEnv Type
-> TyCoVarSet
-> TcM RelevantBindings
relevant_bindings want_filtering lcl_env lcl_name_env ct_tvs
= do { dflags <- getDynFlags
; traceTc "relevant_bindings" $
vcat [ 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 ] ]
; go dflags (maxRelevantBinds dflags)
emptyVarSet (RelevantBindings [] False)
(removeBindingShadowing $ tcl_bndrs lcl_env)
}
where
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)
go :: DynFlags -> Maybe Int -> TcTyVarSet
-> RelevantBindings
-> [TcBinder]
-> TcM RelevantBindings
go _ _ _ (RelevantBindings bds discards) []
= return $ RelevantBindings (reverse bds) discards
go dflags n_left tvs_seen rels@(RelevantBindings bds discards) (tc_bndr : tc_bndrs)
= case tc_bndr of
TcTvBndr {} -> discard_it
TcIdBndr id top_lvl -> go2 (idName id) top_lvl
TcIdBndr_ExpType name et top_lvl ->
do { mb_ty <- readExpType_maybe et
; case mb_ty of
Just _ty -> go2 name top_lvl
Nothing -> discard_it
}
where
discard_it = go dflags n_left tvs_seen rels tc_bndrs
go2 id_name top_lvl
= do { let tidy_ty = case lookupNameEnv lcl_name_env id_name of
Just tty -> tty
Nothing -> pprPanic "relevant_bindings" (ppr id_name)
; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty)
; let id_tvs = tyCoVarsOfType tidy_ty
bd = (id_name, tidy_ty)
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 n_left tvs_seen (RelevantBindings bds True)
tc_bndrs
else go dflags (dec_max n_left) new_seen
(RelevantBindings (bd:bds) discards) tc_bndrs }
warnDefaulting :: TcTyVar -> [Ct] -> Type -> TcM ()
warnDefaulting _ [] _
= panic "warnDefaulting: empty Wanteds"
warnDefaulting the_tv wanteds@(ct:_) default_ty
= do { warn_default <- woptM Opt_WarnTypeDefaults
; env0 <- tcInitTidyEnv
; let filtered = filter (not . isWantedSuperclassOrigin . ctOrigin) wanteds
tidy_env = tidyFreeTyCoVars env0 $
tyCoVarsOfCtsList (listToBag filtered)
tidy_wanteds = map (tidyCt tidy_env) filtered
tidy_tv = lookupVarEnv (snd tidy_env) the_tv
diag = TcRnWarnDefaulting tidy_wanteds tidy_tv default_ty
loc = ctLoc ct
; setCtLocM loc $ diagnosticTc warn_default diag }
solverReportMsg_ExpectedActuals :: TcSolverReportMsg -> [(Type, Type)]
solverReportMsg_ExpectedActuals
= \case
TcReportWithInfo msg infos ->
solverReportMsg_ExpectedActuals msg
++ (solverReportInfo_ExpectedActuals =<< toList infos)
Mismatch { mismatch_ty1 = exp, mismatch_ty2 = act } ->
[(exp, act)]
KindMismatch { kmismatch_expected = exp, kmismatch_actual = act } ->
[(exp, act)]
TypeEqMismatch { teq_mismatch_expected = exp, teq_mismatch_actual = act } ->
[(exp,act)]
_ -> []
solverReportInfo_ExpectedActuals :: TcSolverReportInfo -> [(Type, Type)]
solverReportInfo_ExpectedActuals
= \case
ExpectedActual { ea_expected = exp, ea_actual = act } ->
[(exp, act)]
ExpectedActualAfterTySynExpansion
{ ea_expanded_expected = exp, ea_expanded_actual = act } ->
[(exp, act)]
_ -> []