[Git][ghc/ghc][wip/T24824] Pmc: Improve implementation of -Wincomplete-record-selectors (#24824, #24891)
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Fri May 31 13:24:47 UTC 2024
Sebastian Graf pushed to branch wip/T24824 at Glasgow Haskell Compiler / GHC
Commits:
aa6cc73a by Sebastian Graf at 2024-05-31T15:24:35+02:00
Pmc: Improve implementation of -Wincomplete-record-selectors (#24824, #24891)
We now incorporate the result type of unsaturated record selector applications
as well as consider long-distance information in getField applications.
See the updated Note [Detecting incomplete record selectors].
Fixes #24824 and #24891.
- - - - -
14 changed files:
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/HsToCore/Pmc.hs
- compiler/GHC/HsToCore/Pmc/Check.hs
- compiler/GHC/HsToCore/Types.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/Types/CtLocEnv.hs
- compiler/GHC/Tc/Types/LclEnv.hs
- compiler/GHC/Tc/Utils/Monad.hs
- + testsuite/tests/pmcheck/should_compile/T24824.hs
- + testsuite/tests/pmcheck/should_compile/T24891.hs
- + testsuite/tests/pmcheck/should_compile/T24891.stderr
- testsuite/tests/pmcheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -1,6 +1,6 @@
-
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE MultiWayIf #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# LANGUAGE LambdaCase #-}
@@ -43,6 +43,7 @@ import GHC.Hs
import GHC.Tc.Utils.TcType
import GHC.Tc.Types.Evidence
import GHC.Tc.Utils.Monad
+import GHC.Tc.Instance.Class (lookupHasFieldLabel)
import GHC.Core.Type
import GHC.Core.TyCo.Rep
import GHC.Core
@@ -68,7 +69,6 @@ import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Core.PatSyn
import Control.Monad
-import GHC.Types.Error
{-
************************************************************************
@@ -262,28 +262,18 @@ dsLExpr (L loc e) = putSrcSpanDsA loc $ dsExpr e
dsExpr :: HsExpr GhcTc -> DsM CoreExpr
dsExpr (HsVar _ (L _ id)) = dsHsVar id
-{- Record selectors are warned about if they are not
-present in all of the parent data type's constructor,
-or always in case of pattern synonym record selectors
-(regulated by a flag). However, this only produces
-a warning if it's not a part of a record selector
-application. For example:
-
- data T = T1 | T2 {s :: Bool}
- f x = s x -- the warning from this case will be supressed
-
-See the `HsApp` case for where it is filtered out
--}
+-- See of Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
dsExpr (HsRecSel _ (FieldOcc id _))
= do { let name = getName id
RecSelId {sel_cons = (_, cons_wo_field)}
= idDetails id
- ; cons_trimmed <- trim_cons cons_wo_field
- ; unless (null cons_wo_field) $ diagnosticDs
- $ DsIncompleteRecordSelector name cons_trimmed (cons_trimmed /= cons_wo_field)
- -- This only produces a warning if it's not a part of a
- -- record selector application (e.g. `s a` where `s` is a selector)
- -- See the `HsApp` case for where it is filtered out
+ ; suppress_here <- getSuppressIncompleteRecSelsDs
+ -- See (5) of Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
+ ; unless suppress_here $ do
+ cons_trimmed <- trim_cons cons_wo_field
+ -- See (4) of Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
+ unless (null cons_wo_field) $
+ diagnosticDs $ DsIncompleteRecordSelector name cons_trimmed (cons_trimmed /= cons_wo_field)
; dsHsVar id }
where
trim_cons :: [ConLike] -> DsM [ConLike]
@@ -359,28 +349,17 @@ dsExpr (HsLam _ variant a_Match)
= uncurry mkCoreLams <$> matchWrapper (LamAlt variant) Nothing a_Match
dsExpr e@(HsApp _ fun arg)
- -- We want to have a special case that uses the PMC information to filter
- -- out some of the incomplete record selectors warnings and not trigger
- -- the warning emitted during the desugaring of dsExpr(HsRecSel)
- -- See Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
- = do { (msgs, fun') <- captureMessagesDs $ dsLExpr fun
- -- Make sure to filter out the generic incomplete record selector warning
- -- if it's a raw record selector
+ = do { fun' <- suppressIncompleteRecSelsDs $ dsLExpr fun
+ -- See (5) of Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
; arg' <- dsLExpr arg
- ; case getIdFromTrivialExpr_maybe fun' of
- Just fun_id | isRecordSelector fun_id
- -> do { let msgs' = filterMessages is_incomplete_rec_sel_msg msgs
- ; addMessagesDs msgs'
- ; pmcRecSel fun_id arg' }
- _ -> addMessagesDs msgs
+ ; mb_rec_sel <- decomposeRecSelHead fun'
+ ; case mb_rec_sel of
+ -- See (2) of Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
+ Just sel_id
+ -> pmcRecSel sel_id arg'
+ _ -> return ()
; warnUnusedBindValue fun arg (exprType arg')
; return $ mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg' }
- where
- is_incomplete_rec_sel_msg :: MsgEnvelope DsMessage -> Bool
- is_incomplete_rec_sel_msg (MsgEnvelope {errMsgDiagnostic = DsIncompleteRecordSelector{}})
- = False
- is_incomplete_rec_sel_msg _ = True
-
dsExpr e@(HsAppType {}) = dsHsWrapped e
@@ -1006,7 +985,19 @@ warnDiscardedDoBindings rhs rhs_ty
------------------------------
dsHsWrapped :: HsExpr GhcTc -> DsM CoreExpr
dsHsWrapped orig_hs_expr
- = go idHsWrapper orig_hs_expr
+ = do { res <- suppressIncompleteRecSelsDs $ go idHsWrapper orig_hs_expr
+ ; suppress_here <- getSuppressIncompleteRecSelsDs
+ -- See (5) of Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
+ ; if | not suppress_here
+ , Just fun_id <- getIdFromTrivialExpr_maybe res
+ , isRecordSelector fun_id
+ , Just (FTF_T_T, _, arg_ty,_res_ty) <- splitFunTy_maybe (exprType res)
+ -> do { dummy <- newSysLocalDs ManyTy arg_ty
+ -- See (3) of Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
+ ; pmcRecSel fun_id (Var dummy) }
+ | otherwise
+ -> return ()
+ ; return res }
where
go wrap (HsPar _ (L _ hs_e))
= go wrap hs_e
@@ -1028,3 +1019,43 @@ dsHsWrapped orig_hs_expr
{ addTyCs FromSource (hsWrapDictBinders wrap) $
do { e <- dsExpr hs_e
; return (wrap' e) } } }
+
+decomposeRecSelHead :: CoreExpr -> DsM (Maybe Id)
+-- Detect whether the given CoreExpr is
+-- * a record selector, or
+-- * a resolved getField application listing the record selector
+-- See (6) of Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc.
+decomposeRecSelHead fun
+ -- First plain record selectors; `sel |> co`. Easy:
+ | Just sel_id <- getIdFromTrivialExpr_maybe fun
+ , isRecordSelector sel_id
+ = pure (Just sel_id)
+
+ -- Now resolved getField applications. General form:
+ -- getField
+ -- @GHC.Types.Symbol {k}
+ -- @"sel" x
+ -- @T r
+ -- @Int a
+ -- ($dHasField :: HasField "sel" T Int)
+ -- :: T -> Int
+ -- where
+ -- $dHasField = sel |> (co :: T -> Int ~R# HasField "sel" T Int)
+ -- Alas, we cannot simply look at the unfolding of $dHasField below because it
+ -- has not been set yet, so we have to reconstruct the selector from the types.
+ | App fun2 dict <- fun
+ -- cheap test first
+ , Just _dict_id <- getIdFromTrivialExpr_maybe dict
+ -- looks good so far. Now match deeper
+ , get_field `App` _k `App` Type x_ty `App` Type r_ty `App` _a_ty <- fun2
+ , Just get_field_id <- getIdFromTrivialExpr_maybe get_field
+ , get_field_id `hasKey` getFieldClassOpKey
+ -- Checks out! Now get a hold of the record selector.
+ = do fam_inst_envs <- dsGetFamInstEnvs
+ -- Look up the field named x/"sel" in the type r/T
+ case lookupHasFieldLabel fam_inst_envs x_ty r_ty of
+ Just fl -> Just <$> dsLookupGlobalId (flSelector fl)
+ Nothing -> pure Nothing
+
+ | otherwise
+ = pure Nothing
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -36,6 +36,9 @@ module GHC.HsToCore.Monad (
-- Getting and setting pattern match oracle states
getPmNablas, updPmNablas,
+ -- Locally suppress -Wincomplete-record-selectors warnings
+ getSuppressIncompleteRecSelsDs, suppressIncompleteRecSelsDs,
+
-- Tracking evidence variable coherence
addUnspecables, getUnspecables,
@@ -45,7 +48,6 @@ module GHC.HsToCore.Monad (
-- Warnings and errors
DsWarning, diagnosticDs, errDsCoreExpr,
failWithDs, failDs, discardWarningsDs,
- addMessagesDs, captureMessagesDs,
-- Data types
DsMatchContext(..),
@@ -374,6 +376,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
, dsl_loc = real_span
, dsl_nablas = initNablas
, dsl_unspecables = mempty
+ , dsl_suppress_incomplete_rec_sel = False
}
in (gbl_env, lcl_env)
@@ -435,6 +438,13 @@ addUnspecables unspecables = updLclEnv (\env -> env{ dsl_unspecables = unspecabl
getUnspecables :: DsM (S.Set EvId)
getUnspecables = dsl_unspecables <$> getLclEnv
+suppressIncompleteRecSelsDs :: DsM a -> DsM a
+suppressIncompleteRecSelsDs = updLclEnv (\dsl -> dsl { dsl_suppress_incomplete_rec_sel = True })
+
+-- | Get the current pattern match oracle state. See 'dsl_nablas'.
+getSuppressIncompleteRecSelsDs :: DsM Bool
+getSuppressIncompleteRecSelsDs = do { env <- getLclEnv; return (dsl_suppress_incomplete_rec_sel env) }
+
getSrcSpanDs :: DsM SrcSpan
getSrcSpanDs = do { env <- getLclEnv
; return (RealSrcSpan (dsl_loc env) Strict.Nothing) }
@@ -459,12 +469,6 @@ diagnosticDs dsMessage
; let msg = mkMsgEnvelope diag_opts loc (ds_name_ppr_ctx env) dsMessage
; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) }
-addMessagesDs :: Messages DsMessage -> DsM ()
-addMessagesDs msgs1
- = do { msg_var <- ds_msgs <$> getGblEnv
- ; msgs0 <- liftIO $ readIORef msg_var
- ; liftIO $ writeIORef msg_var (msgs0 `unionMessages` msgs1) }
-
-- | Issue an error, but return the expression for (), so that we can continue
-- reporting errors.
errDsCoreExpr :: DsMessage -> DsM CoreExpr
@@ -480,13 +484,6 @@ failWithDs msg
failDs :: DsM a
failDs = failM
-captureMessagesDs :: DsM a -> DsM (Messages DsMessage, a)
-captureMessagesDs thing_inside
- = do { msg_var <- liftIO $ newIORef emptyMessages
- ; res <- updGblEnv (\gbl -> gbl {ds_msgs = msg_var}) thing_inside
- ; msgs <- liftIO $ readIORef msg_var
- ; return (msgs, res) }
-
mkNamePprCtxDs :: DsM NamePprCtx
mkNamePprCtxDs = ds_name_ppr_ctx <$> getGblEnv
=====================================
compiler/GHC/HsToCore/Pmc.hs
=====================================
@@ -200,55 +200,171 @@ pmcMatches origin ctxt vars matches = {-# SCC "pmcMatches" #-} do
{-
Note [Detecting incomplete record selectors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A record selector occurrence is incomplete iff. it could fail due to
-being applied to a data type constructor not present for this record field.
-
-e.g.
- data T = T1 | T2 {x :: Int}
- d = x someComputation -- `d` may fail
-
-There are 4 parts to detecting and warning about
-incomplete record selectors to consider:
-
- - Computing which constructors a general application of a record field will succeed on,
- and which ones it will fail on. This is stored in the `sel_cons` field of
- `IdDetails` datatype, which is a part of an `Id` and calculated when renaming a
- record selector in `mkOneRecordSelector`
-
- - Emitting a warning whenever a `HasField` constraint is solved.
- This is checked in `matchHasField` and emitted only for when
- the constraint is resolved with an implicit instance rather than a
- custom one (since otherwise the warning will be emitted in
- the custom implementation anyways)
-
- e.g.
- g :: HasField "x" t Int => t -> Int
- g = getField @"x"
-
- f :: T -> Int
- f = g -- warning will be emitted here
-
- - Emitting a warning for a general occurrence of the record selector
- This is done during the renaming of a `HsRecSel` expression in `dsExpr`
- and simply pulls the information about incompleteness from the `Id`
-
- e.g.
- l :: T -> Int
- l a = x a -- warning will be emitted here
-
- - Emitting a warning for a record selector `sel` applied to a variable `y`.
- In that case we want to use the long-distance information from the
- pattern match checker to rule out impossible constructors
- (See Note [Long-distance information]). We first add constraints to
- the long-distance `Nablas` that `y` cannot be one of the constructors that
- contain `sel` (function `checkRecSel` in GHC.HsToCore.Pmc.Check). If the
- `Nablas` are still inhabited, we emit a warning with the inhabiting constructors
- as examples of where `sel` may fail.
-
- e.g.
- z :: T -> Int
- z T1 = 0
- z a = x a -- warning will not be emitted here since `a` can only be `T2`
+This Note describes the implementation of
+GHC proposal 516 "Add warning for incomplete record selectors".
+
+A **partial field** is a field that does not belong to every constructor of the
+corresponding datatype.
+A **partial selector occurrence** is a use of a record selector for a partial
+field, either as a selector function in an expression, or as the solution to a
+HasField constraint.
+
+Partial selector occurrences desugar to case expressions which may crash at
+runtime:
+
+ data T a where
+ T1 :: T Int
+ T2 {sel :: Int} :: T Bool
+
+ urgh :: T a -> Int
+ urgh x = sel x
+ ===>
+ urgh x = case x of
+ T1 -> error "no record field sel"
+ T2 f -> f
+
+As such, it makes sense to warn about such potential crashes.
+We do so whenever -Wincomplete-record-selectors is present, and we utilise
+the pattern-match coverage checker for precise results, because there are many
+uses of selectors for partial fields which are in fact dynamically safe.
+
+Pmc can detect two very common safe uses for which we will not warn:
+
+ (LDI) Ambient pattern-matches unleash Note [long-distance information] that
+ render a naively flagged partial selector occurrence safe, as in
+ ldi :: T a -> Int
+ ldi T1 = 0
+ ldi arg = sel arg
+ We should not warn here, because `arg` cannot be `T1`.
+
+ (RES) Constraining the result type of a GADT such as T might render
+ naively flagged partial selector occurrences safe, as in
+ resTy :: T Bool -> Int
+ resTy = sel
+ Here, `T1 :: T Int` is ruled out because it has the wrong result type.
+
+Additionally, we want to support incomplete -XOverloadedRecordDot access as
+well, in either the (LDI) use case or the (RES) use case:
+
+ data Dot = No | Yes { sel2 :: Int }
+ dot d = d.sel2 -- should warn
+ ldiDot No = 0
+ ldiDot d = d.sel2 -- should not warn
+ resTyDot :: T Bool -> Int
+ resTyDot x = x.sel -- should not warn
+
+Furthermore, HasField constraints allow to delay the completeness check from
+the field access site to a caller, as in test cases TcIncompleteRecSel and T24891:
+
+ accessDot :: HasField "sel2" t Int => t -> Int
+ accessDot x = x.sel2
+ solveDot :: Dot -> Int
+ solveDot = accessDot
+
+We should warn in `solveDot`, but not in `accessDot`.
+
+Here is how we achieve all this in the implementation:
+
+ 1. When renaming a record selector in `mkOneRecordSelector`,
+ we precompute the constructors the selector succeeds on.
+ That would be `T2` for `sel` because `sel (T2 42)` succeeds,
+ and `Yes` for `sel2` because `sel2 (Yes 13)` succeeds.
+ We store this information in the `sel_cons` field of `RecSelId`.
+
+The next three items describe mechanisms for producing warnings on vanilla
+record selectors and situations in which they trigger. They are ordered by
+specificity, so we prefer (2) over (3) over (4).
+Item (5) below describes how we resolve the overlap.
+
+ 2. In case (LDI), we have a record selector application `sel arg`.
+ This situation is detected in the `HsApp` case of `dsExpr`.
+ We call out to the pattern-match checker to determine whether use of the
+ selector is safe, by calling GHC.HsToCore.Pmc.pmcRecSel, passing the
+ `RecSelId` `sel` as well as `arg`.
+
+ The pattern-match checker reduces the partial-selector-occurrence problem to
+ a complete-match problem by adding a negative constructor constraint such as
+ `arg /~ T2` for every constructor in the precomputed `sel_cons` of `sel`.
+ Recall that these were exactly the constructors which define a field `sel`.
+ `pmcRecSel` then tests
+
+ case arg of {}
+
+ for completeness. Any incomplete match, such as in the original `urgh`, must
+ reference a constructor that does not have field `sel`, such as `T1`.
+ In case of `urgh`, `T1` is indeed the case that we report as inexhaustive.
+
+ However, in the example `ldi`, we have *both* the result type of
+ `arg::T a` (boring, but see (3)) as well as Note [Long-distance information]
+ about `arg` from the ambient match, and the latter lists the constraint
+ `arg /~ T1`. Consequently, since `arg` is neither `T1` nor `T2` in the
+ reduced problem, the match is exhaustive and the use of the record selector
+ safe.
+
+ 3. In case (RES), the record selector is unsaturated, but the result type
+ ensures a safe use of the selector, such as in `resTy`.
+ This situation is detected in `dsHsWrapped`, where the record selector
+ is elaborated with its type arguments; we simply match on desugared Core
+ `sel @Bool :: T Bool -> Int` to learn the result type `T Bool`.
+ We again call `pmcRecSel`, but this time with a fresh dummy Id `ds::T Bool`.
+
+ 4. In case of an unsaturated record selector that is *not* applied to any type
+ argument after elaboration (e.g. in `urgh2 = sel2 :: Dot -> Int`), we simply
+ produce a warning about all `sel_cons`; no need to call `pmcRecSel`.
+ This happens in the `HsRecSel` case of `dsExpr`.
+
+We resolve the overlap between situations (2)-(4) by preferring (2) over (3)
+over (4) as follows:
+
+ 5. (4) produces warnings in the `HsRecSel` case of `dsExpr`.
+ (3) produces warnings in a potentially surrounding call to `dsHsWrapped`.
+ (2) produces warnings in a potentially surrounding `HsApp` case in `dsExpr`.
+ Since (2) surrounds (3) surrounds (4), this is simply implemented via the
+ flag `dsl_suppress_incomplete_rec_sel` of the `DsLclEnv`, which is set
+ in (2) and (3) before desugaring subexpressions.
+
+Finally, there are 2 more items addressing -XOverloadedRecordDot:
+
+ 6. -XOverloadedRecordDot such as in `ldiDot` desugars as follows:
+ getField
+ @GHC.Types.Symbol
+ @"sel2"
+ @Dot
+ @Int
+ ($dHasField :: HasField "sel2" Dot Int)
+ d
+ where
+ $dHasField = sel2 |> (co :: Dot -> Int ~R# HasField "sel2" Dot Int)
+ We want to catch these applications in the saturated (2) case.
+ (The unsaturated case is handled implicitly by (7).)
+ For example, we do not want to generate a warning for `ldiDot`!
+ For that, we need to be smart in `decomposeRecSelHead`, which matches out
+ the record selector. It must treat the above expression similar to a vanilla
+ RecSel app `sel2 d`.
+ This is a bit nasty since we cannot look at the unfolding of `$dHasField`.
+ Tested in T24891.
+
+ 7. For `accessDot` above, `decomposeRecSelHead` will fail to find a record
+ selector, because type `t` is not obviously a record type.
+ That's good, because it means we won't emit a warning for `accessDot`.
+ But we should really emit a warning for `solveDot`!
+ There, the compiler solves a `HasField` constraint and without an immediate
+ `getField`, roughly `solveDot = accessDot @Dot $d`.
+ It is the job of the solver to warn about incompleteness here,
+ in `GHC.Tc.Instance.Class.matchHasField`.
+
+ What makes this complicated is that we do not *also* want to warn in the
+ example `dot d = d.sel2` above, which is covered by more precise case (6)!
+ We suppress the warning in this case as follows:
+ 1. The type-checker (`GHC.Tc.Gen.tcApp`) produces `getField @.. $d e`
+ (Remember that (6) will detect `getField @.. $d e` as well.)
+ 2. Through `tcl_suppress_incomplete_rec_sel`, we suppress warnings when
+ solving `$d`.
+ 3. ... but not when checking `e`, because `e` might itself be a field
+ access that would need to be checked individually.
+ 4. What complicates matters is that the solver runs *after* type-checking,
+ so we must persist `tcl_suppress_incomplete_rec_sel` in the `CtLocEnv`.
+ What a hassle. This is all tested in T24891.
-}
pmcRecSel :: Id -- ^ Id of the selector
=====================================
compiler/GHC/HsToCore/Pmc/Check.hs
=====================================
@@ -193,12 +193,11 @@ checkRecSel :: PmRecSel () -> CheckAction (PmRecSel Id)
-- See Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
checkRecSel pr@(PmRecSel { pr_arg = arg, pr_cons = cons }) = CA $ \inc -> do
arg_id <- case arg of
- Var arg_id -> return arg_id
- _ -> mkPmId $ exprType arg
+ (Var arg_id) -> return arg_id
+ arg -> mkPmId $ exprType arg
let con_cts = map (PhiNotConCt arg_id . PmAltConLike) cons
- arg_ct = PhiCoreCt arg_id arg
- phi_cts = listToBag (arg_ct : con_cts)
+ phi_cts = listToBag (PhiCoreCt arg_id arg : con_cts)
unc <- addPhiCtsNablas inc phi_cts
pure CheckResult { cr_ret = pr{ pr_arg_var = arg_id }, cr_uncov = unc, cr_approx = mempty }
=====================================
compiler/GHC/HsToCore/Types.hs
=====================================
@@ -11,7 +11,7 @@ module GHC.HsToCore.Types (
DsMetaEnv, DsMetaVal(..), CompleteMatches
) where
-import GHC.Prelude (Int)
+import GHC.Prelude (Int, Bool)
import Data.IORef
import qualified Data.Set as S
@@ -79,6 +79,9 @@ data DsLclEnv
-- ^ See Note [Long-distance information] in "GHC.HsToCore.Pmc".
-- The set of reaching values Nablas is augmented as we walk inwards, refined
-- through each pattern match in turn
+ , dsl_suppress_incomplete_rec_sel :: Bool
+ -- ^ Whether to suppress -Wincomplete-record-selectors warnings.
+ -- See (5) of Note [Detecting incomplete record selectors]
, dsl_unspecables :: S.Set EvVar
-- ^ See Note [Desugaring non-canonical evidence]: this field collects
-- all un-specialisable evidence variables in scope.
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -331,9 +331,17 @@ tcApp rn_expr exp_res_ty
; (tc_fun, fun_sigma) <- tcInferAppHead fun
+ ; let supp_incomplete_rec_sel
+ | XExpr (ExpandedThingRn (OrigExpr HsGetField{}) _) <- rn_expr
+ -- See (7) of Note [Detecting incomplete record selectors]
+ = setSuppressIncompleteRecSelsTc True
+ | otherwise
+ = id
+
-- Instantiate
; do_ql <- wantQuickLook rn_fun
- ; (delta, inst_args, app_res_rho) <- tcInstFun do_ql True (tc_fun, fun_ctxt) fun_sigma rn_args
+ ; (delta, inst_args, app_res_rho) <- supp_incomplete_rec_sel $
+ tcInstFun do_ql True (tc_fun, fun_ctxt) fun_sigma rn_args
-- Quick look at result
; app_res_rho <- if do_ql
@@ -655,7 +663,9 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
; return (delta, reverse acc, fun_ty) }
go1 delta acc so_far fun_ty (EWrap w : args)
- = go1 delta (EWrap w : acc) so_far fun_ty args
+ = setSuppressIncompleteRecSelsTc False $
+ -- See (7) of Note [Detecting incomplete record selectors]
+ go1 delta (EWrap w : acc) so_far fun_ty args
go1 delta acc so_far fun_ty (EPrag sp prag : args)
= go1 delta (EPrag sp prag : acc) so_far fun_ty args
=====================================
compiler/GHC/Tc/Instance/Class.hs
=====================================
@@ -5,7 +5,8 @@ module GHC.Tc.Instance.Class (
matchGlobalInst, matchEqualityInst,
ClsInstResult(..),
InstanceWhat(..), safeOverlap, instanceReturnsDictCon,
- AssocInstInfo(..), isNotAssociated
+ AssocInstInfo(..), isNotAssociated,
+ lookupHasFieldLabel
) where
import GHC.Prelude
@@ -22,7 +23,7 @@ import GHC.Tc.Instance.Typeable
import GHC.Tc.Utils.TcMType
import GHC.Tc.Types.Evidence
import GHC.Tc.Types.Origin (InstanceWhat (..), SafeOverlapping)
-import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst )
+import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst, FamInstEnvs )
import GHC.Rename.Env( addUsedGRE, addUsedDataCons, DeprecationWarnings (..) )
import GHC.Builtin.Types
@@ -1250,15 +1251,9 @@ matchHasField dflags short_cut clas tys
; case tys of
-- We are matching HasField {k} x r a...
[_k_ty, x_ty, r_ty, a_ty]
- -- x should be a literal string
- | Just x <- isStrLitTy x_ty
- -- r should be an applied type constructor
- , Just (tc, args) <- tcSplitTyConApp_maybe r_ty
- -- use representation tycon (if data family); it has the fields
- , let r_tc = fstOf3 (tcLookupDataFamInst fam_inst_envs tc args)
- -- x should be a field of r
- , Just fl <- lookupTyConFieldLabel (FieldLabelString x) r_tc
- -- the field selector should be in scope
+ -- Look up the field named x in the type r
+ | Just fl <- lookupHasFieldLabel fam_inst_envs x_ty r_ty
+ -- and ensure the field selector is in scope
, Just gre <- lookupGRE_FieldLabel rdr_env fl
-> do { let name = flSelector fl
@@ -1293,10 +1288,10 @@ matchHasField dflags short_cut clas tys
then do { -- See Note [Unused name reporting and HasField]
addUsedGRE AllDeprecationWarnings gre
; keepAlive name
- ; unless (null $ snd $ sel_cons $ idDetails sel_id)
- $ addDiagnostic $ TcRnHasFieldResolvedIncomplete name
- -- Only emit an incomplete selector warning if it's an implicit instance
- -- See Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
+ ; suppress <- getSuppressIncompleteRecSelsTc
+ -- See (7) of Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
+ ; unless (null (snd $ sel_cons $ idDetails sel_id) || suppress) $ do
+ addDiagnostic $ TcRnHasFieldResolvedIncomplete name
; return OneInst { cir_new_theta = theta
, cir_mk_ev = mk_ev
, cir_canonical = True
@@ -1304,3 +1299,21 @@ matchHasField dflags short_cut clas tys
else matchInstEnv dflags short_cut clas tys }
_ -> matchInstEnv dflags short_cut clas tys }
+
+lookupHasFieldLabel :: FamInstEnvs -> Type -> Type -> Maybe FieldLabel
+-- For a HasField constraint `HasField {k} x r a`,
+-- lookupHasFieldLabel _ _ x r
+-- returns the record selector `sel_id` of record type `r` which has literal
+-- string name `x`.
+lookupHasFieldLabel fam_inst_envs x_ty r_ty
+ -- x should be a literal string
+ | Just x <- isStrLitTy x_ty
+ -- r should be an applied type constructor
+ , Just (tc, args) <- tcSplitTyConApp_maybe r_ty
+ -- use representation tycon (if data family); it has the fields
+ , let r_tc = fstOf3 (tcLookupDataFamInst fam_inst_envs tc args)
+ -- x should be a field of r
+ = lookupTyConFieldLabel (FieldLabelString x) r_tc
+
+ | otherwise
+ = Nothing
=====================================
compiler/GHC/Tc/Types/CtLocEnv.hs
=====================================
@@ -29,7 +29,8 @@ data CtLocEnv = CtLocEnv { ctl_ctxt :: ![ErrCtxt]
, ctl_bndrs :: !TcBinderStack
, ctl_tclvl :: !TcLevel
, ctl_in_gen_code :: !Bool
- , ctl_rdr :: !LocalRdrEnv }
+ , ctl_rdr :: !LocalRdrEnv
+ , ctl_suppress_incomplete_rec_sels :: !Bool }
getCtLocEnvLoc :: CtLocEnv -> RealSrcSpan
@@ -57,4 +58,4 @@ setCtLocEnvLoc env loc@(UnhelpfulSpan _)
= env
ctLocEnvInGeneratedCode :: CtLocEnv -> Bool
-ctLocEnvInGeneratedCode = ctl_in_gen_code
\ No newline at end of file
+ctLocEnvInGeneratedCode = ctl_in_gen_code
=====================================
compiler/GHC/Tc/Types/LclEnv.hs
=====================================
@@ -12,6 +12,7 @@ module GHC.Tc.Types.LclEnv (
, getLclEnvRdrEnv
, getLclEnvTcLevel
, getLclEnvThStage
+ , getLclEnvSuppressIncompleteRecSels
, setLclEnvTcLevel
, setLclEnvLoc
, setLclEnvRdrEnv
@@ -19,6 +20,7 @@ module GHC.Tc.Types.LclEnv (
, setLclEnvErrCtxt
, setLclEnvThStage
, setLclEnvTypeEnv
+ , setLclEnvSuppressIncompleteRecSels
, modifyLclEnvTcLevel
, lclEnvInGeneratedCode
@@ -117,9 +119,11 @@ data TcLclCtxt
tcl_arrow_ctxt :: ArrowCtxt, -- Arrow-notation context
- tcl_env :: TcTypeEnv -- The local type environment:
+ tcl_env :: TcTypeEnv, -- The local type environment:
-- Ids and TyVars defined in this module
+ tcl_suppress_incomplete_rec_sel :: Bool -- True <=> Suppress warnings about incomplete record selectors
+ -- See (7) of Note [Detecting incomplete record selectors]
}
getLclEnvThStage :: TcLclEnv -> ThStage
@@ -179,6 +183,12 @@ getLclEnvRdrEnv = tcl_rdr . tcl_lcl_ctxt
setLclEnvRdrEnv :: LocalRdrEnv -> TcLclEnv -> TcLclEnv
setLclEnvRdrEnv rdr_env = modifyLclCtxt (\env -> env { tcl_rdr = rdr_env })
+getLclEnvSuppressIncompleteRecSels :: TcLclEnv -> Bool
+getLclEnvSuppressIncompleteRecSels = tcl_suppress_incomplete_rec_sel . tcl_lcl_ctxt
+
+setLclEnvSuppressIncompleteRecSels :: Bool -> TcLclEnv -> TcLclEnv
+setLclEnvSuppressIncompleteRecSels suppress = modifyLclCtxt (\env -> env { tcl_suppress_incomplete_rec_sel = suppress })
+
modifyLclCtxt :: (TcLclCtxt -> TcLclCtxt) -> TcLclEnv -> TcLclEnv
modifyLclCtxt upd env =
let !res = upd (tcl_lcl_ctxt env)
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -94,6 +94,7 @@ module GHC.Tc.Utils.Monad(
mkTcRnMessage, reportDiagnostic, reportDiagnostics,
warnIf, diagnosticTc, diagnosticTcM,
addDiagnosticTc, addDiagnosticTcM, addDiagnostic, addDiagnosticAt,
+ getSuppressIncompleteRecSelsTc, setSuppressIncompleteRecSelsTc,
-- * Type constraints
newTcEvBinds, newNoTcEvBinds, cloneEvBindsVar,
@@ -391,7 +392,8 @@ initTcWithGbl hsc_env gbl_env loc do_this
tcl_arrow_ctxt = NoArrowCtxt,
tcl_env = emptyNameEnv,
tcl_bndrs = [],
- tcl_tclvl = topTcLevel
+ tcl_tclvl = topTcLevel,
+ tcl_suppress_incomplete_rec_sel = False
},
tcl_usage = usage_var,
tcl_lie = lie_var,
@@ -1284,6 +1286,7 @@ mkCtLocEnv lcl_env =
, ctl_tclvl = getLclEnvTcLevel lcl_env
, ctl_in_gen_code = lclEnvInGeneratedCode lcl_env
, ctl_rdr = getLclEnvRdrEnv lcl_env
+ , ctl_suppress_incomplete_rec_sels = getLclEnvSuppressIncompleteRecSels lcl_env
}
setCtLocM :: CtLoc -> TcM a -> TcM a
@@ -1292,6 +1295,7 @@ setCtLocM (CtLoc { ctl_env = lcl }) thing_inside
= updLclEnv (\env -> setLclEnvLoc (ctl_loc lcl)
$ setLclEnvErrCtxt (ctl_ctxt lcl)
$ setLclEnvBinderStack (ctl_bndrs lcl)
+ $ setLclEnvSuppressIncompleteRecSels (ctl_suppress_incomplete_rec_sels lcl)
$ env) thing_inside
{- *********************************************************************
@@ -1673,6 +1677,12 @@ add_diagnostic msg
; mkTcRnMessage loc (TcRnMessageWithInfo unit_state msg) >>= reportDiagnostic
}
+getSuppressIncompleteRecSelsTc :: TcRn Bool
+getSuppressIncompleteRecSelsTc = getLclEnvSuppressIncompleteRecSels <$> getLclEnv
+
+setSuppressIncompleteRecSelsTc :: Bool -> TcRn a -> TcRn a
+setSuppressIncompleteRecSelsTc b = updLclEnv (setLclEnvSuppressIncompleteRecSels b)
+
{-
-----------------------------------
=====================================
testsuite/tests/pmcheck/should_compile/T24824.hs
=====================================
@@ -0,0 +1,36 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module T24824 where
+
+import GHC.Hs hiding (DataConCantHappen)
+
+main :: IO ()
+main = do
+ let hsModule = undefined :: HsModule GhcPs
+ let _ = hsmodImports $ hsModule -- warns
+ let _ = hsmodImports hsModule -- does not warn
+ pure ()
+
+data S a where
+ S1 :: S Int
+ S2 :: { x::Int } -> S a
+ S3 :: { x::Int } -> S a
+
+-- x :: forall a. S a -> Int
+-- A partial function
+
+g :: S Bool -> Int
+g s = (x @Bool) $ s
+
+data W a where
+ W1 :: !(F a) -> W a
+ W2 :: { y::Int } -> W a
+ W3 :: { y::Int } -> W a
+
+data DataConCantHappen
+
+type family F a
+type instance F Bool = DataConCantHappen
+
+h :: W Bool -> Int
+h w = y @Bool $ w
=====================================
testsuite/tests/pmcheck/should_compile/T24891.hs
=====================================
@@ -0,0 +1,30 @@
+{-# LANGUAGE GADTs, OverloadedRecordDot, DataKinds #-}
+
+module T24891 where
+
+import GHC.Records
+
+data T a where
+ T1 :: T Int
+ T2 :: {sel :: Int} -> T Bool
+ T3 :: T Bool
+
+f :: T Bool -> Int
+f x = x.sel -- warn, but only once, suggesting to match on T3
+
+data Dot = No | Yes {sel2 :: Int}
+
+ldiDot :: Dot -> Int
+ldiDot No = 0
+ldiDot d = d.sel2 -- do not warn
+
+accessDot :: HasField "sel2" t Int => t -> Int
+accessDot x = x.sel2 -- do not warn
+
+solveDot :: Dot -> Int
+solveDot = accessDot -- warn
+
+data Dot2 t = No2 | Yes2 {sel3 :: t}
+
+accessDot2 :: HasField "sel2" t Int => Dot2 t -> Int
+accessDot2 x = x.sel3.sel2 -- warn about x.sel3
=====================================
testsuite/tests/pmcheck/should_compile/T24891.stderr
=====================================
@@ -0,0 +1,9 @@
+T24891.hs:13:7: warning: [GHC-17335] [-Wincomplete-record-selectors]
+ The application of the record field ‘sel’ may fail for the following constructors: T3
+
+T24891.hs:25:12: warning: [GHC-86894] [-Wincomplete-record-selectors]
+ The invocation of `getField` on the record field ‘sel2’ may produce an error since it is not defined for all data constructors
+
+T24891.hs:30:16: warning: [GHC-17335] [-Wincomplete-record-selectors]
+ The application of the record field ‘sel3’ may fail for the following constructors: No2
+
=====================================
testsuite/tests/pmcheck/should_compile/all.T
=====================================
@@ -169,3 +169,5 @@ test('DsIncompleteRecSel1', normal, compile, ['-Wincomplete-record-selectors'])
test('DsIncompleteRecSel2', normal, compile, ['-Wincomplete-record-selectors'])
test('DsIncompleteRecSel3', [collect_compiler_stats('bytes allocated', 10)], compile, ['-Wincomplete-record-selectors'])
test('DoubleMatch', normal, compile, [overlapping_incomplete])
+test('T24824', normal, compile, ['-package ghc -Wincomplete-record-selectors'])
+test('T24891', normal, compile, ['-Wincomplete-record-selectors'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/aa6cc73a41732009cf7d26edf130f3123068a868
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/aa6cc73a41732009cf7d26edf130f3123068a868
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240531/a75017d5/attachment-0001.html>
More information about the ghc-commits
mailing list