[Git][ghc/ghc][master] Renamer: don't call addUsedGRE on an exact Name
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sat Apr 8 02:30:25 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
3ba77b36 by sheaf at 2023-04-07T22:30:07-04:00
Renamer: don't call addUsedGRE on an exact Name
When looking up a record field in GHC.Rename.Env.lookupRecFieldOcc,
we could end up calling addUsedGRE on an exact Name, which would then
lead to a panic in the bestImport function: it would be incapable of
processing a GRE which is not local but also not brought into scope
by any imports (as it is referred to by its unique instead).
Fixes #23240
- - - - -
6 changed files:
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Types/Name/Reader.hs
- + testsuite/tests/rename/should_compile/T23240.hs
- + testsuite/tests/rename/should_compile/T23240_aux.hs
- testsuite/tests/rename/should_compile/all.T
Changes:
=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -534,30 +534,29 @@ lookupRecFieldOcc mb_con rdr_name
= return $ mk_unbound_rec_fld con
| Just con <- mb_con
= do { let lbl = FieldLabelString $ occNameFS (rdrNameOcc rdr_name)
- ; res <- lookupExactOrOrig rdr_name ensure_recfld $ -- See Note [Record field names and Template Haskell]
+ ; mb_nm <- lookupExactOrOrig rdr_name ensure_recfld $ -- See Note [Record field names and Template Haskell]
do { flds <- lookupConstructorFields con
; env <- getGlobalRdrEnv
- ; let lbl = FieldLabelString $ occNameFS (rdrNameOcc rdr_name)
- mb_gre = do fl <- find ((== lbl) . flLabel) flds
+ ; let mb_gre = do fl <- find ((== lbl) . flLabel) flds
-- We have the label, now check it is in scope. If
-- there is a qualifier, use pickGREs to check that
-- the qualifier is correct, and return the filtered
-- GRE so we get import usage right (see #17853).
gre <- lookupGRE_FieldLabel env fl
if isQual rdr_name
- then listToMaybe (pickGREs rdr_name [gre])
+ then listToMaybe $ pickGREs rdr_name [gre]
else return gre
; traceRn "lookupRecFieldOcc" $
vcat [ text "mb_con:" <+> ppr mb_con
, text "rdr_name:" <+> ppr rdr_name
, text "flds:" <+> ppr flds
, text "mb_gre:" <+> ppr mb_gre ]
- ; return mb_gre }
- ; case res of
+ ; mapM_ (addUsedGRE True) mb_gre
+ ; return $ flSelector . fieldGRELabel <$> mb_gre }
+ ; case mb_nm of
{ Nothing -> do { addErr (badFieldConErr con lbl)
; return $ mk_unbound_rec_fld con }
- ; Just gre -> do { addUsedGRE True gre
- ; return (flSelector $ fieldGRELabel gre) } } }
+ ; Just nm -> return nm } }
| otherwise -- Can't use the data constructor to disambiguate
= greName <$> lookupGlobalOccRn' (IncludeFields WantField) rdr_name
@@ -572,7 +571,9 @@ lookupRecFieldOcc mb_con rdr_name
mkRecFieldOccFS (getOccFS con) (occNameFS occ)
occ = rdrNameOcc rdr_name
- ensure_recfld gre = do { guard (isRecFldGRE gre) ; return gre }
+ ensure_recfld :: GlobalRdrElt -> Maybe Name
+ ensure_recfld gre = do { guard (isRecFldGRE gre)
+ ; return $ greName gre }
{- Note [DisambiguateRecordFields]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -1855,7 +1855,10 @@ mkImportMap gres
RealSrcLoc decl_loc _ -> Map.insertWith add decl_loc [gre] imp_map
UnhelpfulLoc _ -> imp_map
where
- best_imp_spec = bestImport (bagToList imp_specs)
+ best_imp_spec =
+ case bagToList imp_specs of
+ [] -> pprPanic "mkImportMap: GRE with no ImportSpecs" (ppr gre)
+ is:iss -> bestImport (is NE.:| iss)
add _ gres = gre : gres
warnUnusedImport :: WarningFlag -> GlobalRdrEnv
=====================================
compiler/GHC/Types/Name/Reader.hs
=====================================
@@ -126,7 +126,6 @@ import GHC.Utils.Panic
import Control.DeepSeq
import Control.Monad ( guard )
import Data.Data
-import Data.List ( sortBy )
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import qualified Data.Semigroup as S
@@ -1654,12 +1653,9 @@ data ImpItemSpec
-- only @T@ is named explicitly.
deriving (Eq, Data)
-bestImport :: [ImportSpec] -> ImportSpec
+bestImport :: NE.NonEmpty ImportSpec -> ImportSpec
-- See Note [Choosing the best import declaration]
-bestImport iss
- = case sortBy best iss of
- (is:_) -> is
- [] -> pprPanic "bestImport" (ppr iss)
+bestImport iss = NE.head $ NE.sortBy best iss
where
best :: ImportSpec -> ImportSpec -> Ordering
-- Less means better
=====================================
testsuite/tests/rename/should_compile/T23240.hs
=====================================
@@ -0,0 +1,14 @@
+{-# LANGUAGE Haskell2010 #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+-- Crucial to triggering the bug.
+{-# LANGUAGE DisambiguateRecordFields #-}
+
+-- Need to enable the unused imports warning to trigger the bug.
+{-# OPTIONS_GHC -Wunused-imports #-}
+
+module T23240 ( test ) where
+import T23240_aux ( D, mkD )
+
+test :: D
+test = $$mkD
=====================================
testsuite/tests/rename/should_compile/T23240_aux.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE Haskell2010 #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module T23240_aux where
+
+import Language.Haskell.TH ( CodeQ )
+
+data D = MkD { myFld :: () }
+mkD :: CodeQ D
+mkD = [|| MkD { myFld = () } ||]
=====================================
testsuite/tests/rename/should_compile/all.T
=====================================
@@ -209,3 +209,4 @@ test('ImportNullaryRecordWildcard', [extra_files(['NullaryRecordWildcard.hs', 'N
test('GHCINullaryRecordWildcard', combined_output, ghci_script, ['GHCINullaryRecordWildcard.script'])
test('GHCIImplicitImportNullaryRecordWildcard', combined_output, ghci_script, ['GHCIImplicitImportNullaryRecordWildcard.script'])
test('T22122', [expect_broken(22122), extra_files(['T22122_aux.hs'])], multimod_compile, ['T22122', '-v0'])
+test('T23240', [req_th, extra_files(['T23240_aux.hs'])], multimod_compile, ['T23240', '-v0'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3ba77b369a170ba68f4eb5c8f3ae13e03dcbb28d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3ba77b369a170ba68f4eb5c8f3ae13e03dcbb28d
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/20230407/eecf49ff/attachment-0001.html>
More information about the ghc-commits
mailing list