PmCheck: Only suggest imported ConLikes for missing patterns (#13964)wip/T13964

We simply `lookupGRE_Name` every `ConLike` of a `COMPLETE` set before
suggesting it.

Fixes #13964.

7 files changed, 33 insertions, 12 deletions

diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs
index 0c9717d4eb..cffce7c3be 100644
--- a/compiler/GHC/HsToCore/Monad.hs
+++ b/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
diff --git a/compiler/GHC/HsToCore/PmCheck/Oracle.hs b/compiler/GHC/HsToCore/PmCheck/Oracle.hs
index fd76bcf70d..ee845c34be 100644
--- a/compiler/GHC/HsToCore/PmCheck/Oracle.hs
+++ b/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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/HsToCore/Types.hs b/compiler/GHC/HsToCore/Types.hs
index d6fd94e723..a3b84a99e8 100644
--- a/compiler/GHC/HsToCore/Types.hs
+++ b/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
diff --git a/testsuite/tests/pmcheck/complete_sigs/T13964.hs b/testsuite/tests/pmcheck/complete_sigs/T13964.hs
index 36a87a9a25..88ffbd4791 100644
--- a/testsuite/tests/pmcheck/complete_sigs/T13964.hs
+++ b/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
diff --git a/testsuite/tests/pmcheck/complete_sigs/T13964.stderr b/testsuite/tests/pmcheck/complete_sigs/T13964.stderr
index 606756a783..4b3fb6a46d 100644
--- a/testsuite/tests/pmcheck/complete_sigs/T13964.stderr
+++ b/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
diff --git a/testsuite/tests/pmcheck/complete_sigs/T13964b.hs b/testsuite/tests/pmcheck/complete_sigs/T13964b.hs
new file mode 100644
index 0000000000..e5248b0093
--- /dev/null
+++ b/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
diff --git a/testsuite/tests/pmcheck/complete_sigs/all.T b/testsuite/tests/pmcheck/complete_sigs/all.T
index 2728121160..da81cfa94e 100644
--- a/testsuite/tests/pmcheck/complete_sigs/all.T
+++ b/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, [''])