Commit faec8d35 authored by Richard Eisenberg's avatar Richard Eisenberg

Track type variable scope more carefully.

The main job of this commit is to track more accurately the scope
of tyvars introduced by user-written foralls. For example, it would
be to have something like this:

  forall a. Int -> (forall k (b :: k). Proxy '[a, b]) -> Bool

In that type, a's kind must be k, but k isn't in scope. We had a
terrible way of doing this before (not worth repeating or describing
here, but see the old tcImplicitTKBndrs and friends), but now
we have a principled approach: make an Implication when kind-checking
a forall. Doing so then hooks into the existing machinery for
preventing skolem-escape, performing floating, etc. This also means
that we bump the TcLevel whenever going into a forall.

The new behavior is done in TcHsType.scopeTyVars, but see also
TcHsType.tc{Im,Ex}plicitTKBndrs, which have undergone significant
rewriting. There are several Notes near there to guide you. Of
particular interest there is that Implication constraints can now
have skolems that are out of order; this situation is reported in
TcErrors.

A major consequence of this is a slightly tweaked process for type-
checking type declarations. The new Note [Use SigTvs in kind-checking
pass] in TcTyClsDecls lays it out.

The error message for dependent/should_fail/TypeSkolEscape has become
noticeably worse. However, this is because the code in TcErrors goes to
some length to preserve pre-8.0 error messages for kind errors. It's time
to rip off that plaster and get rid of much of the kind-error-specific
error messages. I tried this, and doing so led to a lovely error message
for TypeSkolEscape. So: I'm accepting the error message quality regression
for now, but will open up a new ticket to fix it, along with a larger
error-message improvement I've been pondering. This applies also to
dependent/should_fail/{BadTelescope2,T14066,T14066e}, polykinds/T11142.

Other minor changes:
 - isUnliftedTypeKind didn't look for tuples and sums. It does now.

 - check_type used check_arg_type on both sides of an AppTy. But the left
   side of an AppTy isn't an arg, and this was causing a bad error message.
   I've changed it to use check_type on the left-hand side.

 - Some refactoring around when we print (TYPE blah) in error messages.
   The changes decrease the times when we do so, to good effect.
   Of course, this is still all controlled by
   -fprint-explicit-runtime-reps

Fixes #14066 #14749

Test cases: dependent/should_compile/{T14066a,T14749},
            dependent/should_fail/T14066{,c,d,e,f,g,h}
parent ca535f95
......@@ -894,7 +894,11 @@ mkDataCon name declared_infix prom_info
== Set.fromList (binderVars user_tvbs)
user_tvbs' =
ASSERT2( user_tvbs_invariant
, ppr univ_tvs $$ ppr ex_tvs $$ ppr user_tvbs )
, (vcat [ ppr name
, ppr univ_tvs
, ppr ex_tvs
, ppr eq_spec
, ppr user_tvbs ]) )
user_tvbs
con = MkData {dcName = name, dcUnique = nameUnique name,
dcVanilla = is_vanilla, dcInfix = declared_infix,
......
......@@ -35,7 +35,7 @@
module Var (
-- * The main data type and synonyms
Var, CoVar, Id, NcId, DictId, DFunId, EvVar, EqVar, EvId, IpId, JoinId,
TyVar, TypeVar, KindVar, TKVar, TyCoVar,
TyVar, TcTyVar, TypeVar, KindVar, TKVar, TyCoVar,
-- * In and Out variants
InVar, InCoVar, InId, InTyVar,
......@@ -128,6 +128,9 @@ type TyVar = Var -- Type *or* kind variable (historical)
-- | Type or Kind Variable
type TKVar = Var -- Type *or* kind variable (historical)
-- | Type variable that might be a metavariable
type TcTyVar = Var
-- | Type Variable
type TypeVar = Var -- Definitely a type variable
......@@ -378,8 +381,9 @@ updateVarTypeM f id = do { ty' <- f (varType id)
-- permitted by request ('Specified') (visible type application), or
-- prohibited entirely from appearing in source Haskell ('Inferred')?
-- See Note [TyVarBndrs, TyVarBinders, TyConBinders, and visibility] in TyCoRep
data ArgFlag = Required | Specified | Inferred
deriving (Eq, Data)
data ArgFlag = Inferred | Specified | Required
deriving (Eq, Ord, Data)
-- (<) on ArgFlag meant "is less visible than"
-- | Does this 'ArgFlag' classify an argument that is written in Haskell?
isVisibleArgFlag :: ArgFlag -> Bool
......
......@@ -1167,6 +1167,6 @@ badUseOfLevPolyPrimop id ty
levPolyPrimopErr :: Id -> Type -> [Type] -> DsM ()
levPolyPrimopErr primop ty bad_tys
= errDs $ vcat [ hang (text "Cannot use primitive with levity-polymorphic arguments:")
2 (ppr primop <+> dcolon <+> ppr ty)
2 (ppr primop <+> dcolon <+> pprWithTYPE ty)
, hang (text "Levity-polymorphic arguments:")
2 (vcat (map (\t -> ppr t <+> dcolon <+> ppr (typeKind t)) bad_tys)) ]
2 (vcat (map (\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t)) bad_tys)) ]
......@@ -19,7 +19,7 @@
module HsDecls (
-- * Toplevel declarations
HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving,
HsDerivingClause(..), LHsDerivingClause,
HsDerivingClause(..), LHsDerivingClause, NewOrData(..), newOrDataToFlavour,
-- ** Class or type declarations
TyClDecl(..), LTyClDecl,
......@@ -35,7 +35,7 @@ module HsDecls (
FamilyDecl(..), LFamilyDecl,
-- ** Instance declarations
InstDecl(..), LInstDecl, NewOrData(..), FamilyInfo(..),
InstDecl(..), LInstDecl, FamilyInfo(..),
TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,
DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour, pprFamInstLHS,
FamInstEqn, LFamInstEqn, FamEqn(..),
......@@ -958,7 +958,7 @@ famDeclHasCusk _ (FamilyDecl { fdInfo = ClosedTypeFamily _
, fdResultSig = L _ resultSig })
= hsTvbAllKinded tyvars && hasReturnKindSignature resultSig
famDeclHasCusk mb_class_cusk _ = mb_class_cusk `orElse` True
-- all un-associated open families have CUSKs!
-- all un-associated open families have CUSKs
-- | Does this family declaration have user-supplied return kind signature?
hasReturnKindSignature :: FamilyResultSig a -> Bool
......@@ -1114,6 +1114,11 @@ data NewOrData
| DataType -- ^ @data Blah ...@
deriving( Eq, Data ) -- Needed because Demand derives Eq
-- | Convert a 'NewOrData' to a 'TyConFlavour'
newOrDataToFlavour :: NewOrData -> TyConFlavour
newOrDataToFlavour NewType = NewtypeFlavour
newOrDataToFlavour DataType = DataTypeFlavour
-- | Located data Constructor Declaration
type LConDecl pass = Located (ConDecl pass)
-- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when
......
......@@ -1036,13 +1036,13 @@ splitLHsSigmaTy ty
= (tvs, ctxt, ty2)
splitLHsForAllTy :: LHsType pass -> ([LHsTyVarBndr pass], LHsType pass)
splitLHsForAllTy (L _ (HsParTy ty)) = splitLHsForAllTy ty
splitLHsForAllTy (L _ (HsForAllTy { hst_bndrs = tvs, hst_body = body })) = (tvs, body)
splitLHsForAllTy (L _ (HsParTy t)) = splitLHsForAllTy t
splitLHsForAllTy body = ([], body)
splitLHsQualTy :: LHsType pass -> (LHsContext pass, LHsType pass)
splitLHsQualTy (L _ (HsParTy ty)) = splitLHsQualTy ty
splitLHsQualTy (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body })) = (ctxt, body)
splitLHsQualTy (L _ (HsParTy t)) = splitLHsQualTy t
splitLHsQualTy body = (noLoc [], body)
splitLHsInstDeclTy :: LHsSigType GhcRn
......
......@@ -53,6 +53,7 @@ module IfaceType (
import GhcPrelude
import {-# SOURCE #-} TysWiredIn ( liftedRepDataConTyCon )
import {-# SOURCE #-} TyCoRep ( isRuntimeRepTy )
import DynFlags
import TyCon hiding ( pprPromotionQuote )
......@@ -671,7 +672,7 @@ overhead.
For this reason it was decided that we would hide RuntimeRep variables for now
(see #11549). We do this by defaulting all type variables of kind RuntimeRep to
PtrLiftedRep. This is done in a pass right before pretty-printing
LiftedRep. This is done in a pass right before pretty-printing
(defaultRuntimeRepVars, controlled by -fprint-explicit-runtime-reps)
-}
......@@ -690,8 +691,8 @@ PtrLiftedRep. This is done in a pass right before pretty-printing
-- syntactic overhead in otherwise simple type signatures (e.g. ($)). See
-- Note [Defaulting RuntimeRep variables] and #11549 for further discussion.
--
defaultRuntimeRepVars :: IfaceType -> IfaceType
defaultRuntimeRepVars = go emptyFsEnv
defaultRuntimeRepVars :: PprStyle -> IfaceType -> IfaceType
defaultRuntimeRepVars sty = go emptyFsEnv
where
go :: FastStringEnv () -> IfaceType -> IfaceType
go subs (IfaceForAllTy bndr ty)
......@@ -707,12 +708,27 @@ defaultRuntimeRepVars = go emptyFsEnv
var :: IfLclName
(var, var_kind) = binderVar bndr
go subs (IfaceTyVar tv)
go subs ty@(IfaceTyVar tv)
| tv `elemFsEnv` subs
= IfaceTyConApp liftedRep ITC_Nil
| otherwise
= ty
go _ ty@(IfaceFreeTyVar tv)
| userStyle sty && TyCoRep.isRuntimeRepTy (tyVarKind tv)
-- don't require -fprint-explicit-runtime-reps for good debugging output
= IfaceTyConApp liftedRep ITC_Nil
| otherwise
= ty
go subs (IfaceFunTy kind ty)
= IfaceFunTy (go subs kind) (go subs ty)
go subs (IfaceTyConApp tc tc_args)
= IfaceTyConApp tc (go_args subs tc_args)
go subs (IfaceTupleTy sort is_prom tc_args)
= IfaceTupleTy sort is_prom (go_args subs tc_args)
go subs (IfaceFunTy arg res)
= IfaceFunTy (go subs arg) (go subs res)
go subs (IfaceAppTy x y)
= IfaceAppTy (go subs x) (go subs y)
......@@ -723,7 +739,13 @@ defaultRuntimeRepVars = go emptyFsEnv
go subs (IfaceCastTy x co)
= IfaceCastTy (go subs x) co
go _ other = other
go _ ty@(IfaceLitTy {}) = ty
go _ ty@(IfaceCoercionTy {}) = ty
go_args :: FastStringEnv () -> IfaceTcArgs -> IfaceTcArgs
go_args _ ITC_Nil = ITC_Nil
go_args subs (ITC_Vis ty args) = ITC_Vis (go subs ty) (go_args subs args)
go_args subs (ITC_Invis ty args) = ITC_Invis (go subs ty) (go_args subs args)
liftedRep :: IfaceTyCon
liftedRep =
......@@ -739,7 +761,7 @@ eliminateRuntimeRep :: (IfaceType -> SDoc) -> IfaceType -> SDoc
eliminateRuntimeRep f ty = sdocWithDynFlags $ \dflags ->
if gopt Opt_PrintExplicitRuntimeReps dflags
then f ty
else f (defaultRuntimeRepVars ty)
else getPprStyle $ \sty -> f (defaultRuntimeRepVars sty ty)
instance Outputable IfaceTcArgs where
ppr tca = pprIfaceTcArgs tca
......
......@@ -74,9 +74,13 @@ import Data.Maybe ( catMaybes )
----------------
toIfaceTvBndr :: TyVar -> IfaceTvBndr
toIfaceTvBndr tyvar = ( occNameFS (getOccName tyvar)
, toIfaceKind (tyVarKind tyvar)
)
toIfaceTvBndr = toIfaceTvBndrX emptyVarSet
toIfaceTvBndrX :: VarSet -> TyVar -> IfaceTvBndr
toIfaceTvBndrX fr tyvar = ( occNameFS (getOccName tyvar)
, toIfaceTypeX fr (tyVarKind tyvar)
)
toIfaceIdBndr :: Id -> (IfLclName, IfaceType)
toIfaceIdBndr id = (occNameFS (getOccName id), toIfaceType (idType id))
......@@ -120,7 +124,7 @@ toIfaceTypeX fr (TyVarTy tv) -- See Note [TcTyVars in IfaceType] in IfaceType
| otherwise = IfaceTyVar (toIfaceTyVar tv)
toIfaceTypeX fr (AppTy t1 t2) = IfaceAppTy (toIfaceTypeX fr t1) (toIfaceTypeX fr t2)
toIfaceTypeX _ (LitTy n) = IfaceLitTy (toIfaceTyLit n)
toIfaceTypeX fr (ForAllTy b t) = IfaceForAllTy (toIfaceForAllBndr b)
toIfaceTypeX fr (ForAllTy b t) = IfaceForAllTy (toIfaceForAllBndrX fr b)
(toIfaceTypeX (fr `delVarSet` binderVar b) t)
toIfaceTypeX fr (FunTy t1 t2)
| isPredTy t1 = IfaceDFunTy (toIfaceTypeX fr t1) (toIfaceTypeX fr t2)
......@@ -160,7 +164,10 @@ toIfaceCoVar :: CoVar -> FastString
toIfaceCoVar = occNameFS . getOccName
toIfaceForAllBndr :: TyVarBinder -> IfaceForAllBndr
toIfaceForAllBndr (TvBndr v vis) = TvBndr (toIfaceTvBndr v) vis
toIfaceForAllBndr = toIfaceForAllBndrX emptyVarSet
toIfaceForAllBndrX :: VarSet -> TyVarBinder -> IfaceForAllBndr
toIfaceForAllBndrX fr (TvBndr v vis) = TvBndr (toIfaceTvBndrX fr v) vis
----------------
toIfaceTyCon :: TyCon -> IfaceTyCon
......
......@@ -1008,5 +1008,3 @@ liveness1 platform liveregs blockmap (LiveInstr instr _)
r_dying_br = nonDetEltsUniqSet (mkUniqSet r_dying `unionUniqSets`
live_branch_only)
-- See Note [Unique Determinism and code generation]
......@@ -2025,12 +2025,16 @@ tupleRepDataConKey = mkPreludeDataConUnique 72
sumRepDataConKey = mkPreludeDataConUnique 73
-- See Note [Wiring in RuntimeRep] in TysWiredIn
runtimeRepSimpleDataConKeys :: [Unique]
runtimeRepSimpleDataConKeys, unliftedSimpleRepDataConKeys, unliftedRepDataConKeys :: [Unique]
liftedRepDataConKey :: Unique
runtimeRepSimpleDataConKeys@(
liftedRepDataConKey : _)
runtimeRepSimpleDataConKeys@(liftedRepDataConKey : unliftedSimpleRepDataConKeys)
= map mkPreludeDataConUnique [74..82]
unliftedRepDataConKeys = vecRepDataConKey :
tupleRepDataConKey :
sumRepDataConKey :
unliftedSimpleRepDataConKeys
-- See Note [Wiring in RuntimeRep] in TysWiredIn
-- VecCount
vecCountDataConKeys :: [Unique]
......
......@@ -40,7 +40,7 @@ import FamInstEnv( normaliseType )
import FamInst( tcGetFamInstEnvs )
import TyCon
import TcType
import Type( mkStrLitTy, tidyOpenType, splitTyConApp_maybe)
import Type( mkStrLitTy, tidyOpenType, splitTyConApp_maybe, mkCastTy)
import TysPrim
import TysWiredIn( mkBoxedTupleTy )
import Id
......@@ -987,14 +987,14 @@ chooseInferredQuantifiers inferred_theta tau_tvs qtvs
| otherwise -- Can't happen; by now we know it's a partial sig
= pprPanic "report_sig_tv_err" (ppr sig)
choose_psig_context :: VarSet -> TcThetaType -> Maybe TcTyVar
choose_psig_context :: VarSet -> TcThetaType -> Maybe TcType
-> TcM (VarSet, TcThetaType)
choose_psig_context _ annotated_theta Nothing
= do { let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta
`unionVarSet` tau_tvs)
; return (free_tvs, annotated_theta) }
choose_psig_context psig_qtvs annotated_theta (Just wc_var)
choose_psig_context psig_qtvs annotated_theta (Just wc_var_ty)
= do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta seed_tvs)
-- growThetaVars just like the no-type-sig case
-- Omitting this caused #12844
......@@ -1012,7 +1012,13 @@ chooseInferredQuantifiers inferred_theta tau_tvs qtvs
| pred <- my_theta
, all (not . (`eqType` pred)) annotated_theta ]
; ctuple <- mk_ctuple inferred_diff
; writeMetaTyVar wc_var ctuple
; case tcGetCastedTyVar_maybe wc_var_ty of
-- We know that wc_co must have type kind(wc_var) ~ Constraint, as it
-- comes from the checkExpectedKind in TcHsType.tcWildCardOcc. So, to
-- make the kinds work out, we reverse the cast here.
Just (wc_var, wc_co) -> writeMetaTyVar wc_var (ctuple `mkCastTy` mkTcSymCo wc_co)
Nothing -> pprPanic "chooseInferredQuantifiers 1" (ppr wc_var_ty)
; traceTc "completeTheta" $
vcat [ ppr sig
......@@ -1517,6 +1523,7 @@ tcExtendTyVarEnvForRhs (Just sig) thing_inside
tcExtendTyVarEnvFromSig :: TcIdSigInst -> TcM a -> TcM a
tcExtendTyVarEnvFromSig sig_inst thing_inside
| TISI { sig_inst_skols = skol_prs, sig_inst_wcs = wcs } <- sig_inst
-- Note [Use tcExtendTyVar not scopeTyVars in tcRhs]
= tcExtendTyVarEnv2 wcs $
tcExtendTyVarEnv2 skol_prs $
thing_inside
......@@ -1656,6 +1663,30 @@ Example for (E2), we generate
The beta is untoucable, but floats out of the constraint and can
be solved absolutely fine.
Note [Use tcExtendTyVar not scopeTyVars in tcRhs]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Normally, any place that corresponds to Λ or ∀ in Core should be flagged
with a call to scopeTyVars, which arranges for an implication constraint
to be made, bumps the TcLevel, and (crucially) prevents a unification
variable created outside the scope of a local skolem to unify with that
skolem.
We do not need to do this here, however.
- Note that this happens only in the case of a partial signature.
Complete signatures go via tcPolyCheck, not tcPolyInfer.
- The TcLevel is incremented in tcPolyInfer, right outside the call
to tcMonoBinds. We thus don't have to worry about outer metatvs unifying
with local skolems.
- The other potential concern is that we need SkolemInfo associated with
the skolems. This, too, is OK, though: the constraints pass through
simplifyInfer (which doesn't report errors), at the end of which
the skolems will get quantified and put into an implication constraint.
Thus, by the time any errors are reported, the SkolemInfo will be
in place.
************************************************************************
* *
Generalisation
......
......@@ -144,11 +144,15 @@ tcClassSigs clas sigs def_methods
dm_bind_names :: [Name] -- These ones have a value binding in the class decl
dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
skol_info = TyConSkol ClassFlavour clas
tc_sig :: NameEnv (SrcSpan, Type) -> ([Located Name], LHsSigType GhcRn)
-> TcM [TcMethInfo]
tc_sig gen_dm_env (op_names, op_hs_ty)
= do { traceTc "ClsSig 1" (ppr op_names)
; op_ty <- tcClassSigType op_names op_hs_ty -- Class tyvars already in scope
; op_ty <- tcClassSigType skol_info op_names op_hs_ty
-- Class tyvars already in scope
; traceTc "ClsSig 2" (ppr op_names)
; return [ (op_name, op_ty, f op_name) | L _ op_name <- op_names ] }
where
......@@ -157,7 +161,7 @@ tcClassSigs clas sigs def_methods
| otherwise = Nothing
tc_gen_sig (op_names, gen_hs_ty)
= do { gen_op_ty <- tcClassSigType op_names gen_hs_ty
= do { gen_op_ty <- tcClassSigType skol_info op_names gen_hs_ty
; return [ (op_name, (loc, gen_op_ty)) | L loc op_name <- op_names ] }
{-
......@@ -194,6 +198,9 @@ tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
; let tc_item = tcDefMeth clas clas_tyvars this_dict
default_binds sig_fn prag_fn
-- tcExtendTyVarEnv here (instead of scopeTyVars) is OK:
-- the tcDefMeth calls checkConstraints to bump the TcLevel
-- and make the implication constraint
; dm_binds <- tcExtendTyVarEnv clas_tyvars $
mapM tc_item op_items
......@@ -276,7 +283,7 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
, sig_loc = getLoc (hsSigType hs_ty) }
; (ev_binds, (tc_bind, _))
<- checkConstraints (ClsSkol clas) tyvars [this_dict] $
<- checkConstraints (TyConSkol ClassFlavour (getName clas)) tyvars [this_dict] $
tcPolyCheck no_prag_fn local_dm_sig
(L bind_loc lm_bind)
......
......@@ -717,6 +717,9 @@ deriveTyData tvs tc tc_args deriv_strat deriv_pred
= setSrcSpan (getLoc (hsSigType deriv_pred)) $
-- Use loc of the 'deriving' item
do { (deriv_tvs, cls, cls_tys, cls_arg_kinds)
-- Why not scopeTyVars? Because these are *TyVar*s, not TcTyVars.
-- Their kinds are fully settled. No need to worry about skolem
-- escape.
<- tcExtendTyVarEnv tvs $
tcHsDeriv deriv_pred
-- Deriving preds may (now) mention
......
......@@ -401,10 +401,18 @@ tcExtendKindEnv extra_env thing_inside
-----------------------
-- Scoped type and kind variables
-- Before using this function, consider using TcHsType.scopeTyVars, which
-- bumps the TcLevel and thus prevents any of these TyVars from appearing
-- in kinds of tyvars in an outer scope.
-- Indeed, you should always use scopeTyVars unless some other code nearby
-- bumps the TcLevel.
tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv tvs thing_inside
= tcExtendTyVarEnv2 (mkTyVarNamePairs tvs) thing_inside
-- Before using this function, consider using TcHsType.scopeTyVars2, which
-- bumps the TcLevel and thus prevents any of these TyVars from appearing
-- in kinds of tyvars in an outer scope.
tcExtendTyVarEnv2 :: [(Name,TcTyVar)] -> TcM r -> TcM r
tcExtendTyVarEnv2 binds thing_inside
-- this should be used only for explicitly mentioned scoped variables.
......
......@@ -38,7 +38,7 @@ import Name
import RdrName ( lookupGlobalRdrEnv, lookupGRE_Name, GlobalRdrEnv
, mkRdrUnqual, isLocalGRE, greSrcSpan, pprNameProvenance
, GlobalRdrElt (..), globalRdrEnvElts )
import PrelNames ( typeableClassName, hasKey, liftedRepDataConKey )
import PrelNames ( typeableClassName, hasKey, liftedRepDataConKey, tYPETyConKey )
import Id
import Var
import VarSet
......@@ -130,7 +130,7 @@ reportUnsolved wanted
; defer_errors <- goptM Opt_DeferTypeErrors
; warn_errors <- woptM Opt_WarnDeferredTypeErrors -- implement #10283
; let type_errors | not defer_errors = TypeError
| warn_errors = TypeWarn
| warn_errors = TypeWarn (Reason Opt_WarnDeferredTypeErrors)
| otherwise = TypeDefer
; defer_holes <- goptM Opt_DeferTypedHoles
......@@ -151,7 +151,7 @@ reportUnsolved wanted
| warn_out_of_scope = HoleWarn
| otherwise = HoleDefer
; report_unsolved binds_var False type_errors expr_holes
; report_unsolved binds_var type_errors expr_holes
type_holes out_of_scope_holes wanted
; ev_binds <- getTcEvBindsMap binds_var
......@@ -166,8 +166,8 @@ reportUnsolved wanted
-- and for simplifyDefault.
reportAllUnsolved :: WantedConstraints -> TcM ()
reportAllUnsolved wanted
= do { ev_binds <- newTcEvBinds
; report_unsolved ev_binds False TypeError
= do { ev_binds <- newNoTcEvBinds
; report_unsolved ev_binds TypeError
HoleError HoleError HoleError wanted }
-- | Report all unsolved goals as warnings (but without deferring any errors to
......@@ -176,23 +176,27 @@ reportAllUnsolved wanted
warnAllUnsolved :: WantedConstraints -> TcM ()
warnAllUnsolved wanted
= do { ev_binds <- newTcEvBinds
; report_unsolved ev_binds True TypeWarn
; report_unsolved ev_binds (TypeWarn NoReason)
HoleWarn HoleWarn HoleWarn wanted }
-- | Report unsolved goals as errors or warnings.
report_unsolved :: EvBindsVar -- cec_binds
-> Bool -- Errors as warnings
-> TypeErrorChoice -- Deferred type errors
-> HoleChoice -- Expression holes
-> HoleChoice -- Type holes
-> HoleChoice -- Out of scope holes
-> WantedConstraints -> TcM ()
report_unsolved mb_binds_var err_as_warn type_errors expr_holes
report_unsolved mb_binds_var type_errors expr_holes
type_holes out_of_scope_holes wanted
| isEmptyWC wanted
= return ()
| otherwise
= do { traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted)
= do { traceTc "reportUnsolved warning/error settings:" $
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 -- Zonk to reveal all information
; env0 <- tcInitTidyEnv
......@@ -210,7 +214,6 @@ report_unsolved mb_binds_var err_as_warn type_errors expr_holes
; 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
......@@ -275,7 +278,11 @@ valid_substitutions docs = mempty { report_valid_substitutions = [docs] }
data TypeErrorChoice -- What to do for type errors found by the type checker
= TypeError -- A type error aborts compilation with an error message
| TypeWarn -- A type error is deferred to runtime, plus a compile-time warning
| TypeWarn WarnReason
-- A type error is deferred to runtime, plus a compile-time warning
-- The WarnReason should usually be (Reason Opt_WarnDeferredTypeErrors)
-- but it isn't for the Safe Haskell Overlapping Instances warnings
-- see warnAllUnsolved
| TypeDefer -- A type error is deferred to runtime; no error or warning at compile time
data HoleChoice
......@@ -289,9 +296,9 @@ instance Outputable HoleChoice where
ppr HoleDefer = text "HoleDefer"
instance Outputable TypeErrorChoice where
ppr TypeError = text "TypeError"
ppr TypeWarn = text "TypeWarn"
ppr TypeDefer = text "TypeDefer"
ppr TypeError = text "TypeError"
ppr (TypeWarn reason) = text "TypeWarn" <+> ppr reason
ppr TypeDefer = text "TypeDefer"
data ReportErrCtxt
= CEC { cec_encl :: [Implication] -- Enclosing implications
......@@ -303,10 +310,6 @@ data ReportErrCtxt
-- into warnings, and emit evidence bindings
-- into 'cec_binds' for unsolved constraints
, cec_errors_as_warns :: Bool -- Turn all errors into warnings
-- (except for Holes, which are
-- controlled by cec_type_holes and
-- cec_expr_holes)
, cec_defer_type_errors :: TypeErrorChoice -- Defer type errors until runtime
-- cec_expr_holes is a union of:
......@@ -327,7 +330,6 @@ data ReportErrCtxt
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
......@@ -336,7 +338,6 @@ instance Outputable ReportErrCtxt where
, 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
......@@ -344,6 +345,21 @@ instance Outputable ReportErrCtxt where
, text "cec_warn_redundant" <+> equals <+> ppr wr
, text "cec_suppress" <+> equals <+> ppr sup ])
-- | Returns True <=> the ReportErrCtxt indicates that something is deferred
deferringAnyBindings :: ReportErrCtxt -> Bool
-- Don't check cec_type_holes, as these don't cause bindings to be deferred
deferringAnyBindings (CEC { cec_defer_type_errors = TypeError
, cec_expr_holes = HoleError
, cec_out_of_scope_holes = HoleError }) = False
deferringAnyBindings _ = True
-- | Transforms a 'ReportErrCtxt' into one that does not defer any bindings
-- at all.
noDeferredBindings :: ReportErrCtxt -> ReportErrCtxt
noDeferredBindings ctxt = ctxt { cec_defer_type_errors = TypeError
, cec_expr_holes = HoleError
, cec_out_of_scope_holes = HoleError }
{-
Note [Suppressing error messages]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -359,7 +375,8 @@ Specifically (see reportWanteds)
-}
reportImplic :: ReportErrCtxt -> Implication -> TcM ()
reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given
reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_telescope = m_telescope
, ic_given = given
, ic_wanted = wanted, ic_binds = evb
, ic_status = status, ic_info = info
, ic_env = tcl_env, ic_tclvl = tc_lvl })
......@@ -374,7 +391,8 @@ reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given
= do { traceTc "reportImplic" (ppr implic')
; reportWanteds ctxt' tc_lvl wanted
; when (cec_warn_redundant ctxt) $
warnRedundantConstraints ctxt' tcl_env info' dead_givens }
warnRedundantConstraints ctxt' tcl_env info' dead_givens
; when bad_telescope $ reportBadTelescope ctxt tcl_env m_telescope tvs }
where
insoluble = isInsolubleStatus status
(env1, tvs') = mapAccumL tidyTyCoVarBndr (cec_tidy ctxt) tvs
......@@ -382,8 +400,9 @@ reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given
implic' = implic { ic_skols = tvs'
, ic_given = map (tidyEvVar env1) given
, ic_info = info' }
ctxt1 | termEvidenceAllowed info = ctxt
| otherwise = ctxt { cec_defer_type_errors = TypeError }
ctxt1 | NoEvBindsVar{} <- evb = noDeferredBindings ctxt
| termEvidenceAllowed info = ctxt