diff options
Diffstat (limited to 'compiler/GHC/Tc/Gen/Splice.hs')
| -rw-r--r-- | compiler/GHC/Tc/Gen/Splice.hs | 60 |
1 files changed, 33 insertions, 27 deletions
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index 72fc259e83..b4d15ee4ab 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -323,7 +323,8 @@ tcTExpTy m_ty exp_ty ; return (mkTyConApp codeCon [rep, m_ty, exp_ty]) } where err_msg ty - = vcat [ text "Illegal polytype:" <+> ppr ty + = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ text "Illegal polytype:" <+> ppr ty , text "The type of a Typed Template Haskell expression must" <+> text "not have any quantification." ] @@ -1032,7 +1033,7 @@ runMeta' show_code ppr_hs run_and_convert expr -- see where this splice is do { mb_result <- run_and_convert expr_span hval ; case mb_result of - Left err -> failWithTc err + Left err -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints err) Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result) ; return $! result } } @@ -1050,7 +1051,7 @@ runMeta' show_code ppr_hs run_and_convert expr let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:", nest 2 (text exn_msg), if show_code then text "Code:" <+> ppr expr else empty] - failWithTc msg + failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg) {- Note [Running typed splices in the zonker] @@ -1166,8 +1167,9 @@ instance TH.Quasi TcM where -- 'msg' is forced to ensure exceptions don't escape, -- see Note [Exceptions in TH] - qReport True msg = seqList msg $ addErr (text msg) - qReport False msg = seqList msg $ addDiagnostic WarningWithoutFlag (text msg) + qReport True msg = seqList msg $ addErr $ TcRnUnknownMessage $ mkPlainError noHints (text msg) + qReport False msg = seqList msg $ addDiagnostic $ TcRnUnknownMessage $ + mkPlainDiagnostic WarningWithoutFlag noHints (text msg) qLocation = do { m <- getModule ; l <- getSrcSpanM @@ -1215,7 +1217,7 @@ instance TH.Quasi TcM where th_origin <- getThSpliceOrigin let either_hval = convertToHsDecls th_origin l thds ds <- case either_hval of - Left exn -> failWithTc $ + Left exn -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ hang (text "Error in a declaration passed to addTopDecls:") 2 exn Right ds -> return ds @@ -1233,7 +1235,8 @@ instance TH.Quasi TcM where checkTopDecl (ForD _ (ForeignImport { fd_name = L _ name })) = bindName name checkTopDecl _ - = addErr $ text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl" + = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl" bindName :: RdrName -> TcM () bindName (Exact n) @@ -1242,7 +1245,7 @@ instance TH.Quasi TcM where } bindName name = - addErr $ + addErr $ TcRnUnknownMessage $ mkPlainError noHints $ hang (text "The binder" <+> quotes (ppr name) <+> text "is not a NameU.") 2 (text "Probable cause: you used mkName instead of newName to generate a binding.") @@ -1268,8 +1271,8 @@ instance TH.Quasi TcM where 2 (text "Plugins in the current package can't be specified.") case r of - Found {} -> addErr err - FoundMultiple {} -> addErr err + Found {} -> addErr $ TcRnUnknownMessage $ mkPlainError noHints err + FoundMultiple {} -> addErr $ TcRnUnknownMessage $ mkPlainError noHints err _ -> return () th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv updTcRef th_coreplugins_var (plugin:) @@ -1294,7 +1297,7 @@ instance TH.Quasi TcM where th_doc_var <- tcg_th_docs <$> getGblEnv resolved_doc_loc <- resolve_loc doc_loc is_local <- checkLocalName resolved_doc_loc - unless is_local $ failWithTc $ text + unless is_local $ failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text "Can't add documentation to" <+> ppr_loc doc_loc <+> text "as it isn't inside the current module" updTcRef th_doc_var (Map.insert resolved_doc_loc s) @@ -1380,7 +1383,7 @@ lookupThInstName th_type = do Right (_, (inst:_)) -> return $ getName inst Right (_, []) -> noMatches where - noMatches = failWithTc $ + noMatches = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text "Couldn't find any instances of" <+> ppr_th th_type <+> text "to add documentation to" @@ -1417,7 +1420,7 @@ lookupThInstName th_type = do inst_cls_name TH.WildCardT = inst_cls_name_err inst_cls_name (TH.ImplicitParamT _ _) = inst_cls_name_err - inst_cls_name_err = failWithTc $ + inst_cls_name_err = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text "Couldn't work out what instance" <+> ppr_th th_type <+> text "is supposed to be" @@ -1707,15 +1710,16 @@ reifyInstances' th_nm th_tys ; let matches = lookupFamInstEnv inst_envs tc tys ; traceTc "reifyInstances'2" (ppr matches) ; return $ Right (tc, map fim_instance matches) } - _ -> bale_out (hang (text "reifyInstances:" <+> quotes (ppr ty)) - 2 (text "is not a class constraint or type family application")) } + _ -> bale_out $ TcRnUnknownMessage $ mkPlainError noHints $ + (hang (text "reifyInstances:" <+> quotes (ppr ty)) + 2 (text "is not a class constraint or type family application")) } where doc = ClassInstanceCtx bale_out msg = failWithTc msg cvt :: Origin -> SrcSpan -> TH.Type -> TcM (LHsType GhcPs) cvt origin loc th_ty = case convertToHsType origin loc th_ty of - Left msg -> failWithTc msg + Left msg -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg) Right ty -> return ty {- @@ -1808,17 +1812,18 @@ tcLookupTh name do { mb_thing <- tcLookupImported_maybe name ; case mb_thing of Succeeded thing -> return (AGlobal thing) - Failed msg -> failWithTc msg + Failed msg -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg) }}}} -notInScope :: TH.Name -> SDoc -notInScope th_name = quotes (text (TH.pprint th_name)) <+> - text "is not in scope at a reify" +notInScope :: TH.Name -> TcRnMessage +notInScope th_name = TcRnUnknownMessage $ mkPlainError noHints $ + quotes (text (TH.pprint th_name)) <+> + text "is not in scope at a reify" -- Ugh! Rather an indirect way to display the name -notInEnv :: Name -> SDoc -notInEnv name = quotes (ppr name) <+> - text "is not in the type environment at a reify" +notInEnv :: Name -> TcRnMessage +notInEnv name = TcRnUnknownMessage $ mkPlainError noHints $ + quotes (ppr name) <+> text "is not in the type environment at a reify" ------------------------------ reifyRoles :: TH.Name -> TcM [TH.Role] @@ -1826,7 +1831,7 @@ reifyRoles th_name = do { thing <- getThing th_name ; case thing of AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc)) - _ -> failWithTc (text "No roles associated with" <+> (ppr thing)) + _ -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints $ text "No roles associated with" <+> (ppr thing)) } where reify_role Nominal = TH.NominalR @@ -2620,9 +2625,10 @@ mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type mkThAppTs fun_ty arg_tys = foldl' TH.AppT fun_ty arg_tys noTH :: SDoc -> SDoc -> TcM a -noTH s d = failWithTc (hsep [text "Can't represent" <+> s <+> - text "in Template Haskell:", - nest 2 d]) +noTH s d = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (hsep [text "Can't represent" <+> s <+> + text "in Template Haskell:", + nest 2 d]) ppr_th :: TH.Ppr a => a -> SDoc ppr_th x = text (TH.pprint x) |