[Git][ghc/ghc][wip/T24824] Pmc: Improve implementation of -Wincomplete-record-selectors (#24824, #24891)
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Mon May 27 11:20:56 UTC 2024
Sebastian Graf pushed to branch wip/T24824 at Glasgow Haskell Compiler / GHC
Commits:
e7487c57 by Sebastian Graf at 2024-05-27T13:19:20+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.
- - - - -
8 changed files:
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Pmc.hs
- compiler/GHC/HsToCore/Pmc/Check.hs
- compiler/GHC/Tc/Instance/Class.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,4 +1,3 @@
-
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
@@ -69,6 +68,7 @@ import GHC.Utils.Panic
import GHC.Core.PatSyn
import Control.Monad
import GHC.Types.Error
+import GHC.Tc.Instance.Class (lookupHasFieldLabel)
{-
************************************************************************
@@ -262,18 +262,7 @@ 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)}
@@ -281,9 +270,7 @@ dsExpr (HsRecSel _ (FieldOcc 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
+ -- See (4) and (5) of Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
; dsHsVar id }
where
trim_cons :: [ConLike] -> DsM [ConLike]
@@ -359,28 +346,19 @@ 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
+ -- 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
+ ; 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
+ -> do { let msgs' = filterMessages (not . is_incomplete_rec_sel_msg) msgs
; addMessagesDs msgs'
- ; pmcRecSel fun_id arg' }
+ ; pmcRecSel sel_id arg' }
_ -> addMessagesDs msgs
; 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 +984,19 @@ warnDiscardedDoBindings rhs rhs_ty
------------------------------
dsHsWrapped :: HsExpr GhcTc -> DsM CoreExpr
dsHsWrapped orig_hs_expr
- = go idHsWrapper orig_hs_expr
+ = do { (msgs, res) <- captureMessagesDs $ go idHsWrapper orig_hs_expr
+ -- See (5) of Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
+ ; case getIdFromTrivialExpr_maybe res of
+ Just fun_id
+ | isRecordSelector fun_id
+ , Just (FTF_T_T, _, arg_ty,_res_ty) <- splitFunTy_maybe (exprType res)
+ -> do { let msgs' = filterMessages (not . is_incomplete_rec_sel_msg) msgs
+ ; addMessagesDs msgs'
+ ; dummy <- newSysLocalDs ManyTy arg_ty
+ -- See (3) of Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
+ ; pmcRecSel fun_id (Var dummy) }
+ _ -> addMessagesDs msgs
+ ; return res }
where
go wrap (HsPar _ (L _ hs_e))
= go wrap hs_e
@@ -1028,3 +1018,48 @@ dsHsWrapped orig_hs_expr
{ addTyCs FromSource (hsWrapDictBinders wrap) $
do { e <- dsExpr hs_e
; return (wrap' e) } } }
+
+is_incomplete_rec_sel_msg :: MsgEnvelope DsMessage -> Bool
+is_incomplete_rec_sel_msg (MsgEnvelope {errMsgDiagnostic = DsIncompleteRecordSelector{}})
+ = True
+is_incomplete_rec_sel_msg _ = False
+
+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/Pmc.hs
=====================================
@@ -200,55 +200,120 @@ 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`
+Applications of record selectors desugar to case expressions which may crash
+at runtime for alternatives that do not define the selected field:
+
+ 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 even
+partially-defined record selectors such as `sel` above can be used in safe ways
+when all contructors that lack the selected field (such as `T1`) can be ruled
+out by ambient constraints. This happens in either of two ways:
+
+ (LDI) By relying on long-distance information, as in
+ ldi :: T a -> Int
+ ldi T1 = 0
+ ldi arg = sel arg
+ We should not warn here, because `arg` cannot be `T1`.
+
+ (RES) By constraining the result type of a GADT such as T, e.g.
+ 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 overloaded record dot 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
+
+Here is how we achieve 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 `IdDetails`.
+
+The next three items describe mechanisms for producing warnings 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`.
+ (See also (5) below for how we handle overlap with situations (3) and (4)).
+ 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 record
+ selector Id of `sel` as well as `arg`.
+
+ The pattern-match checker reduces the safe-selector-use 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`
+ and then testing
+
+ case arg of {}
+
+ for completeness. Any incomplete match, such as in the original `urgh`, must
+ reference a constructor that is not part of `sel_cons`, 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` or `resTyDot`.
+ This situation is detected in the `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`.
+ We catch the warnings of (4) when we detect (3) or (2), and the warnings
+ of (3) when we detect (2), via `captureMessagesDs`. Each capture may lead
+ to increasingly precise (i.e. fewer) incompleteness warnings.
+
+There is one more item, addressing overloaded record dot:
+
+ 6. Overloaded record dot such as in `ldiDot` desugars as follows:
+ getField
+ @GHC.Types.Symbol
+ @"sel2"
+ @Dot
+ @Int
+ (sel2 |> (co :: Dot -> Int ~R# HasField "sel2" Dot Int))
+ d
+ The occurrence of `sel2` will readily be handled by (4), or even (3).
+ However, this handling would still generate a warning for `ldiDot`!
+ It is desirable to apply (2) here as well, which needs to be tweaked a bit
+ to treat the above expression similar to a vanilla RecSel app `sel2 d`.
-}
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/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
@@ -62,9 +63,6 @@ import GHC.Unit.Module.Warnings
import GHC.Hs.Extension
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-import GHC.Types.Id.Info
-import GHC.Tc.Errors.Types
-import Control.Monad
import Data.Functor
import Data.Maybe
@@ -1250,15 +1248,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 +1285,6 @@ 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
; return OneInst { cir_new_theta = theta
, cir_mk_ev = mk_ev
, cir_canonical = True
@@ -1304,3 +1292,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
=====================================
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,17 @@
+{-# LANGUAGE GADTs, OverloadedRecordDot #-}
+
+module T24891 where
+
+data T a where
+ T1 :: T Int
+ T2 :: {sel :: Int} -> T Bool
+ T3 :: T Bool
+
+f :: T Bool -> Int
+f x = x.sel -- warn
+
+data Dot = No | Yes {sel2 :: Int}
+
+ldiDot :: Dot -> Int
+ldiDot No = 0
+ldiDot d = d.sel2 -- do not warn
=====================================
testsuite/tests/pmcheck/should_compile/T24891.stderr
=====================================
@@ -0,0 +1,3 @@
+T24891.hs:11:7: warning: [GHC-17335] [-Wincomplete-record-selectors]
+ The application of the record field ‘sel’ may fail for the following constructors: T3
+
=====================================
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/e7487c577ee42c65257d1e12aaae6f26b396eced
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e7487c577ee42c65257d1e12aaae6f26b396eced
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/20240527/1aa19cde/attachment-0001.html>
More information about the ghc-commits
mailing list