Commit 9fc65bb8 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Refactor error generation for pattern synonyms

The result of a series of patches on type-error messages for
pattern synonyms had become a bit baroque. This tidies it up
a bit.  Still not fantastic, but better.
parent 0ad2021b
...@@ -742,7 +742,7 @@ mkErrorReport ctxt tcl_env (Report important relevant_bindings) ...@@ -742,7 +742,7 @@ mkErrorReport ctxt tcl_env (Report important relevant_bindings)
(errDoc important [context] relevant_bindings) (errDoc important [context] relevant_bindings)
} }
type UserGiven = ([EvVar], SkolemInfo, Bool, RealSrcSpan) type UserGiven = Implication
getUserGivens :: ReportErrCtxt -> [UserGiven] getUserGivens :: ReportErrCtxt -> [UserGiven]
-- One item for each enclosing implication -- One item for each enclosing implication
...@@ -750,11 +750,7 @@ getUserGivens (CEC {cec_encl = implics}) = getUserGivensFromImplics implics ...@@ -750,11 +750,7 @@ getUserGivens (CEC {cec_encl = implics}) = getUserGivensFromImplics implics
getUserGivensFromImplics :: [Implication] -> [UserGiven] getUserGivensFromImplics :: [Implication] -> [UserGiven]
getUserGivensFromImplics implics getUserGivensFromImplics implics
= reverse $ = reverse (filterOut (null . ic_given) implics)
[ (givens, info, no_eqs, tcl_loc env)
| Implic { ic_given = givens, ic_env = env
, ic_no_eqs = no_eqs, ic_info = info } <- implics
, not (null givens) ]
{- {-
Note [Always warn with -fdefer-type-errors] Note [Always warn with -fdefer-type-errors]
...@@ -1343,7 +1339,7 @@ misMatchOrCND ctxt ct oriented ty1 ty2 ...@@ -1343,7 +1339,7 @@ misMatchOrCND ctxt ct oriented ty1 ty2
ev = ctEvidence ct ev = ctEvidence ct
eq_pred = ctEvPred ev eq_pred = ctEvPred ev
orig = ctEvOrigin ev orig = ctEvOrigin ev
givens = [ given | given@(_, _, no_eqs, _) <- getUserGivens ctxt, not no_eqs] givens = [ given | given <- getUserGivens ctxt, not (ic_no_eqs given)]
-- Keep only UserGivens that have some equalities -- Keep only UserGivens that have some equalities
couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc
...@@ -1358,10 +1354,11 @@ pp_givens givens ...@@ -1358,10 +1354,11 @@ pp_givens givens
(g:gs) -> ppr_given (text "from the context:") g (g:gs) -> ppr_given (text "from the context:") g
: map (ppr_given (text "or from:")) gs : map (ppr_given (text "or from:")) gs
where where
ppr_given herald (gs, skol_info, _, loc) ppr_given herald (Implic { ic_given = gs, ic_info = skol_info
, ic_env = env })
= hang (herald <+> pprEvVarTheta gs) = hang (herald <+> pprEvVarTheta gs)
2 (sep [ text "bound by" <+> ppr skol_info 2 (sep [ text "bound by" <+> ppr skol_info
, text "at" <+> ppr loc]) , text "at" <+> ppr (tcl_loc env) ])
extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> TcType -> SDoc extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> TcType -> SDoc
-- Add on extra info about skolem constants -- Add on extra info about skolem constants
...@@ -1836,16 +1833,9 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over ...@@ -1836,16 +1833,9 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over
(clas, tys) = getClassPredTys pred (clas, tys) = getClassPredTys pred
ispecs = [ispec | (ispec, _) <- matches] ispecs = [ispec | (ispec, _) <- matches]
unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped] unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped]
givens = getUserGivensFromImplics useful_implics useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics)
all_tyvars = all isTyVarTy tys -- useful_givens are the enclosing implications with non-empty givens,
useful_implics = filter is_useful_implic implics -- modulo the horrid discardProvCtxtGivens
-- See Note [Useful implications]
is_useful_implic implic
| (PatSynSigSkol name) <- ic_info implic
, ProvCtxtOrigin (PSB {psb_id = (L _ name')}) <- orig
, name == name' = False
is_useful_implic _ = True
get_candidate_instances :: TcM [ClsInst] get_candidate_instances :: TcM [ClsInst]
-- See Note [Report candidate instances] -- See Note [Report candidate instances]
...@@ -1871,11 +1861,16 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over ...@@ -1871,11 +1861,16 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over
cannot_resolve_msg ct candidate_insts binds_msg cannot_resolve_msg ct candidate_insts binds_msg
= vcat [ no_inst_msg = vcat [ no_inst_msg
, nest 2 extra_note , nest 2 extra_note
, vcat (pp_givens givens) , vcat (pp_givens useful_givens)
, in_other_words , mb_patsyn_prov `orElse` empty
, ppWhen (has_ambig_tvs && not (null unifiers && null givens)) , ppWhen (has_ambig_tvs && not (null unifiers && null useful_givens))
(vcat [ ppUnless lead_with_ambig ambig_msg, binds_msg, potential_msg ]) (vcat [ ppUnless lead_with_ambig ambig_msg, binds_msg, potential_msg ])
, show_fixes (add_to_ctxt_fixes has_ambig_tvs ++ drv_fixes)
, ppWhen (isNothing mb_patsyn_prov) $
-- Don't suggest fixes for the provided context of a pattern
-- synonym; the right fix is to bind more in the pattern
show_fixes (ctxtFixes has_ambig_tvs pred implics
++ drv_fixes)
, ppWhen (not (null candidate_insts)) , ppWhen (not (null candidate_insts))
(hang (text "There are instances for similar types:") (hang (text "There are instances for similar types:")
2 (vcat (map ppr candidate_insts))) ] 2 (vcat (map ppr candidate_insts))) ]
...@@ -1884,7 +1879,7 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over ...@@ -1884,7 +1879,7 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over
orig = ctOrigin ct orig = ctOrigin ct
-- See Note [Highlighting ambiguous type variables] -- See Note [Highlighting ambiguous type variables]
lead_with_ambig = has_ambig_tvs && not (any isRuntimeUnkSkol ambig_tvs) lead_with_ambig = has_ambig_tvs && not (any isRuntimeUnkSkol ambig_tvs)
&& not (null unifiers) && null givens && not (null unifiers) && null useful_givens
(has_ambig_tvs, ambig_msg) = mkAmbigMsg lead_with_ambig ct (has_ambig_tvs, ambig_msg) = mkAmbigMsg lead_with_ambig ct
ambig_tvs = uncurry (++) (getAmbigTkvs ct) ambig_tvs = uncurry (++) (getAmbigTkvs ct)
...@@ -1895,7 +1890,7 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over ...@@ -1895,7 +1890,7 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over
$$ text "prevents the constraint" <+> quotes (pprParendType pred) $$ text "prevents the constraint" <+> quotes (pprParendType pred)
<+> text "from being solved." <+> text "from being solved."
| null givens | null useful_givens
= addArising orig $ text "No instance for" = addArising orig $ text "No instance for"
<+> pprParendType pred <+> pprParendType pred
...@@ -1916,33 +1911,20 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over ...@@ -1916,33 +1911,20 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over
, text "These potential instance" <> plural unifiers , text "These potential instance" <> plural unifiers
<+> text "exist:"] <+> text "exist:"]
in_other_words mb_patsyn_prov :: Maybe SDoc
mb_patsyn_prov
| not lead_with_ambig | not lead_with_ambig
, ProvCtxtOrigin PSB{ psb_def = (L _ pat) } <- orig , ProvCtxtOrigin PSB{ psb_def = L _ pat } <- orig
= vcat [ text "In other words, a successful match on the pattern" = Just (vcat [ text "In other words, a successful match on the pattern"
, nest 2 $ ppr pat , nest 2 $ ppr pat
, text "does not provide the constraint" <+> pprParendType pred ] , text "does not provide the constraint" <+> pprParendType pred ])
| otherwise = empty | otherwise = Nothing
-- Report "potential instances" only when the constraint arises -- Report "potential instances" only when the constraint arises
-- directly from the user's use of an overloaded function -- directly from the user's use of an overloaded function
want_potential (TypeEqOrigin {}) = False want_potential (TypeEqOrigin {}) = False
want_potential _ = True want_potential _ = True
add_to_ctxt_fixes has_ambig_tvs
| not has_ambig_tvs && all_tyvars
, (orig:origs) <- usefulContext useful_implics pred
= [sep [ text "add" <+> pprParendType pred
<+> text "to the context of"
, nest 2 $ ppr_skol orig $$
vcat [ text "or" <+> ppr_skol orig
| orig <- origs ] ] ]
| otherwise = []
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
extra_note | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys) extra_note | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys)
= text "(maybe you haven't applied a function to enough arguments?)" = text "(maybe you haven't applied a function to enough arguments?)"
| className clas == typeableClassName -- Avoid mysterious "No instance for (Typeable T) | className clas == typeableClassName -- Avoid mysterious "No instance for (Typeable T)
...@@ -1987,7 +1969,7 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over ...@@ -1987,7 +1969,7 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over
-- simply report back the whole given -- simply report back the whole given
-- context. Accelerate Smart.hs showed this problem. -- context. Accelerate Smart.hs showed this problem.
sep [ text "There exists a (perhaps superclass) match:" sep [ text "There exists a (perhaps superclass) match:"
, nest 2 (vcat (pp_givens givens))] , nest 2 (vcat (pp_givens useful_givens))]
, ppWhen (isSingleton matches) $ , ppWhen (isSingleton matches) $
parens (vcat [ text "The choice depends on the instantiation of" <+> parens (vcat [ text "The choice depends on the instantiation of" <+>
...@@ -1996,25 +1978,24 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over ...@@ -1996,25 +1978,24 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over
vcat [ text "To pick the first instance above, use IncoherentInstances" vcat [ text "To pick the first instance above, use IncoherentInstances"
, text "when compiling the other instance declarations"] , text "when compiling the other instance declarations"]
])] ])]
where
givens = getUserGivens ctxt matching_givens = mapMaybe matchable useful_givens
matching_givens = mapMaybe matchable givens
matchable (Implic { ic_given = evvars, ic_info = skol_info, ic_env = env })
matchable (evvars,skol_info,_,loc) = case ev_vars_matching of
= case ev_vars_matching of [] -> Nothing
[] -> Nothing _ -> Just $ hang (pprTheta ev_vars_matching)
_ -> Just $ hang (pprTheta ev_vars_matching) 2 (sep [ text "bound by" <+> ppr skol_info
2 (sep [ text "bound by" <+> ppr skol_info , text "at" <+> ppr (tcl_loc env) ])
, text "at" <+> ppr loc]) where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)
where ev_vars_matching = filter ev_var_matches (map evVarPred evvars) ev_var_matches ty = case getClassPredTys_maybe ty of
ev_var_matches ty = case getClassPredTys_maybe ty of Just (clas', tys')
Just (clas', tys') | clas' == clas
| clas' == clas , Just _ <- tcMatchTys tys tys'
, Just _ <- tcMatchTys tys tys' -> True
-> True | otherwise
| otherwise -> any ev_var_matches (immSuperClasses clas' tys')
-> any ev_var_matches (immSuperClasses clas' tys') Nothing -> False
Nothing -> False
-- Overlap error because of Safe Haskell (first -- Overlap error because of Safe Haskell (first
-- match should be the most specific match) -- match should be the most specific match)
...@@ -2032,6 +2013,63 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over ...@@ -2032,6 +2013,63 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over
] ]
] ]
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 -- See Note [discardProvCtxtGivens]
| 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 picks out the implications whose context
-- the programmer might plausibly augment to solve 'pred'
usefulContext implics pred
= go implics
where
pred_tvs = tyCoVarsOfType pred
go [] = []
go (ic : ics)
| implausible ic = rest
| otherwise = ic_info ic : rest
where
-- Stop when the context binds a variable free in the predicate
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
-- Do not suggest adding constraints to an *inferred* type signature
{- Note [Report candidate instances] {- Note [Report candidate instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we have an unsolved (Num Int), where `Int` is not the Prelude Int, If we have an unsolved (Num Int), where `Int` is not the Prelude Int,
...@@ -2060,64 +2098,49 @@ from being solved: ...@@ -2060,64 +2098,49 @@ from being solved:
Once these conditions are satisfied, we can safely say that ambiguity prevents Once these conditions are satisfied, we can safely say that ambiguity prevents
the constraint from being solved. the constraint from being solved.
Note [Useful implications] Note [discardProvCtxtGivens]
~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~
In most situations we call all enclosing implications "useful". There is one In most situations we call all enclosing implications "useful". There is one
exception, and that is when the constraint that causes the error is from the exception, and that is when the constraint that causes the error is from the
"provided" context of a pattern synonym declaration. Then we only call the "provided" context of a pattern synonym declaration:
enclosing implications that are /not/ from the "required" context of the
declaration "useful". pattern Pat :: (Num a, Eq a) => Show a => a -> Maybe a
-- required => provided => type
The reason for this is that a "provided" constraint should be deducible from pattern Pat x <- (Just x, 4)
a successful pattern match, not from the "required" context. Constraints that
are deducible from the "required" context are already available at every usage When checking the pattern RHS we must check that it does actually bind all
site of the pattern synonym. the claimed "provided" constraints; in this case, does the pattern (Just x, 4)
bind the (Show a) constraint. Answer: no!
This distinction between all and "useful" implications solves two problems.
First, we never tell the user that we could not deduce a "provided" But the implication we generate for this will look like
constraint from the "required" context. Second, we never give a possible fix forall a. (Num a, Eq a) => [W] Show a
that suggests to add a "provided" constraint to the "required" context. because when checking the pattern we must make the required
constraints available, since they are needed to match the pattern (in
For example, without this distinction the following code gives a bad error this case the literal '4' needs (Num a, Eq a)).
BUT we don't want to suggest adding (Show a) to the "required" constraints
of the pattern synonym, thus:
pattern Pat :: (Num a, Eq a, Show a) => Show a => a -> Maybe a
It would then typecheck but it's silly. We want the /pattern/ to bind
the alleged "provided" constraints, Show a.
So we suppress that Implication in discardProvCtxtGivens. It's
painfully ad-hoc but the truth is that adding it to the "required"
constraints would work. Suprressing it solves two problems. First,
we never tell the user that we could not deduce a "provided"
constraint from the "required" context. Second, we never give a
possible fix that suggests to add a "provided" constraint to the
"required" context.
For example, without this distinction the above code gives a bad error
message (showing both problems): message (showing both problems):
pattern Pat :: Eq a => Show a => a -> Maybe a
pattern Pat x <- Just x
error: Could not deduce (Show a) ... from the context: (Eq a) error: Could not deduce (Show a) ... from the context: (Eq a)
... Possible fix: add (Show a) to the context of ... Possible fix: add (Show a) to the context of
the type signature for pattern synonym `Pat' ... the signature for pattern synonym `Pat' ...
-} -}
usefulContext :: [Implication] -> PredType -> [SkolemInfo]
usefulContext implics pred
= go implics
where
pred_tvs = tyCoVarsOfType pred
go [] = []
go (ic : ics)
| implausible ic = rest
| otherwise = correct_info (ic_info ic) : rest
where
-- Stop when the context binds a variable free in the predicate
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
-- Do not suggest adding constraints to an *inferred* type signature
correct_info (SigSkol (PatSynBuilderCtxt n) _) = PatSynSigSkol n
correct_info info = info
-- See example 4 in ticket #11667
show_fixes :: [SDoc] -> SDoc show_fixes :: [SDoc] -> SDoc
show_fixes [] = empty show_fixes [] = empty
show_fixes (f:fs) = sep [ text "Possible fix:" show_fixes (f:fs) = sep [ text "Possible fix:"
...@@ -2274,9 +2297,7 @@ pprSkol implics tv ...@@ -2274,9 +2297,7 @@ pprSkol implics tv
= case skol_info of = case skol_info of
UnkSkol -> pp_tv <+> text "is an unknown type variable" UnkSkol -> pp_tv <+> text "is an unknown type variable"
SigSkol ctxt ty -> ppr_rigid (pprSigSkolInfo ctxt SigSkol ctxt ty -> ppr_rigid (pprSigSkolInfo ctxt
(mkCheckExpType $ (mkSpecForAllTys skol_tvs ty))
mkSpecForAllTys skol_tvs
(checkingExpType "pprSkol" ty)))
_ -> ppr_rigid (pprSkolInfo skol_info) _ -> ppr_rigid (pprSkolInfo skol_info)
where where
pp_tv = quotes (ppr tv) pp_tv = quotes (ppr tv)
......
...@@ -241,9 +241,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details ...@@ -241,9 +241,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
, patsig_ex_bndrs = ex_bndrs, patsig_req = req_theta , patsig_ex_bndrs = ex_bndrs, patsig_req = req_theta
, patsig_arg_tys = arg_tys, patsig_body_ty = pat_ty } , patsig_arg_tys = arg_tys, patsig_body_ty = pat_ty }
= addPatSynCtxt lname $ = addPatSynCtxt lname $
do { let origin = ProvCtxtOrigin psb do { let decl_arity = length arg_names
skol_info = PatSynSigSkol name
decl_arity = length arg_names
ty_arity = length arg_tys ty_arity = length arg_tys
(arg_names, rec_fields, is_infix) = collectPatSynArgInfo details (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
...@@ -274,16 +272,20 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details ...@@ -274,16 +272,20 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
-- Note [Checking against a pattern signature] -- Note [Checking against a pattern signature]
; traceTc "tcpatsyn1" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs]) ; traceTc "tcpatsyn1" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs])
; traceTc "tcpatsyn2" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs']) ; traceTc "tcpatsyn2" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs'])
; prov_dicts <- mapM (emitWanted origin) ; let prov_theta' = substTheta (extendTCvInScopeList subst univ_tvs) prov_theta
(substTheta (extendTCvInScopeList subst univ_tvs) prov_theta) -- Add univ_tvs to the in_scope set to
-- Add the free vars of 'prov_theta' to the in_scope set to
-- satisfy the substition invariant. There's no need to -- satisfy the substition invariant. There's no need to
-- add 'ex_tvs' as they are already in the domain of the -- add 'ex_tvs' as they are already in the domain of the
-- substitution. -- substitution.
-- See also Note [The substitution invariant] in TyCoRep. -- See also Note [The substitution invariant] in TyCoRep.
; prov_dicts <- mapM (emitWanted (ProvCtxtOrigin psb)) prov_theta'
; args' <- zipWithM (tc_arg subst) arg_names arg_tys ; args' <- zipWithM (tc_arg subst) arg_names arg_tys
; return (ex_tvs', prov_dicts, args') } ; return (ex_tvs', prov_dicts, args') }
; let skol_info = SigSkol (PatSynCtxt name) (mkPhiTy req_theta pat_ty)
-- The type here is a bit bogus, but we do not print
-- the type for PatSynCtxt, so it doesn't matter
-- See TcRnTypes Note [Skolem info for pattern synonyms]
; (implics, ev_binds) <- buildImplicationFor tclvl skol_info univ_tvs req_dicts wanted ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info univ_tvs req_dicts wanted
-- Solve the constraints now, because we are about to make a PatSyn, -- Solve the constraints now, because we are about to make a PatSyn,
...@@ -709,7 +711,7 @@ get_builder_sig sig_fun name builder_id need_dummy_arg ...@@ -709,7 +711,7 @@ get_builder_sig sig_fun name builder_id need_dummy_arg
, sig_theta = req ++ prov , sig_theta = req ++ prov
, sig_tau = add_void need_dummy_arg $ , sig_tau = add_void need_dummy_arg $
mkFunTys arg_tys body_ty mkFunTys arg_tys body_ty
, sig_ctxt = PatSynBuilderCtxt name , sig_ctxt = PatSynCtxt name
, sig_loc = getSrcSpan name }) , sig_loc = getSrcSpan name })
| otherwise | otherwise
= -- No signature, so fake up a TcIdSigInfo from the builder Id = -- No signature, so fake up a TcIdSigInfo from the builder Id
......
...@@ -2577,11 +2577,6 @@ data SkolemInfo ...@@ -2577,11 +2577,6 @@ data SkolemInfo
TcType -- a programmer-supplied type signature TcType -- a programmer-supplied type signature
-- Location of the binding site is on the TyVar -- Location of the binding site is on the TyVar
| PatSynSigSkol Name -- Bound by a programmer-supplied type signature of a pattern
-- synonym. Here we cannot use a SigSkol, see
-- Note [Patterns synonyms and the data type Type] in
-- basicTypes\PatSyn.hs
| ClsSkol Class -- Bound at a class decl | ClsSkol Class -- Bound at a class decl
| DerivSkol Type -- Bound by a 'deriving' clause; | DerivSkol Type -- Bound by a 'deriving' clause;
...@@ -2645,8 +2640,6 @@ pprSkolInfo (InferSkol ids) = sep [ text "the inferred type of" ...@@ -2645,8 +2640,6 @@ pprSkolInfo (InferSkol ids) = sep [ text "the inferred type of"
, vcat [ ppr name <+> dcolon <+> ppr ty , vcat [ ppr name <+> dcolon <+> ppr ty
| (name,ty) <- ids ]] | (name,ty) <- ids ]]
pprSkolInfo (UnifyForAllSkol ty) = text "the type" <+> ppr ty pprSkolInfo (UnifyForAllSkol ty) = text "the type" <+> ppr ty
pprSkolInfo (PatSynSigSkol name) = text "the type signature of pattern synonym"
<+> quotes (ppr name)
-- UnkSkol -- UnkSkol
-- For type variables the others are dealt with by pprSkolTvBinding. -- For type variables the others are dealt with by pprSkolTvBinding.
...@@ -2657,6 +2650,7 @@ pprSigSkolInfo :: UserTypeCtxt -> TcType -> SDoc ...@@ -2657,6 +2650,7 @@ pprSigSkolInfo :: UserTypeCtxt -> TcType -> SDoc
pprSigSkolInfo ctxt ty pprSigSkolInfo ctxt ty
= case ctxt of = case ctxt of
FunSigCtxt f _ -> pp_sig f FunSigCtxt f _ -> pp_sig f
PatSynCtxt {} -> pprUserTypeCtxt ctxt -- See Note [Skolem info for pattern synonyms]
_ -> vcat [ pprUserTypeCtxt ctxt <> colon _ -> vcat [ pprUserTypeCtxt ctxt <> colon
, nest 2 (ppr ty) ] , nest 2 (ppr ty) ]
where where
...@@ -2677,7 +2671,17 @@ pprPatSkolInfo (PatSynCon ps) ...@@ -2677,7 +2671,17 @@ pprPatSkolInfo (PatSynCon ps)
, nest 2 $ ppr ps <+> dcolon , nest 2 $ ppr ps <+> dcolon
<+> pprType (patSynType ps) <> comma ] <+> pprType (patSynType ps) <> comma ]
{- {- Note [Skolem info for pattern synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For pattern synonym SkolemInfo we have
SigSkol (PatSynCtxt p) ty
but the type 'ty' is not very helpful. The full pattern-synonym type
is has the provided and required pieces, which it is inconvenient to
record and display here. So we simply don't display the type at all,
contenting outselves with just the name of the pattern synonym, which
is fine. We could do more, but it doesn't seem worth it.
************************************************************************ ************************************************************************
* * * *
CtOrigin CtOrigin
......
...@@ -473,7 +473,7 @@ data UserTypeCtxt ...@@ -473,7 +473,7 @@ data UserTypeCtxt
| TypeAppCtxt -- Visible type application | TypeAppCtxt -- Visible type application
| ConArgCtxt Name -- Data constructor argument | ConArgCtxt Name -- Data constructor argument
| TySynCtxt Name -- RHS of a type synonym decl | TySynCtxt Name -- RHS of a type synonym decl
| PatSynBuilderCtxt Name -- Type sig for the builder of a bidirectional pattern synonym | PatSynCtxt Name -- Type sig for a pattern synonym
| PatSigCtxt -- Type sig in pattern | PatSigCtxt -- Type sig in pattern
-- eg f (x::t) = ... -- eg f (x::t) = ...
-- or (x::t, y) = e -- or (x::t, y) = e
...@@ -670,9 +670,7 @@ pprUserTypeCtxt GhciCtxt = text "a type in a GHCi command" ...@@ -670,9 +670,7 @@ pprUserTypeCtxt GhciCtxt = text "a type in a GHCi command"
pprUserTypeCtxt (ClassSCCtxt c) = text "the super-classes of class" <+> quotes (ppr c) pprUserTypeCtxt (ClassSCCtxt c) = text "the super-classes of class" <+> quotes (ppr c)
pprUserTypeCtxt SigmaCtxt = text "the context of a polymorphic type" pprUserTypeCtxt SigmaCtxt = text "the context of a polymorphic type"
pprUserTypeCtxt (DataTyCtxt tc) = text "the context of the data type declaration for" <+> quotes (ppr tc) pprUserTypeCtxt (DataTyCtxt tc) = text "the context of the data type declaration for" <+> quotes (ppr tc)
pprUserTypeCtxt (PatSynBuilderCtxt n) pprUserTypeCtxt (PatSynCtxt n) = text "the signature for pattern synonym" <+> quotes (ppr n)
= vcat [ text "the type signature for bidirectional pattern synonym" <+> quotes (ppr n)
, text "when used in an expression context" ]
pprSigCtxt :: UserTypeCtxt -> SDoc -> SDoc -> SDoc pprSigCtxt :: UserTypeCtxt -> SDoc -> SDoc -> SDoc
-- (pprSigCtxt ctxt <extra> <type>) -- (pprSigCtxt ctxt <extra> <type>)
...@@ -688,14 +686,12 @@ pprSigCtxt ctxt extra pp_ty ...@@ -688,14 +686,12 @@ pprSigCtxt ctxt extra pp_ty
= hang (text "In" <+> extra <+> pprUserTypeCtxt ctxt <> colon) = hang (text "In" <+> extra <+> pprUserTypeCtxt ctxt <> colon)
2 pp_ty 2 pp_ty
where
isSigMaybe :: UserTypeCtxt -> Maybe Name isSigMaybe :: UserTypeCtxt -> Maybe Name
isSigMaybe (FunSigCtxt n _) = Just n isSigMaybe (FunSigCtxt n _) = Just n
isSigMaybe (ConArgCtxt n) = Just n isSigMaybe (ConArgCtxt n) = Just n
isSigMaybe (ForSigCtxt n) = Just n isSigMaybe (ForSigCtxt n) = Just n
isSigMaybe (PatSynBuilderCtxt n) = Just n isSigMaybe (PatSynCtxt n) = Just n
isSigMaybe _ = Nothing isSigMaybe _ = Nothing
{- {-
************************************************************************ ************************************************************************
......
...@@ -451,9 +451,9 @@ forAllAllowed _ = False ...@@ -451,9 +451,9 @@ forAllAllowed _ = False
representationPolymorphismForbidden :: UserTypeCtxt -> Bool representationPolymorphismForbidden :: UserTypeCtxt -> Bool