diff options
Diffstat (limited to 'compiler/GHC/Tc')
| -rw-r--r-- | compiler/GHC/Tc/Errors/Ppr.hs | 121 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Errors/Types.hs | 171 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Gen/Annotation.hs | 13 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Gen/App.hs | 23 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Gen/Arrow.hs | 6 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Gen/Bind.hs | 57 | ||||
| -rw-r--r-- | compiler/GHC/Tc/TyCl/Instance.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Types.hs-boot | 4 |
8 files changed, 319 insertions, 78 deletions
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index de04bedfe2..c629c5f5e4 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -11,9 +11,12 @@ import GHC.Prelude import GHC.Core.TyCo.Ppr (pprWithTYPE) import GHC.Core.Type +import GHC.Data.Bag import GHC.Tc.Errors.Types import GHC.Types.Error +import GHC.Types.Name (pprPrefixName) import GHC.Types.Name.Reader (pprNameProvenance) +import GHC.Types.SrcLoc (GenLocated(..)) import GHC.Types.Var.Env (emptyTidyEnv) import GHC.Driver.Flags import GHC.Hs @@ -95,6 +98,68 @@ instance Diagnostic TcRnMessage where -> mkSimpleDecorated $ vcat [ text "Illegal `..' notation for constructor" <+> quotes (ppr con) , nest 2 (text "The constructor has no labelled fields") ] + TcRnIgnoringAnnotations anns + -> mkSimpleDecorated $ + text "Ignoring ANN annotation" <> plural anns <> comma + <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi" + TcRnAnnotationInSafeHaskell + -> mkSimpleDecorated $ + vcat [ text "Annotations are not compatible with Safe Haskell." + , text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ] + TcRnInvalidTypeApplication fun_ty hs_ty + -> mkSimpleDecorated $ + text "Cannot apply expression of type" <+> quotes (ppr fun_ty) $$ + text "to a visible type argument" <+> quotes (ppr hs_ty) + TcRnTagToEnumMissingValArg + -> mkSimpleDecorated $ + text "tagToEnum# must appear applied to one value argument" + TcRnTagToEnumUnspecifiedResTy ty + -> mkSimpleDecorated $ + hang (text "Bad call to tagToEnum# at type" <+> ppr ty) + 2 (vcat [ text "Specify the type by giving a type signature" + , text "e.g. (tagToEnum# x) :: Bool" ]) + TcRnTagToEnumResTyNotAnEnum ty + -> mkSimpleDecorated $ + hang (text "Bad call to tagToEnum# at type" <+> ppr ty) + 2 (text "Result type must be an enumeration type") + TcRnArrowIfThenElsePredDependsOnResultTy + -> mkSimpleDecorated $ + text "Predicate type of `ifThenElse' depends on result type" + TcRnArrowCommandExpected cmd + -> mkSimpleDecorated $ + vcat [text "The expression", nest 2 (ppr cmd), + text "was found where an arrow command was expected"] + TcRnIllegalHsBootFileDecl + -> mkSimpleDecorated $ + text "Illegal declarations in an hs-boot file" + TcRnRecursivePatternSynonym binds + -> mkSimpleDecorated $ + hang (text "Recursive pattern synonym definition with following bindings:") + 2 (vcat $ map pprLBind . bagToList $ binds) + where + pprLoc loc = parens (text "defined at" <+> ppr loc) + pprLBind :: GenLocated (SrcSpanAnn' a) (HsBindLR GhcRn idR) -> SDoc + pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders CollNoDictBinders bind) + <+> pprLoc (locA loc) + TcRnPartialTypeSigTyVarMismatch n1 n2 fn_name hs_ty + -> mkSimpleDecorated $ + hang (text "Couldn't match" <+> quotes (ppr n1) + <+> text "with" <+> quotes (ppr n2)) + 2 (hang (text "both bound by the partial type signature:") + 2 (ppr fn_name <+> dcolon <+> ppr hs_ty)) + TcRnPartialTypeSigBadQuantifier n fn_name hs_ty + -> mkSimpleDecorated $ + hang (text "Can't quantify over" <+> quotes (ppr n)) + 2 (hang (text "bound by the partial type signature:") + 2 (ppr fn_name <+> dcolon <+> ppr hs_ty)) + TcRnPolymorphicBinderMissingSig n ty + -> mkSimpleDecorated $ + sep [ text "Polymorphic local binding with no type signature:" + , nest 2 $ pprPrefixName n <+> dcolon <+> ppr ty ] + TcRnOverloadedSig sig + -> mkSimpleDecorated $ + hang (text "Overloaded signature conflicts with monomorphism restriction") + 2 (ppr sig) diagnosticReason = \case TcRnUnknownMessage m @@ -142,6 +207,34 @@ instance Diagnostic TcRnMessage where -> ErrorWithoutFlag TcRnIllegalWildcardsInConstructor{} -> ErrorWithoutFlag + TcRnIgnoringAnnotations{} + -> WarningWithoutFlag + TcRnAnnotationInSafeHaskell + -> ErrorWithoutFlag + TcRnInvalidTypeApplication{} + -> ErrorWithoutFlag + TcRnTagToEnumMissingValArg + -> ErrorWithoutFlag + TcRnTagToEnumUnspecifiedResTy{} + -> ErrorWithoutFlag + TcRnTagToEnumResTyNotAnEnum{} + -> ErrorWithoutFlag + TcRnArrowIfThenElsePredDependsOnResultTy + -> ErrorWithoutFlag + TcRnArrowCommandExpected{} + -> ErrorWithoutFlag + TcRnIllegalHsBootFileDecl + -> ErrorWithoutFlag + TcRnRecursivePatternSynonym{} + -> ErrorWithoutFlag + TcRnPartialTypeSigTyVarMismatch{} + -> ErrorWithoutFlag + TcRnPartialTypeSigBadQuantifier{} + -> ErrorWithoutFlag + TcRnPolymorphicBinderMissingSig{} + -> WarningWithFlag Opt_WarnMissingLocalSignatures + TcRnOverloadedSig{} + -> ErrorWithoutFlag diagnosticHints = \case TcRnUnknownMessage m @@ -189,6 +282,34 @@ instance Diagnostic TcRnMessage where -> noHints TcRnIllegalWildcardsInConstructor{} -> noHints + TcRnIgnoringAnnotations{} + -> noHints + TcRnAnnotationInSafeHaskell + -> noHints + TcRnInvalidTypeApplication{} + -> noHints + TcRnTagToEnumMissingValArg + -> noHints + TcRnTagToEnumUnspecifiedResTy{} + -> noHints + TcRnTagToEnumResTyNotAnEnum{} + -> noHints + TcRnArrowIfThenElsePredDependsOnResultTy + -> noHints + TcRnArrowCommandExpected{} + -> noHints + TcRnIllegalHsBootFileDecl + -> noHints + TcRnRecursivePatternSynonym{} + -> noHints + TcRnPartialTypeSigTyVarMismatch{} + -> noHints + TcRnPartialTypeSigBadQuantifier{} + -> noHints + TcRnPolymorphicBinderMissingSig{} + -> noHints + TcRnOverloadedSig{} + -> noHints messageWithInfoDiagnosticMessage :: UnitState -> ErrInfo diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index a82ac7328f..282fccd1d6 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -1,5 +1,4 @@ {-# LANGUAGE GADTs #-} -{-# LANGUAGE FlexibleContexts #-} module GHC.Tc.Errors.Types ( -- * Main types TcRnMessage(..) @@ -13,6 +12,7 @@ module GHC.Tc.Errors.Types ( import GHC.Prelude import GHC.Hs +import {-# SOURCE #-} GHC.Tc.Types (TcIdSigInfo) import GHC.Tc.Types.Constraint import GHC.Types.Error import GHC.Types.Name (Name, OccName) @@ -165,10 +165,14 @@ data TcRnMessage where with a plugin, the TcRnUnsafeDueToPlugin warning (controlled by -Wunsafe) is used as the reason the module was inferred to be unsafe. This warning is not raised if the -fplugin-trustworthy flag is passed. + + Test cases: plugins/T19926 -} TcRnUnsafeDueToPlugin :: TcRnMessage {-| TcRnModMissingRealSrcSpan is an error that occurrs when compiling a module that lacks an associated 'RealSrcSpan'. + + Test cases: None -} TcRnModMissingRealSrcSpan :: Module -> TcRnMessage @@ -321,6 +325,171 @@ data TcRnMessage where -} TcRnIllegalWildcardsInConstructor :: !Name -> TcRnMessage + {-| TcRnIgnoringAnnotations is a warning that occurs when the source code + contains annotation pragmas but the platform in use does not support an + external interpreter such as GHCi and therefore the annotations are ignored. + + Example(s): None + + Test cases: None + -} + TcRnIgnoringAnnotations :: [LAnnDecl GhcRn] -> TcRnMessage + + {-| TcRnAnnotationInSafeHaskell is an error that occurs if annotation pragmas + are used in conjunction with Safe Haskell. + + Example(s): None + + Test cases: annotations/should_fail/T10826 + -} + TcRnAnnotationInSafeHaskell :: TcRnMessage + + {-| TcRnInvalidTypeApplication is an error that occurs when a visible type application + is used with an expression that does not accept "specified" type arguments. + + Example(s): + foo :: forall {a}. a -> a + foo x = x + bar :: () + bar = let x = foo @Int 42 + in () + + Test cases: overloadedrecflds/should_fail/overloadedlabelsfail03 + typecheck/should_fail/ExplicitSpecificity1 + typecheck/should_fail/ExplicitSpecificity10 + typecheck/should_fail/ExplicitSpecificity2 + typecheck/should_fail/T17173 + typecheck/should_fail/VtaFail + -} + TcRnInvalidTypeApplication :: Type -> LHsWcType GhcRn -> TcRnMessage + + {-| TcRnTagToEnumMissingValArg is an error that occurs when the 'tagToEnum#' + function is not applied to a single value argument. + + Example(s): + tagToEnum# 1 2 + + Test cases: None + -} + TcRnTagToEnumMissingValArg :: TcRnMessage + + {-| TcRnTagToEnumUnspecifiedResTy is an error that occurs when the 'tagToEnum#' + function is not given a concrete result type. + + Example(s): + foo :: forall a. a + foo = tagToEnum# 0# + + Test cases: typecheck/should_fail/tcfail164 + -} + TcRnTagToEnumUnspecifiedResTy :: Type -> TcRnMessage + + {-| TcRnTagToEnumResTyNotAnEnum is an error that occurs when the 'tagToEnum#' + function is given a result type that is not an enumeration type. + + Example(s): + foo :: Int -- not an enumeration TyCon + foo = tagToEnum# 0# + + Test cases: typecheck/should_fail/tcfail164 + -} + TcRnTagToEnumResTyNotAnEnum :: Type -> TcRnMessage + + {-| TcRnArrowIfThenElsePredDependsOnResultTy is an error that occurs when the + predicate type of an ifThenElse expression in arrow notation depends on + the type of the result. + + Example(s): None + + Test cases: None + -} + TcRnArrowIfThenElsePredDependsOnResultTy :: TcRnMessage + + {-| TcRnArrowCommandExpected is an error that occurs if a non-arrow command + is used where an arrow command is expected. + + Example(s): None + + Test cases: None + -} + TcRnArrowCommandExpected :: HsCmd GhcRn -> TcRnMessage + + {-| TcRnIllegalHsBootFileDecl is an error that occurs when an hs-boot file + contains declarations that are not allowed, such as bindings. + + Example(s): None + + Test cases: None + -} + TcRnIllegalHsBootFileDecl :: TcRnMessage + + {-| TcRnRecursivePatternSynonym is an error that occurs when a pattern synonym + is defined in terms of itself, either directly or indirectly. + + Example(s): + pattern A = B + pattern B = A + + Test cases: patsyn/should_fail/T16900 + -} + TcRnRecursivePatternSynonym :: LHsBinds GhcRn -> TcRnMessage + + {-| TcRnPartialTypeSigTyVarMismatch is an error that occurs when a partial type signature + attempts to unify two different types. + + Example(s): + f :: a -> b -> _ + f x y = [x, y] + + Test cases: partial-sigs/should_fail/T14449 + -} + TcRnPartialTypeSigTyVarMismatch + :: Name -- ^ first type variable + -> Name -- ^ second type variable + -> Name -- ^ function name + -> LHsSigWcType GhcRn -> TcRnMessage + + {-| TcRnPartialTypeSigBadQuantifier is an error that occurs when a type variable + being quantified over in the partial type signature of a function gets unified + with a type that is free in that function's context. + + Example(s): + foo :: Num a => a -> a + foo xxx = g xxx + where + g :: forall b. Num b => _ -> b + g y = xxx + y + + Test cases: partial-sig/should_fail/T14479 + -} + TcRnPartialTypeSigBadQuantifier + :: Name -- ^ type variable being quantified + -> Name -- ^ function name + -> LHsSigWcType GhcRn -> TcRnMessage + + {-| TcRnPolymorphicBinderMissingSig is a warning controlled by -Wmissing-local-signatures + that occurs when a local polymorphic binding lacks a type signature. + + Example(s): + id a = a + + Test cases: warnings/should_compile/T12574 + -} + TcRnPolymorphicBinderMissingSig :: Name -> Type -> TcRnMessage + + {-| TcRnOverloadedSig is an error that occurs when a binding group conflicts + with the monomorphism restriction. + + Example(s): + data T a = T a + mono = ... where + x :: Applicative f => f a + T x = ... + + Test cases: typecheck/should_compile/T11339 + -} + TcRnOverloadedSig :: TcIdSigInfo -> TcRnMessage + -- | Which parts of a record field are affected by a particular error or warning. data RecordFieldPart = RecordFieldConstructor !Name diff --git a/compiler/GHC/Tc/Gen/Annotation.hs b/compiler/GHC/Tc/Gen/Annotation.hs index fa4e96dbc3..61c4e192b0 100644 --- a/compiler/GHC/Tc/Gen/Annotation.hs +++ b/compiler/GHC/Tc/Gen/Annotation.hs @@ -28,7 +28,6 @@ import GHC.Utils.Outputable import GHC.Types.Name import GHC.Types.Annotations import GHC.Types.SrcLoc -import GHC.Types.Error import Control.Monad ( when ) @@ -45,10 +44,7 @@ warnAnns :: [LAnnDecl GhcRn] -> TcM [Annotation] --- No GHCI; emit a warning (not an error) and ignore. cf #4268 warnAnns [] = return [] warnAnns anns@(L loc _ : _) - = do { let msg = TcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints $ - (text "Ignoring ANN annotation" <> plural anns <> comma - <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi") - ; setSrcSpanA loc $ addDiagnosticTc msg + = do { setSrcSpanA loc $ addDiagnosticTc (TcRnIgnoringAnnotations anns) ; return [] } tcAnnotation :: LAnnDecl GhcRn -> TcM Annotation @@ -61,13 +57,8 @@ tcAnnotation (L loc ann@(HsAnnotation _ _ provenance expr)) = do setSrcSpanA loc $ addErrCtxt (annCtxt ann) $ do -- See #10826 -- Annotations allow one to bypass Safe Haskell. dflags <- getDynFlags - when (safeLanguageOn dflags) $ failWithTc safeHsErr + when (safeLanguageOn dflags) $ failWithTc TcRnAnnotationInSafeHaskell runAnnotation target expr - where - safeHsErr :: TcRnMessage - safeHsErr = TcRnUnknownMessage $ mkPlainError noHints $ - vcat [ text "Annotations are not compatible with Safe Haskell." - , text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ] annProvenanceToTarget :: Module -> AnnProvenance GhcRn -> AnnTarget Name diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs index 326af87c69..cc0814cced 100644 --- a/compiler/GHC/Tc/Gen/App.hs +++ b/compiler/GHC/Tc/Gen/App.hs @@ -40,7 +40,6 @@ import GHC.Core.TyCo.Subst (substTyWithInScope) import GHC.Core.TyCo.FVs( shallowTyCoVarsOfType ) import GHC.Core.Type import GHC.Tc.Types.Evidence -import GHC.Types.Error import GHC.Types.Var.Set import GHC.Builtin.PrimOps( tagToEnumKey ) import GHC.Builtin.Names @@ -695,9 +694,7 @@ tcVTA fun_ty hs_ty | otherwise = do { (_, fun_ty) <- zonkTidyTcType emptyTidyEnv fun_ty - ; failWith $ TcRnUnknownMessage $ mkPlainError noHints $ - text "Cannot apply expression of type" <+> quotes (ppr fun_ty) $$ - text "to a visible type argument" <+> quotes (ppr hs_ty) } + ; failWith $ TcRnInvalidTypeApplication fun_ty hs_ty } {- Note [Required quantifiers in the type of a term] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1157,7 +1154,7 @@ tcTagToEnum tc_fun fun_ctxt tc_args res_ty -- Check that the type is algebraic ; case tcSplitTyConApp_maybe res_ty of { - Nothing -> do { addErrTc (mk_error res_ty doc1) + Nothing -> do { addErrTc (TcRnTagToEnumUnspecifiedResTy res_ty) ; vanilla_result } ; Just (tc, tc_args) -> @@ -1177,26 +1174,14 @@ tcTagToEnum tc_fun fun_ctxt tc_args res_ty ; return (mkHsWrap df_wrap tc_expr) }}}}} | otherwise - = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ - (text "tagToEnum# must appear applied to one value argument") + = failWithTc TcRnTagToEnumMissingValArg where vanilla_result = return (rebuildHsApps tc_fun fun_ctxt tc_args) check_enumeration ty' tc | isEnumerationTyCon tc = return () - | otherwise = addErrTc (mk_error ty' doc2) - - doc1 = vcat [ text "Specify the type by giving a type signature" - , text "e.g. (tagToEnum# x) :: Bool" ] - doc2 = text "Result type must be an enumeration type" - - mk_error :: TcType -> SDoc -> TcRnMessage - mk_error ty what - = TcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Bad call to tagToEnum#" - <+> text "at type" <+> ppr ty) - 2 what + | otherwise = addErrTc (TcRnTagToEnumResTyNotAnEnum ty') {- ********************************************************************* diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs index e898b74be5..4caa73e625 100644 --- a/compiler/GHC/Tc/Gen/Arrow.hs +++ b/compiler/GHC/Tc/Gen/Arrow.hs @@ -184,7 +184,7 @@ tc_cmd env (HsCmdIf x fun@(SyntaxExprRn {}) pred b1 b2) res_ty -- Rebindable syn ; (_, [r_tv]) <- tcInstSkolTyVars [alphaTyVar] ; let r_ty = mkTyVarTy r_tv ; checkTc (not (r_tv `elemVarSet` tyCoVarsOfType pred_ty)) - (TcRnUnknownMessage $ mkPlainError noHints $ text "Predicate type of `ifThenElse' depends on result type") + TcRnArrowIfThenElsePredDependsOnResultTy ; (pred', fun') <- tcSyntaxOp IfThenElseOrigin fun (map synKnownType [pred_ty, r_ty, r_ty]) (mkCheckExpType r_ty) $ \ _ _ -> @@ -338,9 +338,7 @@ tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty) -- This is where expressions that aren't commands get rejected tc_cmd _ cmd _ - = failWithTc (TcRnUnknownMessage $ mkPlainError noHints $ - vcat [text "The expression", nest 2 (ppr cmd), - text "was found where an arrow command was expected"]) + = failWithTc (TcRnArrowCommandExpected cmd) -- | Typechecking for case command alternatives. Used for both -- 'HsCmdCase' and 'HsCmdLamCase'. diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs index 01dcd48952..368248dc28 100644 --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -18,7 +18,6 @@ module GHC.Tc.Gen.Bind , tcHsBootSigs , tcPolyCheck , chooseInferredQuantifiers - , badBootDeclErr ) where @@ -224,7 +223,7 @@ tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id] -- A hs-boot file has only one BindGroup, and it only has type -- signatures in it. The renamer checked all this tcHsBootSigs binds sigs - = do { checkTc (null binds) badBootDeclErr + = do { checkTc (null binds) TcRnIllegalHsBootFileDecl ; concatMapM (addLocMA tc_boot_sig) (filter isTypeLSig sigs) } where tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames @@ -235,10 +234,6 @@ tcHsBootSigs binds sigs -- Notice that we make GlobalIds, not LocalIds tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) -badBootDeclErr :: TcRnMessage -badBootDeclErr = TcRnUnknownMessage $ mkPlainError noHints $ - text "Illegal declarations in an hs-boot file" - ------------------------ tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing -> TcM (HsLocalBinds GhcTc, thing) @@ -432,20 +427,13 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside tc_sub_group rec_tc binds = tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds -recursivePatSynErr :: - (OutputableBndrId p, CollectPass (GhcPass p)) - => SrcSpan -- ^ The location of the first pattern synonym binding +recursivePatSynErr + :: SrcSpan -- ^ The location of the first pattern synonym binding -- (for error reporting) - -> LHsBinds (GhcPass p) + -> LHsBinds GhcRn -> TcM a recursivePatSynErr loc binds - = failAt loc $ TcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Recursive pattern synonym definition with following bindings:") - 2 (vcat $ map pprLBind . bagToList $ binds) - where - pprLoc loc = parens (text "defined at" <+> ppr loc) - pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders CollNoDictBinders bind) - <+> pprLoc (locA loc) + = failAt loc $ TcRnRecursivePatternSynonym binds tc_single :: forall thing. TopLevelFlag -> TcSigFun -> TcPragEnv @@ -802,7 +790,7 @@ mkExport prag_fn insoluble qtvs theta else addErrCtxtM (mk_impedance_match_msg mono_info sel_poly_ty poly_ty) $ tcSubTypeSigma sig_ctxt sel_poly_ty poly_ty - ; localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig + ; localSigWarn poly_id mb_sig ; return (ABE { abe_ext = noExtField , abe_wrap = wrap @@ -912,21 +900,13 @@ chooseInferredQuantifiers inferred_theta tau_tvs qtvs where report_dup_tyvar_tv_err (n1,n2) | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig - = addErrTc (TcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Couldn't match" <+> quotes (ppr n1) - <+> text "with" <+> quotes (ppr n2)) - 2 (hang (text "both bound by the partial type signature:") - 2 (ppr fn_name <+> dcolon <+> ppr hs_ty))) - + = addErrTc (TcRnPartialTypeSigTyVarMismatch n1 n2 fn_name hs_ty) | otherwise -- Can't happen; by now we know it's a partial sig = pprPanic "report_tyvar_tv_err" (ppr sig) report_mono_sig_tv_err n | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig - = addErrTc (TcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Can't quantify over" <+> quotes (ppr n)) - 2 (hang (text "bound by the partial type signature:") - 2 (ppr fn_name <+> dcolon <+> ppr hs_ty))) + = addErrTc (TcRnPartialTypeSigBadQuantifier n fn_name hs_ty) | otherwise -- Can't happen; by now we know it's a partial sig = pprPanic "report_mono_sig_tv_err" (ppr sig) @@ -1004,23 +984,18 @@ mk_inf_msg poly_name poly_ty tidy_env -- | Warn the user about polymorphic local binders that lack type signatures. -localSigWarn :: WarningFlag -> Id -> Maybe TcIdSigInst -> TcM () -localSigWarn flag id mb_sig +localSigWarn :: Id -> Maybe TcIdSigInst -> TcM () +localSigWarn id mb_sig | Just _ <- mb_sig = return () | not (isSigmaTy (idType id)) = return () - | otherwise = warnMissingSignatures flag msg id - where - msg = text "Polymorphic local binding with no type signature:" + | otherwise = warnMissingSignatures id -warnMissingSignatures :: WarningFlag -> SDoc -> Id -> TcM () -warnMissingSignatures flag msg id +warnMissingSignatures :: Id -> TcM () +warnMissingSignatures id = do { env0 <- tcInitTidyEnv ; let (env1, tidy_ty) = tidyOpenType env0 (idType id) - ; let dia = TcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag flag) noHints (mk_msg tidy_ty) + ; let dia = TcRnPolymorphicBinderMissingSig (idName id) tidy_ty ; addDiagnosticTcM (env1, dia) } - where - mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ] checkOverloadedSig :: Bool -> TcIdSigInst -> TcM () -- Example: @@ -1034,9 +1009,7 @@ checkOverloadedSig monomorphism_restriction_applies sig , monomorphism_restriction_applies , let orig_sig = sig_inst_sig sig = setSrcSpan (sig_loc orig_sig) $ - failWith $ TcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Overloaded signature conflicts with monomorphism restriction") - 2 (ppr orig_sig) + failWith $ TcRnOverloadedSig orig_sig | otherwise = return () diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs index 5f56c3c830..609ef55837 100644 --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -553,7 +553,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds -- In hs-boot files there should be no bindings ; let no_binds = isEmptyLHsBinds binds && null uprags ; is_boot <- tcIsHsBootOrSig - ; failIfTc (is_boot && not no_binds) badBootDeclErr + ; failIfTc (is_boot && not no_binds) TcRnIllegalHsBootFileDecl ; return ( [inst_info], all_insts, deriv_infos ) } where diff --git a/compiler/GHC/Tc/Types.hs-boot b/compiler/GHC/Tc/Types.hs-boot index 8b8feac31e..c6302adb57 100644 --- a/compiler/GHC/Tc/Types.hs-boot +++ b/compiler/GHC/Tc/Types.hs-boot @@ -2,9 +2,13 @@ module GHC.Tc.Types where import GHC.Tc.Utils.TcType import GHC.Types.SrcLoc +import GHC.Utils.Outputable data TcLclEnv +data TcIdSigInfo +instance Outputable TcIdSigInfo + setLclEnvTcLevel :: TcLclEnv -> TcLevel -> TcLclEnv getLclEnvTcLevel :: TcLclEnv -> TcLevel |