summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/hsSyn/Convert.lhs3
-rw-r--r--compiler/hsSyn/HsBinds.lhs17
-rw-r--r--compiler/rename/RnEnv.lhs4
-rw-r--r--compiler/typecheck/TcSplice.lhs25
-rw-r--r--compiler/typecheck/TcTyClsDecls.lhs26
5 files changed, 39 insertions, 36 deletions
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index ef17c60299..aa141fa0f3 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -861,7 +861,8 @@ cvtTypeKind ty_str ty
LitT lit
-> returnL (HsTyLit (cvtTyLit lit))
- PromotedT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }
+ PromotedT nm -> do { nm' <- cName nm; mk_apps (HsTyVar nm') tys' }
+ -- Promoted data constructor; hence cName
PromotedTupleT n
| n == 1
diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index f756578e2d..3fd7efc538 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -368,16 +368,13 @@ ppr_monobind (FunBind { fun_id = fun, fun_infix = inf,
ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
, abs_exports = exports, abs_binds = val_binds
, abs_ev_binds = ev_binds })
- = sep [ptext (sLit "AbsBinds"),
- brackets (interpp'SP tyvars),
- brackets (interpp'SP dictvars),
- brackets (sep (punctuate comma (map ppr exports)))]
- $$
- nest 2 ( vcat [pprBndr LetBind (abe_poly ex) | ex <- exports]
- -- Print type signatures
- $$ pprLHsBinds val_binds )
- $$
- ifPprDebug (ppr ev_binds)
+ = hang (ptext (sLit "AbsBinds") <+> brackets (interpp'SP tyvars)
+ <+> brackets (interpp'SP dictvars))
+ 2 $ braces $ vcat
+ [ ptext (sLit "Exports:") <+> brackets (sep (punctuate comma (map ppr exports)))
+ , ptext (sLit "Exported types:") <+> vcat [pprBndr LetBind (abe_poly ex) | ex <- exports]
+ , ptext (sLit "Binds:") <+> pprLHsBinds val_binds
+ , ifPprDebug (ptext (sLit "Evidence:") <+> ppr ev_binds) ]
instance (OutputableBndr id) => Outputable (ABExport id) where
ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index 2f1de923c2..798381b117 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -258,8 +258,8 @@ lookupExactOcc name
where
exact_nm_err = hang (ptext (sLit "The exact Name") <+> quotes (ppr name) <+> ptext (sLit "is not in scope"))
- 2 (vcat [ ptext (sLit "Probable cause: you used a unique name (NameU), perhaps via newName,")
- , ptext (sLit "in Template Haskell, but did not bind it")
+ 2 (vcat [ ptext (sLit "Probable cause: you used a unique Template Haskell name (NameU), ")
+ , ptext (sLit "perhaps via newName, but did not bind it")
, ptext (sLit "If that's it, then -ddump-splices might be useful") ])
-----------------------------------------------
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 7b55ca3b12..0072794e10 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -470,11 +470,9 @@ tcTopSplice expr res_ty
; expr2 <- runMetaE zonked_q_expr
; showSplice "expression" expr (ppr expr2)
- -- Rename it, but bale out if there are errors
- -- otherwise the type checker just gives more spurious errors
; addErrCtxt (spliceResultDoc expr) $ do
- { (exp3, _fvs) <- checkNoErrs (rnLExpr expr2)
-
+ { (exp3, _fvs) <- checkNoErrs $ rnLExpr expr2
+ -- checkNoErrs: see Note [Renamer errors]
; exp4 <- tcMonoExpr exp3 res_ty
; return (unLoc exp4) } }
@@ -509,6 +507,13 @@ tcTopSpliceExpr tc_action
; zonkTopLExpr (mkHsDictLet (EvBinds const_binds) expr') }
\end{code}
+Note [Renamer errors]
+~~~~~~~~~~~~~~~~~~~~~
+It's important to wrap renamer calls in checkNoErrs, because the
+renamer does not fail for out of scope variables etc. Instead it
+returns a bogus term/type, so that it can report more than one error.
+We don't want the type checker to see these bogus unbound variables.
+
%************************************************************************
%* *
@@ -559,11 +564,10 @@ tcTopSpliceType expr
; hs_ty2 <- runMetaT zonked_q_expr
; showSplice "type" expr (ppr hs_ty2)
- -- Rename it, but bale out if there are errors
- -- otherwise the type checker just gives more spurious errors
; addErrCtxt (spliceResultDoc expr) $ do
{ let doc = SpliceTypeCtx hs_ty2
- ; (hs_ty3, _fvs) <- checkNoErrs (rnLHsType doc hs_ty2)
+ ; (hs_ty3, _fvs) <- checkNoErrs $ rnLHsType doc hs_ty2
+ -- checkNoErrs: see Note [Renamer errors]
; tcLHsType hs_ty3 }}
\end{code}
@@ -997,7 +1001,7 @@ illegalBracket = ptext (sLit "Template Haskell brackets cannot be nested (withou
\begin{code}
reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec]
reifyInstances th_nm th_tys
- = addErrCtxt (ptext (sLit "In reifyInstances")
+ = addErrCtxt (ptext (sLit "In the argument of reifyInstances:")
<+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $
do { thing <- getThing th_nm
; case thing of
@@ -1026,8 +1030,9 @@ reifyInstances th_nm th_tys
<+> int tc_arity <> rparen))
; loc <- getSrcSpanM
; rdr_tys <- mapM (cvt loc) th_tys -- Convert to HsType RdrName
- ; (rn_tys, _fvs) <- rnLHsTypes doc rdr_tys -- Rename to HsType Name
- ; (tys, _res_k) <- tcInferApps tc (tyConKind tc) rn_tys
+ ; (rn_tys, _fvs) <- checkNoErrs $ rnLHsTypes doc rdr_tys -- Rename to HsType Name
+ -- checkNoErrs: see Note [Renamer errors]
+ ; (tys, _res_k) <- tcInferApps tc (tyConKind tc) rn_tys
; return tys }
cvt :: SrcSpan -> TH.Type -> TcM (LHsType RdrName)
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 114140c8d1..3db2423999 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -1518,11 +1518,11 @@ mkRecSelBinds tycons
mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name)
mkRecSelBind (tycon, sel_name)
- = (L sel_loc (IdSig sel_id), unitBag (L sel_loc sel_bind))
+ = (L loc (IdSig sel_id), unitBag (L loc sel_bind))
where
- sel_loc = getSrcSpan tycon
- sel_id = Var.mkExportedLocalVar rec_details sel_name
- sel_ty vanillaIdInfo
+ loc = getSrcSpan sel_name
+ sel_id = Var.mkExportedLocalVar rec_details sel_name
+ sel_ty vanillaIdInfo
rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty }
-- Find a representative constructor, con1
@@ -1549,23 +1549,23 @@ mkRecSelBind (tycon, sel_name)
-- where cons_w_field = [C2,C7]
sel_bind | is_naughty = mkTopFunBind sel_lname [mkSimpleMatch [] unit_rhs]
| otherwise = mkTopFunBind sel_lname (map mk_match cons_w_field ++ deflt)
- mk_match con = mkSimpleMatch [noLoc (mk_sel_pat con)]
- (noLoc (HsVar field_var))
- mk_sel_pat con = ConPatIn (noLoc (getName con)) (RecCon rec_fields)
+ mk_match con = mkSimpleMatch [L loc (mk_sel_pat con)]
+ (L loc (HsVar field_var))
+ mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields)
rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }
rec_field = HsRecField { hsRecFieldId = sel_lname
- , hsRecFieldArg = nlVarPat field_var
+ , hsRecFieldArg = L loc (VarPat field_var)
, hsRecPun = False }
- sel_lname = L sel_loc sel_name
- field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) sel_loc
+ sel_lname = L loc sel_name
+ field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc
-- Add catch-all default case unless the case is exhaustive
-- We do this explicitly so that we get a nice error message that
-- mentions this particular record selector
deflt | not (any is_unused all_cons) = []
- | otherwise = [mkSimpleMatch [nlWildPat]
- (nlHsApp (nlHsVar (getName rEC_SEL_ERROR_ID))
- (nlHsLit msg_lit))]
+ | otherwise = [mkSimpleMatch [L loc (WildPat placeHolderType)]
+ (mkHsApp (L loc (HsVar (getName rEC_SEL_ERROR_ID)))
+ (L loc (HsLit msg_lit)))]
-- Do not add a default case unless there are unmatched
-- constructors. We must take account of GADTs, else we
View Lorry Controller Status