[Git][ghc/ghc][master] PMC: suggest in-scope COMPLETE sets when possible
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Aug 1 04:52:05 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
bae1fea4 by sheaf at 2024-08-01T00:51:15-04:00
PMC: suggest in-scope COMPLETE sets when possible
This commit modifies GHC.HsToCore.Pmc.Solver.generateInhabitingPatterns
to prioritise reporting COMPLETE sets in which all of the ConLikes
are in scope. This avoids suggesting out of scope constructors
when displaying an incomplete pattern match warning, e.g. in
baz :: Ordering -> Int
baz = \case
EQ -> 5
we prefer:
Patterns of type 'Ordering' not matched:
LT
GT
over:
Patterns of type 'Ordering' not matched:
OutOfScope
Fixes #25115
- - - - -
7 changed files:
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/HsToCore/Pmc/Solver.hs
- compiler/GHC/HsToCore/Types.hs
- + testsuite/tests/pmcheck/complete_sigs/T25115.hs
- + testsuite/tests/pmcheck/complete_sigs/T25115.stderr
- + testsuite/tests/pmcheck/complete_sigs/T25115a.hs
- testsuite/tests/pmcheck/complete_sigs/all.T
Changes:
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -356,16 +356,16 @@ initTcDsForSolver thing_inside
= do { (gbl, lcl) <- getEnvs
; hsc_env <- getTopEnv
+ -- The DsGblEnv is used to inform the typechecker's solver of a few
+ -- key pieces of information:
+ --
+ -- - ds_fam_inst_env tells it how to reduce type families,
+ -- - ds_gbl_rdr_env tells it which newtypes it can unwrap.
; let DsGblEnv { ds_mod = mod
, ds_fam_inst_env = fam_inst_env
- , ds_gbl_rdr_env = rdr_env } = gbl
- -- This is *the* use of ds_gbl_rdr_env:
- -- Make sure the solver (used by the pattern-match overlap checker) has
- -- access to the GlobalRdrEnv and FamInstEnv for the module, so that it
- -- knows how to reduce type families, and which newtypes it can unwrap.
-
-
- DsLclEnv { dsl_loc = loc } = lcl
+ , ds_gbl_rdr_env = rdr_env
+ } = gbl
+ DsLclEnv { dsl_loc = loc } = lcl
; (msgs, mb_ret) <- liftIO $ initTc hsc_env HsSrcFile False mod loc $
updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env
=====================================
compiler/GHC/HsToCore/Pmc/Solver.hs
=====================================
@@ -36,6 +36,7 @@ import GHC.Prelude
import GHC.HsToCore.Pmc.Types
import GHC.HsToCore.Pmc.Utils (tracePm, traceWhenFailPm, mkPmId)
+import GHC.HsToCore.Types (DsGblEnv(..))
import GHC.Driver.DynFlags
import GHC.Driver.Config
@@ -51,11 +52,14 @@ import GHC.Types.Unique.DSet
import GHC.Types.Unique.SDFM
import GHC.Types.Id
import GHC.Types.Name
-import GHC.Types.Var (EvVar)
+import GHC.Types.Name.Reader (lookupGRE_Name, GlobalRdrEnv)
+import GHC.Types.Var (EvVar)
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Unique.Supply
+import GHC.Tc.Utils.Monad (getGblEnv)
+
import GHC.Core
import GHC.Core.FVs (exprFreeVars)
import GHC.Core.TyCo.Compare( eqType )
@@ -97,6 +101,7 @@ import Data.List (sortBy, find)
import qualified Data.List.NonEmpty as NE
import Data.Ord (comparing)
+
--
-- * Main exports
--
@@ -1959,13 +1964,16 @@ generateInhabitingPatterns mode (x:xs) n nabla = do
-- No COMPLETE sets ==> inhabited
generateInhabitingPatterns mode xs n newty_nabla
Just clss -> do
- -- Try each COMPLETE set, pick the one with the smallest number of
- -- inhabitants
+ -- Try each COMPLETE set.
nablass' <- forM clss (instantiate_cons y rep_ty xs n newty_nabla)
- let nablas' = minimumBy (comparing length) nablass'
- if null nablas' && vi_bot vi /= IsNotBot
- then generateInhabitingPatterns mode xs n newty_nabla -- bot is still possible. Display a wildcard!
- else pure nablas'
+ if any null nablass' && vi_bot vi /= IsNotBot
+ then generateInhabitingPatterns mode xs n newty_nabla -- bot is still possible. Display a wildcard!
+ else do
+ -- Pick the residual COMPLETE set with the smallest cost (see 'completeSetCost').
+ -- See Note [Prefer in-scope COMPLETE matches].
+ DsGblEnv { ds_gbl_rdr_env = rdr_env } <- getGblEnv
+ let bestSet = map snd $ minimumBy (comparing $ completeSetCost rdr_env) nablass'
+ pure bestSet
-- Instantiates a chain of newtypes, beginning at @x at .
-- Turns @x nabla [T,U,V]@ to @(y, nabla')@, where @nabla'@ we has the fact
@@ -1979,13 +1987,13 @@ generateInhabitingPatterns mode (x:xs) n nabla = do
nabla' <- addConCt nabla x (PmAltConLike (RealDataCon dc)) [] [y]
instantiate_newtype_chain y nabla' dcs
- instantiate_cons :: Id -> Type -> [Id] -> Int -> Nabla -> [ConLike] -> DsM [Nabla]
+ instantiate_cons :: Id -> Type -> [Id] -> Int -> Nabla -> [ConLike] -> DsM [(Maybe ConLike, Nabla)]
instantiate_cons _ _ _ _ _ [] = pure []
instantiate_cons _ _ _ 0 _ _ = pure []
instantiate_cons _ ty xs n nabla _
-- We don't want to expose users to GHC-specific constructors for Int etc.
| fmap (isTyConTriviallyInhabited . fst) (splitTyConApp_maybe ty) == Just True
- = generateInhabitingPatterns mode xs n nabla
+ = map (Nothing,) <$> generateInhabitingPatterns mode xs n nabla
instantiate_cons x ty xs n nabla (cl:cls) = do
-- The following line is where we call out to the inhabitationTest!
mb_nabla <- runMaybeT $ instCon 4 nabla x cl
@@ -2002,7 +2010,54 @@ generateInhabitingPatterns mode (x:xs) n nabla = do
-- inhabited, otherwise the inhabitation test would have refuted.
Just nabla' -> generateInhabitingPatterns mode xs n nabla'
other_cons_nablas <- instantiate_cons x ty xs (n - length con_nablas) nabla cls
- pure (con_nablas ++ other_cons_nablas)
+ pure (map (Just cl,) con_nablas ++ other_cons_nablas)
+
+-- | If multiple residual COMPLETE sets apply, pick one as follows:
+--
+-- - prefer COMPLETE sets in which all constructors are in scope,
+-- as per Note [Prefer in-scope COMPLETE matches],
+-- - if there are ties, pick the one with the fewest (residual) ConLikes,
+-- - if there are ties, pick the one with the fewest "trivially inhabited" types,
+-- - if there are ties, pick the one with the fewest PatSyns,
+-- - if there are still ties, pick the one that comes first in the list of
+-- COMPLETE pragmas, which means the one that was brought into scope first.
+completeSetCost :: GlobalRdrEnv -> [(Maybe ConLike, a)] -> (Bool, Int, Int, Int)
+completeSetCost _ [] = (False, 0, 0, 0)
+completeSetCost rdr_env ((mb_con, _) : cons) =
+ let con_out_of_scope
+ | Just con <- mb_con
+ = isNothing $ lookupGRE_Name rdr_env (conLikeName con)
+ | otherwise
+ = False
+ (any_out_of_scope, nb_cons, nb_triv, nb_ps) = completeSetCost rdr_env cons
+ in ( any_out_of_scope || con_out_of_scope
+ , nb_cons + 1
+ , nb_triv + case mb_con of { Nothing -> 1; _ -> 0 }
+ , nb_ps + case mb_con of { Just (PatSynCon {}) -> 1; _ -> 0 }
+ )
+
+{- Note [Prefer in-scope COMPLETE matches]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We prefer using COMPLETE pragmas in which all ConLikes are in scope, as this
+improves error messages. See for example T25115:
+
+ - T25115a defines pattern Foo :: a with {-# COMPLETE Foo #-}
+ - T25115 imports T25115a, but not Foo.
+ (This means it imports the COMPLETE pragma, which behaves like an instance.)
+
+ Then, for the following incomplete pattern match in T25115:
+
+ baz :: Ordering -> Int
+ baz = \case
+ EQ -> 5
+
+ we would prefer reporting that 'LT' and 'GT' are not matched, rather than
+ saying that 'T25115a.Foo' is not matched.
+
+ However, if ALL ConLikes are out of scope, then we should still report
+ something, so we don't want to outright filter out all COMPLETE sets
+ with an out-of-scope ConLike.
+-}
pickApplicableCompleteSets :: TyState -> Type -> ResidualCompleteMatches -> DsM DsCompleteMatches
-- See Note [Implementation of COMPLETE pragmas] on what "applicable" means
=====================================
compiler/GHC/HsToCore/Types.hs
=====================================
@@ -53,9 +53,9 @@ data DsGblEnv
= DsGblEnv
{ ds_mod :: Module -- For SCC profiling
, ds_fam_inst_env :: FamInstEnv -- Like tcg_fam_inst_env
- , ds_gbl_rdr_env :: GlobalRdrEnv -- needed *only* to know what newtype
- -- constructors are in scope during
- -- pattern-match satisfiability checking
+ , ds_gbl_rdr_env :: GlobalRdrEnv -- needed only for the following reasons:
+ -- - to know what newtype constructors are in scope
+ -- - to check whether all members of a COMPLETE pragma are in scope
, ds_name_ppr_ctx :: NamePprCtx
, ds_msgs :: IORef (Messages DsMessage) -- Diagnostic messages
, ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global,
=====================================
testsuite/tests/pmcheck/complete_sigs/T25115.hs
=====================================
@@ -0,0 +1,28 @@
+{-# LANGUAGE EmptyCase #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE PatternSynonyms #-}
+
+module T25115 where
+
+import T25115a ( ABC )
+
+-- Check that we don't suggest to use the 'Foo' pattern synonym from
+-- T25115a, as it is not imported (even though the import of T25115a
+-- has brought into scope all COMPLETE pragmas from that module).
+
+foo :: Bool -> Int
+foo = \case {}
+
+bar :: Bool -> Int
+bar = \case
+ True -> 3
+
+baz :: Ordering -> Int
+baz = \case
+ EQ -> 5
+
+-- Check that we do still suggest something for ABC, even though
+-- all constructors are out of scope.
+
+quux :: ABC -> Int
+quux = \case {}
=====================================
testsuite/tests/pmcheck/complete_sigs/T25115.stderr
=====================================
@@ -0,0 +1,25 @@
+[1 of 2] Compiling T25115a ( T25115a.hs, T25115a.o )
+[2 of 2] Compiling T25115 ( T25115.hs, T25115.o )
+T25115.hs:14:7: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)]
+ Pattern match(es) are non-exhaustive
+ In a \case alternative:
+ Patterns of type ‘Bool’ not matched:
+ False
+ True
+
+T25115.hs:17:7: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)]
+ Pattern match(es) are non-exhaustive
+ In a \case alternative: Patterns of type ‘Bool’ not matched: False
+
+T25115.hs:21:7: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)]
+ Pattern match(es) are non-exhaustive
+ In a \case alternative:
+ Patterns of type ‘Ordering’ not matched:
+ LT
+ GT
+
+T25115.hs:28:8: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)]
+ Pattern match(es) are non-exhaustive
+ In a \case alternative:
+ Patterns of type ‘ABC’ not matched: T25115a.Foo
+
=====================================
testsuite/tests/pmcheck/complete_sigs/T25115a.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module T25115a ( pattern Foo, ABC ) where
+
+pattern Foo :: a
+pattern Foo <- _unused
+{-# COMPLETE Foo #-}
+
+data ABC = A | B | C
=====================================
testsuite/tests/pmcheck/complete_sigs/all.T
=====================================
@@ -32,3 +32,4 @@ test('T18960', normal, compile, [''])
test('T18960b', normal, compile, [''])
test('T19475', normal, compile, [''])
test('T24326', normal, compile, [''])
+test('T25115', [extra_files(['T25115a.hs'])], multimod_compile, ['T25115', ''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bae1fea4d192fa110eeacae193baf7a2e78e8256
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bae1fea4d192fa110eeacae193baf7a2e78e8256
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/20240801/40483205/attachment-0001.html>
More information about the ghc-commits
mailing list