[Git][ghc/ghc][wip/T13964] PmCheck: Only suggest imported ConLikes for missing patterns (#13964)
Sebastian Graf
gitlab at gitlab.haskell.org
Wed Sep 23 15:48:07 UTC 2020
Sebastian Graf pushed to branch wip/T13964 at Glasgow Haskell Compiler / GHC
Commits:
4421c464 by Sebastian Graf at 2020-09-23T17:48:00+02:00
PmCheck: Only suggest imported ConLikes for missing patterns (#13964)
We simply `lookupGRE_Name` every `ConLike` of a `COMPLETE` set before
suggesting it.
Fixes #13964.
- - - - -
7 changed files:
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/HsToCore/PmCheck/Oracle.hs
- compiler/GHC/HsToCore/Types.hs
- testsuite/tests/pmcheck/complete_sigs/T13964.hs
- testsuite/tests/pmcheck/complete_sigs/T13964.stderr
- + testsuite/tests/pmcheck/complete_sigs/T13964b.hs
- testsuite/tests/pmcheck/complete_sigs/all.T
Changes:
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -27,9 +27,9 @@ module GHC.HsToCore.Monad (
mkPrintUnqualifiedDs,
newUnique,
UniqSupply, newUniqueSupply,
- getGhcModeDs, dsGetFamInstEnvs,
+ getGhcModeDs, dsGetFamInstEnvs, dsGetGlobalRdrEnv,
dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon,
- dsLookupDataCon, dsLookupConLike,
+ dsLookupDataCon,
getCCIndexDsM,
DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,
@@ -72,7 +72,6 @@ import GHC.Driver.Types
import GHC.Data.Bag
import GHC.Types.Basic ( Origin )
import GHC.Core.DataCon
-import GHC.Core.ConLike
import GHC.Core.TyCon
import GHC.HsToCore.Types
import GHC.HsToCore.PmCheck.Types
@@ -302,6 +301,7 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var cc_st_var
(unitState dflags)
(mkHomeUnitFromFlags dflags)
rdr_env
+ , ds_rdr_env = rdr_env
, ds_msgs = msg_var
, ds_complete_matches = complete_matches
, ds_cc_st = cc_st_var
@@ -522,10 +522,8 @@ dsLookupDataCon :: Name -> DsM DataCon
dsLookupDataCon name
= tyThingDataCon <$> dsLookupGlobal name
-dsLookupConLike :: Name -> DsM ConLike
-dsLookupConLike name
- = tyThingConLike <$> dsLookupGlobal name
-
+dsGetGlobalRdrEnv :: DsM GlobalRdrEnv
+dsGetGlobalRdrEnv = ds_rdr_env <$> getGblEnv
dsGetFamInstEnvs :: DsM FamInstEnvs
-- Gets both the external-package inst-env
=====================================
compiler/GHC/HsToCore/PmCheck/Oracle.hs
=====================================
@@ -44,6 +44,7 @@ import GHC.Types.Unique.DSet
import GHC.Types.Unique.DFM
import GHC.Types.Id
import GHC.Types.Name
+import GHC.Types.Name.Reader (GlobalRdrEnv, lookupGRE_Name)
import GHC.Types.Var (EvVar)
import GHC.Types.Var.Env
import GHC.Types.Var.Set
@@ -1737,11 +1738,16 @@ generateInhabitingPatterns (x:xs) n nabla = do
pickApplicableCompleteSets :: Type -> ResidualCompleteMatches -> DsM [ConLikeSet]
pickApplicableCompleteSets ty rcm = do
+ gre <- dsGetGlobalRdrEnv
env <- dsGetFamInstEnvs
- pure $ filter (all (is_valid env) . uniqDSetToList) (getRcm rcm)
+ pure $ filter (all (is_valid gre env) . uniqDSetToList) (getRcm rcm)
where
- is_valid :: FamInstEnvs -> ConLike -> Bool
- is_valid env cl = isJust (guessConLikeUnivTyArgsFromResTy env ty cl)
+ is_valid :: GlobalRdrEnv -> FamInstEnvs -> ConLike -> Bool
+ is_valid gre env cl = isJust (guessConLikeUnivTyArgsFromResTy env ty cl)
+ && isJust (lookupGRE_Name gre (conLikeName cl))
+ -- filter out ConLikes that the User can't write,
+ -- because they aren't imported or not even
+ -- exported. This is #13964.
{- Note [Why inhabitationTest doesn't call generateInhabitingPatterns]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/HsToCore/Types.hs
=====================================
@@ -10,6 +10,7 @@ import Data.IORef
import GHC.Types.CostCentre.State
import GHC.Types.Name.Env
+import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
import GHC.Types.Var
import GHC.Hs (LForeignDecl, HsExpr, GhcTc)
@@ -46,6 +47,8 @@ data DsGblEnv
, ds_msgs :: IORef Messages -- Warning messages
, ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global,
-- possibly-imported things
+ , ds_rdr_env :: GlobalRdrEnv -- ^ Used for looking up whether a
+ -- Name is imported or not
, ds_complete_matches :: CompleteMatches
-- Additional complete pattern matches
, ds_cc_st :: IORef CostCentreState
=====================================
testsuite/tests/pmcheck/complete_sigs/T13964.hs
=====================================
@@ -3,7 +3,7 @@
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
-module Bug (Boolean(F, TooGoodToBeTrue), catchAll) where
+module T13964 (Boolean(F, TooGoodToBeTrue), catchAll) where
data Boolean = F | T
deriving Eq
=====================================
testsuite/tests/pmcheck/complete_sigs/T13964.stderr
=====================================
@@ -1,4 +1,11 @@
+[1 of 2] Compiling T13964 ( T13964.hs, T13964.o )
T13964.hs:18:1: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
In an equation for ‘catchAll’: Patterns not matched: T
+[2 of 2] Compiling T13964b ( T13964b.hs, T13964b.o )
+
+T13964b.hs:6:1: warning: [-Wincomplete-patterns (in -Wextra)]
+ Pattern match(es) are non-exhaustive
+ In an equation for ‘catchAll2’:
+ Patterns not matched: TooGoodToBeTrue
=====================================
testsuite/tests/pmcheck/complete_sigs/T13964b.hs
=====================================
@@ -0,0 +1,7 @@
+module T13964b where
+
+import T13964
+
+catchAll2 :: Boolean -> Int
+catchAll2 F = 0
+-- catchAll2 TooGoodToBeTrue = 1
=====================================
testsuite/tests/pmcheck/complete_sigs/all.T
=====================================
@@ -16,7 +16,7 @@ test('T13021', normal, compile, [''])
test('T13363a', normal, compile, [''])
test('T13363b', normal, compile, [''])
test('T13717', normal, compile, [''])
-test('T13964', normal, compile, [''])
+test('T13964', normal, multimod_compile, ['T13964b', '-W'])
test('T13965', normal, compile, [''])
test('T14059a', normal, compile, [''])
test('T14059b', expect_broken('14059'), compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4421c464b93480dd7eac719c1ef7b81a2a7de8dd
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4421c464b93480dd7eac719c1ef7b81a2a7de8dd
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/20200923/14f0ac62/attachment-0001.html>
More information about the ghc-commits
mailing list