diff options
| -rw-r--r-- | compiler/GHC/Tc/Errors/Ppr.hs | 117 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Errors/Types.hs | 142 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Gen/Expr.hs | 114 |
3 files changed, 266 insertions, 107 deletions
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index 841f0aa713..6975eeb9d3 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -19,13 +19,13 @@ import GHC.Core.Type import GHC.Data.Bag import GHC.Tc.Errors.Types import GHC.Tc.Types.Rank (Rank(..)) -import GHC.Tc.Utils.TcType (tcSplitForAllTyVars) +import GHC.Tc.Utils.TcType (TcType, tcSplitForAllTyVars) import GHC.Types.Error -import GHC.Types.FieldLabel (flIsOverloaded, flSelector) +import GHC.Types.FieldLabel (FieldLabelString, flIsOverloaded, flSelector) import GHC.Types.Id (isRecordSelector) import GHC.Types.Name import GHC.Types.Name.Reader (GreName(..), pprNameProvenance) -import GHC.Types.SrcLoc (GenLocated(..)) +import GHC.Types.SrcLoc (GenLocated(..), unLoc) import GHC.Types.TyThing import GHC.Types.Var.Env (emptyTidyEnv) import GHC.Types.Var.Set (pprVarSet, pluralVarSet) @@ -398,6 +398,79 @@ instance Diagnostic TcRnMessage where ppr_name (FieldGreName fl) | flIsOverloaded fl = ppr fl | otherwise = ppr (flSelector fl) ppr_name (NormalGreName name) = ppr name + TcRnAmbiguousField rupd parent_type + -> mkSimpleDecorated $ + vcat [ text "The record update" <+> ppr rupd + <+> text "with type" <+> ppr parent_type + <+> text "is ambiguous." + , text "This will not be supported by -XDuplicateRecordFields in future releases of GHC." + ] + TcRnMissingFields con fields + -> mkSimpleDecorated $ vcat [header, nest 2 rest] + where + rest | null fields = empty + | otherwise = vcat (fmap pprField fields) + header = text "Fields of" <+> quotes (ppr con) <+> + text "not initialised" <> + if null fields then empty else colon + TcRnFieldUpdateInvalidType prs + -> mkSimpleDecorated $ + hang (text "Record update for insufficiently polymorphic field" + <> plural prs <> colon) + 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ]) + TcRnNoConstructorHasAllFields conflictingFields + -> mkSimpleDecorated $ + hang (text "No constructor has all these fields:") + 2 (pprQuotedList conflictingFields) + TcRnMixedSelectors data_name data_sels pat_name pat_syn_sels + -> mkSimpleDecorated $ + text "Cannot use a mixture of pattern synonym and record selectors" $$ + text "Record selectors defined by" + <+> quotes (ppr data_name) + <> colon + <+> pprWithCommas ppr data_sels $$ + text "Pattern synonym selectors defined by" + <+> quotes (ppr pat_name) + <> colon + <+> pprWithCommas ppr pat_syn_sels + TcRnMissingStrictFields con fields + -> mkSimpleDecorated $ vcat [header, nest 2 rest] + where + rest | null fields = empty -- Happens for non-record constructors + -- with strict fields + | otherwise = vcat (fmap pprField fields) + + header = text "Constructor" <+> quotes (ppr con) <+> + text "does not have the required strict field(s)" <> + if null fields then empty else colon + TcRnNoPossibleParentForFields rbinds + -> mkSimpleDecorated $ + hang (text "No type has all these fields:") + 2 (pprQuotedList fields) + where fields = map (hfbLHS . unLoc) rbinds + TcRnBadOverloadedRecordUpdate _rbinds + -> mkSimpleDecorated $ + text "Record update is ambiguous, and requires a type signature" + TcRnStaticFormNotClosed name reason + -> mkSimpleDecorated $ + quotes (ppr name) + <+> text "is used in a static form but it is not closed" + <+> text "because it" + $$ sep (causes reason) + where + causes :: NotClosedReason -> [SDoc] + causes NotLetBoundReason = [text "is not let-bound."] + causes (NotTypeClosed vs) = + [ text "has a non-closed type because it contains the" + , text "type variables:" <+> + pprVarSet vs (hsep . punctuate comma . map (quotes . ppr)) + ] + causes (NotClosed n reason) = + let msg = text "uses" <+> quotes (ppr n) <+> text "which" + in case reason of + NotClosed _ _ -> msg : causes reason + _ -> let (xs0, xs1) = splitAt 1 $ causes reason + in fmap (msg <+>) xs0 ++ xs1 diagnosticReason = \case TcRnUnknownMessage m @@ -553,6 +626,24 @@ instance Diagnostic TcRnMessage where -> ErrorWithoutFlag TcRnConflictingExports{} -> ErrorWithoutFlag + TcRnAmbiguousField{} + -> WarningWithFlag Opt_WarnAmbiguousFields + TcRnMissingFields{} + -> WarningWithFlag Opt_WarnMissingFields + TcRnFieldUpdateInvalidType{} + -> ErrorWithoutFlag + TcRnNoConstructorHasAllFields{} + -> ErrorWithoutFlag + TcRnMixedSelectors{} + -> ErrorWithoutFlag + TcRnMissingStrictFields{} + -> ErrorWithoutFlag + TcRnNoPossibleParentForFields{} + -> ErrorWithoutFlag + TcRnBadOverloadedRecordUpdate{} + -> ErrorWithoutFlag + TcRnStaticFormNotClosed{} + -> ErrorWithoutFlag diagnosticHints = \case TcRnUnknownMessage m @@ -724,6 +815,24 @@ instance Diagnostic TcRnMessage where -> noHints TcRnConflictingExports{} -> noHints + TcRnAmbiguousField{} + -> noHints + TcRnMissingFields{} + -> noHints + TcRnFieldUpdateInvalidType{} + -> noHints + TcRnNoConstructorHasAllFields{} + -> noHints + TcRnMixedSelectors{} + -> noHints + TcRnMissingStrictFields{} + -> noHints + TcRnNoPossibleParentForFields{} + -> noHints + TcRnBadOverloadedRecordUpdate{} + -> noHints + TcRnStaticFormNotClosed{} + -> noHints messageWithInfoDiagnosticMessage :: UnitState -> ErrInfo @@ -789,6 +898,8 @@ pprLevityPolyInType ty prov = -> empty in formatLevPolyErr ty $$ extra +pprField :: (FieldLabelString, TcType) -> SDoc +pprField (f,ty) = ppr f <+> dcolon <+> ppr ty pprRecordFieldPart :: RecordFieldPart -> SDoc pprRecordFieldPart = \case diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index 4272ac9a4a..7bcd83c98c 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -12,6 +12,7 @@ module GHC.Tc.Errors.Types ( , hasKinds , SuggestUndecidableInstances(..) , suggestUndecidableInstances + , NotClosedReason(..) ) where import GHC.Prelude @@ -20,15 +21,20 @@ import GHC.Hs import {-# SOURCE #-} GHC.Tc.Types (TcIdSigInfo) import GHC.Tc.Types.Constraint import GHC.Tc.Types.Rank (Rank) +import GHC.Tc.Utils.TcType (TcType) import GHC.Types.Error +import GHC.Types.FieldLabel (FieldLabelString) import GHC.Types.Name (Name, OccName) import GHC.Types.Name.Reader import GHC.Types.SrcLoc import GHC.Types.TyThing (TyThing) +import GHC.Types.Var (Id) +import GHC.Types.Var.Set (TyVarSet, VarSet) import GHC.Unit.Types (Module) import GHC.Utils.Outputable import GHC.Core.Class (Class) import GHC.Core.Coercion.Axiom (CoAxBranch) +import GHC.Core.ConLike (ConLike) import GHC.Core.FamInstEnv (FamInst) import GHC.Core.InstEnv (ClsInst) import GHC.Core.TyCon (TyCon, TyConFlavour) @@ -36,7 +42,6 @@ import GHC.Core.Type (Kind, Type, Var) import GHC.Unit.State (UnitState) import GHC.Unit.Module.Name (ModuleName) import GHC.Types.Basic -import GHC.Types.Var.Set (TyVarSet) import qualified Data.List.NonEmpty as NE import Data.Typeable hiding (TyCon) @@ -1097,6 +1102,135 @@ data TcRnMessage where -> IE GhcPs -- ^ Export decl of second export -> TcRnMessage + {-| TcRnAmbiguousField is a warning controlled by -Wambiguous-fields occurring + when a record update's type cannot be precisely determined. This will not + be supported by -XDuplicateRecordFields in future releases. + + Example(s): + data Person = MkPerson { personId :: Int, name :: String } + data Address = MkAddress { personId :: Int, address :: String } + bad1 x = x { personId = 4 } :: Person -- ambiguous + bad2 (x :: Person) = x { personId = 4 } -- ambiguous + good x = (x :: Person) { personId = 4 } -- not ambiguous + + Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail06 + -} + TcRnAmbiguousField + :: HsExpr GhcRn -- ^ Field update + -> TyCon -- ^ Record type + -> TcRnMessage + + {-| TcRnMissingFields is a warning controlled by -Wmissing-fields occurring + when the intialisation of a record is missing one or more (lazy) fields. + + Example(s): + data Rec = Rec { a :: Int, b :: String, c :: Bool } + x = Rec { a = 1, b = "two" } -- missing field 'c' + + Test cases: deSugar/should_compile/T13870 + deSugar/should_compile/ds041 + patsyn/should_compile/T11283 + rename/should_compile/T5334 + rename/should_compile/T12229 + rename/should_compile/T5892a + warnings/should_fail/WerrorFail2 + -} + TcRnMissingFields :: ConLike -> [(FieldLabelString, TcType)] -> TcRnMessage + + {-| TcRnFieldUpdateInvalidType is an error occurring when an updated field's + type mentions something that is outside the universally quantified variables + of the data constructor, such as an existentially quantified type. + + Example(s): + data X = forall a. MkX { f :: a } + x = (MkX ()) { f = False } + + Test cases: patsyn/should_fail/records-exquant + typecheck/should_fail/T3323 + -} + TcRnFieldUpdateInvalidType :: [(FieldLabelString,TcType)] -> TcRnMessage + + {-| TcRnNoConstructorHasAllFields is an error that occurs when a record update + has fields that no single constructor encompasses. + + Example(s): + data Foo = A { x :: Bool } + | B { y :: Int } + foo = (A False) { x = True, y = 5 } + + Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail08 + patsyn/should_fail/mixed-pat-syn-record-sels + typecheck/should_fail/T7989 + -} + TcRnNoConstructorHasAllFields :: [FieldLabelString] -> TcRnMessage + + {- TcRnMixedSelectors is an error for when a mixture of pattern synonym and + record selectors are used in the same record update block. + + Example(s): + data Rec = Rec { foo :: Int, bar :: String } + pattern Pat { f1, f2 } = Rec { foo = f1, bar = f2 } + illegal :: Rec -> Rec + illegal r = r { f1 = 1, bar = "two" } + + Test cases: patsyn/should_fail/records-mixing-fields + -} + TcRnMixedSelectors + :: Name -- ^ Record + -> [Id] -- ^ Record selectors + -> Name -- ^ Pattern synonym + -> [Id] -- ^ Pattern selectors + -> TcRnMessage + + {- TcRnMissingStrictFields is an error occurring when a record field marked + as strict is omitted when constructing said record. + + Example(s): + data R = R { strictField :: !Bool, nonStrict :: Int } + x = R { nonStrict = 1 } + + Test cases: typecheck/should_fail/T18869 + typecheck/should_fail/tcfail085 + typecheck/should_fail/tcfail112 + -} + TcRnMissingStrictFields :: ConLike -> [(FieldLabelString, TcType)] -> TcRnMessage + + {- TcRnNoPossibleParentForFields is an error thrown when the fields used in a + record update block do not all belong to any one type. + + Example(s): + data R1 = R1 { x :: Int, y :: Int } + data R2 = R2 { y :: Int, z :: Int } + update r = r { x = 1, y = 2, z = 3 } + + Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail01 + overloadedrecflds/should_fail/overloadedrecfldsfail14 + -} + TcRnNoPossibleParentForFields :: [LHsRecUpdField GhcRn] -> TcRnMessage + + {- TcRnBadOverloadedRecordUpdate is an error for a record update that cannot + be pinned down to any one constructor and thus must be given a type signature. + + Example(s): + data R1 = R1 { x :: Int } + data R2 = R2 { x :: Int } + update r = r { x = 1 } -- needs a type signature + + Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail01 + -} + TcRnBadOverloadedRecordUpdate :: [LHsRecUpdField GhcRn] -> TcRnMessage + + {- TcRnStaticFormNotClosed is an error pertaining to terms that are marked static + using the -XStaticPointers extension but which are not closed terms. + + Example(s): + f x = static x + + Test cases: rename/should_fail/RnStaticPointersFail01 + rename/should_fail/RnStaticPointersFail03 + -} + TcRnStaticFormNotClosed :: Name -> NotClosedReason -> TcRnMessage + -- | Which parts of a record field are affected by a particular error or warning. data RecordFieldPart = RecordFieldConstructor !Name @@ -1151,3 +1285,9 @@ data SuggestUndecidableInstances suggestUndecidableInstances :: Bool -> SuggestUndecidableInstances suggestUndecidableInstances True = YesSuggestUndecidableInstaces suggestUndecidableInstances False = NoSuggestUndecidableInstaces + +-- | A data type to describe why a variable is not closed. +-- See Note [Not-closed error messages] in GHC.Tc.Gen.Expr +data NotClosedReason = NotLetBoundReason + | NotTypeClosed VarSet + | NotClosed Name NotClosedReason diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index d61bbbe694..899a69353e 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -738,7 +738,7 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds }) res_ con1_tv_set = mkVarSet con1_tvs bad_fld (fld, ty) = fld `elem` upd_fld_occs && not (tyCoVarsOfType ty `subVarSet` con1_tv_set) - ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds) + ; checkTc (null bad_upd_flds) (TcRnFieldUpdateInvalidType bad_upd_flds) -- STEP 4 Note [Type of a record update] -- Figure out types for the scrutinee and result @@ -1218,7 +1218,7 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty identifyParent fam_inst_envs possible_parents = case foldr1 intersect possible_parents of -- No parents for all fields: record update is ill-typed - [] -> failWithTc (noPossibleParents rbnds) + [] -> failWithTc (TcRnNoPossibleParentForFields rbnds) -- Exactly one datatype with all the fields: use that [p] -> return p @@ -1237,7 +1237,7 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty ; return (RecSelData tc) } -- Nothing else we can try... - _ -> failWithTc badOverloadedUpdate + _ -> failWithTc (TcRnBadOverloadedRecordUpdate rbnds) -- Make a field unambiguous by choosing the given parent. -- Emits an error if the field cannot have that parent, @@ -1286,13 +1286,7 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty -- See Note [Deprecating ambiguous fields] in GHC.Tc.Gen.Head reportAmbiguousField :: TyCon -> TcM () reportAmbiguousField parent_type = - setSrcSpan loc $ addDiagnostic $ - TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnAmbiguousFields) noHints $ - vcat [ text "The record update" <+> ppr rupd - <+> text "with type" <+> ppr parent_type - <+> text "is ambiguous." - , text "This will not be supported by -XDuplicateRecordFields in future releases of GHC." - ] + setSrcSpan loc $ addDiagnostic $ TcRnAmbiguousField rupd parent_type where rupd = RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds, rupd_ext = noExtField } loc = getLocA (head rbnds) @@ -1401,13 +1395,10 @@ checkMissingFields con_like rbinds arg_tys -- But C{} is still valid if no strict fields = if any isBanged field_strs then -- Illegal if any arg is strict - addErrTc (missingStrictFields con_like []) + addErrTc (TcRnMissingStrictFields con_like []) else do when (notNull field_strs && null field_labels) $ do - let msg = TcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingFields) - noHints - (missingFields con_like []) + let msg = TcRnMissingFields con_like [] (diagnosticTc True msg) | otherwise = do -- A record @@ -1415,7 +1406,7 @@ checkMissingFields con_like rbinds arg_tys fs <- zonk_fields missing_s_fields -- It is an error to omit a strict field, because -- we can't substitute it with (error "Missing field f") - addErrTc (missingStrictFields con_like fs) + addErrTc (TcRnMissingStrictFields con_like fs) warn <- woptM Opt_WarnMissingFields when (warn && notNull missing_ns_fields) $ do @@ -1423,10 +1414,7 @@ checkMissingFields con_like rbinds arg_tys -- It is not an error (though we may want) to omit a -- lazy field, because we can always use -- (error "Missing field f") instead. - let msg = TcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingFields) - noHints - (missingFields con_like fs) + let msg = TcRnMissingFields con_like fs diagnosticTc True msg where @@ -1468,22 +1456,13 @@ fieldCtxt :: FieldLabelString -> SDoc fieldCtxt field_name = text "In the" <+> quotes (ppr field_name) <+> text "field of a record" -badFieldTypes :: [(FieldLabelString,TcType)] -> TcRnMessage -badFieldTypes prs - = TcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Record update for insufficiently polymorphic field" - <> plural prs <> colon) - 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ]) - badFieldsUpd :: [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] -- Field names that don't belong to a single datacon -> [ConLike] -- Data cons of the type which the first field name belongs to -> TcRnMessage badFieldsUpd rbinds data_cons - = TcRnUnknownMessage $ mkPlainError noHints $ - hang (text "No constructor has all these fields:") - 2 (pprQuotedList conflictingFields) + = TcRnNoConstructorHasAllFields conflictingFields -- See Note [Finding the conflicting fields] where -- A (preferably small) set of fields such that no constructor contains @@ -1554,60 +1533,12 @@ a decent stab, no more. See #7989. mixedSelectors :: [Id] -> [Id] -> TcRnMessage mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_) - = TcRnUnknownMessage $ mkPlainError noHints $ - text "Cannot use a mixture of pattern synonym and record selectors" $$ - text "Record selectors defined by" - <+> quotes (ppr (tyConName rep_dc)) - <> colon - <+> pprWithCommas ppr data_sels $$ - text "Pattern synonym selectors defined by" - <+> quotes (ppr (patSynName rep_ps)) - <> colon - <+> pprWithCommas ppr pat_syn_sels + = TcRnMixedSelectors (tyConName rep_dc) data_sels (patSynName rep_ps) pat_syn_sels where RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id RecSelData rep_dc = recordSelectorTyCon dc_rep_id mixedSelectors _ _ = panic "GHC.Tc.Gen.Expr: mixedSelectors emptylists" - -missingStrictFields :: ConLike -> [(FieldLabelString, TcType)] -> TcRnMessage -missingStrictFields con fields - = TcRnUnknownMessage $ mkPlainError noHints $ vcat [header, nest 2 rest] - where - pprField (f,ty) = ppr f <+> dcolon <+> ppr ty - rest | null fields = Outputable.empty -- Happens for non-record constructors - -- with strict fields - | otherwise = vcat (fmap pprField fields) - - header = text "Constructor" <+> quotes (ppr con) <+> - text "does not have the required strict field(s)" <> - if null fields then Outputable.empty else colon - -missingFields :: ConLike -> [(FieldLabelString, TcType)] -> SDoc -missingFields con fields - = vcat [header, nest 2 rest] - where - pprField (f,ty) = ppr f <+> text "::" <+> ppr ty - rest | null fields = Outputable.empty - | otherwise = vcat (fmap pprField fields) - header = text "Fields of" <+> quotes (ppr con) <+> - text "not initialised" <> - if null fields then Outputable.empty else colon - --- callCtxt fun args = text "In the call" <+> parens (ppr (foldl' mkHsApp fun args)) - -noPossibleParents :: [LHsRecUpdField GhcRn] -> TcRnMessage -noPossibleParents rbinds - = TcRnUnknownMessage $ mkPlainError noHints $ - hang (text "No type has all these fields:") - 2 (pprQuotedList fields) - where - fields = map (hfbLHS . unLoc) rbinds - -badOverloadedUpdate :: TcRnMessage -badOverloadedUpdate = TcRnUnknownMessage $ mkPlainError noHints $ - text "Record update is ambiguous, and requires a type signature" - {- ************************************************************************ * * @@ -1616,11 +1547,6 @@ badOverloadedUpdate = TcRnUnknownMessage $ mkPlainError noHints $ ************************************************************************ -} --- | A data type to describe why a variable is not closed. -data NotClosedReason = NotLetBoundReason - | NotTypeClosed VarSet - | NotClosed Name NotClosedReason - -- | Checks if the given name is closed and emits an error if not. -- -- See Note [Not-closed error messages]. @@ -1686,25 +1612,7 @@ checkClosedInStaticForm name = do -- when the final node has a non-closed type. -- explain :: Name -> NotClosedReason -> TcRnMessage - explain name reason = TcRnUnknownMessage $ mkPlainError noHints $ - quotes (ppr name) <+> text "is used in a static form but it is not closed" - <+> text "because it" - $$ - sep (causes reason) - - causes :: NotClosedReason -> [SDoc] - causes NotLetBoundReason = [text "is not let-bound."] - causes (NotTypeClosed vs) = - [ text "has a non-closed type because it contains the" - , text "type variables:" <+> - pprVarSet vs (hsep . punctuate comma . map (quotes . ppr)) - ] - causes (NotClosed n reason) = - let msg = text "uses" <+> quotes (ppr n) <+> text "which" - in case reason of - NotClosed _ _ -> msg : causes reason - _ -> let (xs0, xs1) = splitAt 1 $ causes reason - in fmap (msg <+>) xs0 ++ xs1 + explain = TcRnStaticFormNotClosed -- Note [Not-closed error messages] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |