diff options
Diffstat (limited to 'compiler/GHC/HsToCore')
| -rw-r--r-- | compiler/GHC/HsToCore/Monad.hs | 12 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/PmCheck/Oracle.hs | 12 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Types.hs | 3 |
3 files changed, 17 insertions, 10 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 |