[Git][ghc/ghc][wip/amg/renamer-refactor] 9 commits: Introduce fieldLabelPrintableName
Adam Gundry
gitlab at gitlab.haskell.org
Thu Nov 19 23:19:20 UTC 2020
Adam Gundry pushed to branch wip/amg/renamer-refactor at Glasgow Haskell Compiler / GHC
Commits:
206aab8b by Adam Gundry at 2020-11-19T16:44:13+00:00
Introduce fieldLabelPrintableName
- - - - -
8610da7b by Adam Gundry at 2020-11-19T16:44:43+00:00
Extend DRFHoleFits test to cover case of an imported field label
- - - - -
bc9e6a97 by Adam Gundry at 2020-11-19T22:11:40+00:00
DRFPatSynExport test
- - - - -
f8c531fb by Adam Gundry at 2020-11-19T22:11:57+00:00
Clean up -ddump-minimal-imports
- - - - -
abba93de by Adam Gundry at 2020-11-19T22:13:27+00:00
Cleanup
- - - - -
e23604e9 by Adam Gundry at 2020-11-19T22:29:13+00:00
Add test for DuplicateRecordFields variant of #9156
- - - - -
4ff3c565 by Adam Gundry at 2020-11-19T22:29:43+00:00
Fix DuplicateRecordFields variant of #9156
- - - - -
ea6061c4 by Adam Gundry at 2020-11-19T23:04:59+00:00
Add expect_broken test for #13438
- - - - -
c6d41ff4 by Adam Gundry at 2020-11-19T23:18:48+00:00
Fix printing of some DRF pattern synonyms in errors
- - - - -
22 changed files:
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Tc/Errors/Hole.hs
- compiler/GHC/Tc/Gen/Export.hs
- compiler/GHC/Types/FieldLabel.hs
- compiler/GHC/Types/Name.hs-boot
- compiler/GHC/Types/Name/Reader.hs
- + testsuite/tests/overloadedrecflds/ghci/T13438.hs
- + testsuite/tests/overloadedrecflds/ghci/T13438.script
- + testsuite/tests/overloadedrecflds/ghci/T13438.stdout
- testsuite/tests/overloadedrecflds/ghci/all.T
- + testsuite/tests/overloadedrecflds/should_compile/DRFPatSynExport.hs
- + testsuite/tests/overloadedrecflds/should_compile/DRFPatSynExport.stdout
- + testsuite/tests/overloadedrecflds/should_compile/DRFPatSynExport_A.hs
- + testsuite/tests/overloadedrecflds/should_compile/Makefile
- testsuite/tests/overloadedrecflds/should_compile/all.T
- + testsuite/tests/overloadedrecflds/should_fail/DRF9156.hs
- + testsuite/tests/overloadedrecflds/should_fail/DRF9156.stderr
- testsuite/tests/overloadedrecflds/should_fail/DRFHoleFits.hs
- testsuite/tests/overloadedrecflds/should_fail/DRFHoleFits.stderr
- + testsuite/tests/overloadedrecflds/should_fail/DRFHoleFits_A.hs
- testsuite/tests/overloadedrecflds/should_fail/all.T
Changes:
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1873,8 +1873,8 @@ instance ToHie (Located (TyFamInstDecl GhcRn)) where
instance HiePass p => ToHie (Context (FieldOcc (GhcPass p))) where
toHie (C c (FieldOcc n (L l _))) = case hiePass @p of
- HieTc -> toHie (C c (L l n)) -- AMG TODO: probably wrong
- HieRn -> toHie (C c (L l n)) -- AMG TODO: probably wrong
+ HieTc -> toHie (C c (L l n))
+ HieRn -> toHie (C c (L l n))
instance HiePass p => ToHie (PatSynFieldContext (RecordPatSynField (GhcPass p))) where
toHie (PSC sp (RecordPatSynField a b)) = concatM $
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -666,9 +666,11 @@ extendGlobalRdrEnvRn avails new_fixities
occ = greOccName gre
dups = filter isDupGRE (lookupGlobalRdrEnv env occ)
-- Duplicate GREs are those defined locally with the same OccName,
- -- except cases where *both* GREs are DuplicateRecordFields (#17965).
+ -- except cases where *both* GREs are DuplicateRecordFields (#17965)
+ -- that are distinct (#9156).
isDupGRE gre' = isLocalGRE gre'
- && not (isOverloadedRecFldGRE gre && isOverloadedRecFldGRE gre')
+ && (not (isOverloadedRecFldGRE gre && isOverloadedRecFldGRE gre')
+ || (gre_child gre == gre_child gre'))
{- *********************************************************************
@@ -1635,8 +1637,8 @@ getMinimalImports = fmap combine . mapM mk_minimal
-- to say "T(A,B,C)". So we have to find out what the module exports.
to_ie _ (Avail n)
= [IEVar noExtField (to_ie_post_rn $ noLoc n)]
- to_ie _ (AvailFL fl)
- = [IEVar noExtField (to_ie_post_rn $ noLoc (flSelector fl))] -- AMG TODO Probably wrong
+ to_ie _ (AvailFL fl) -- Note [Overloaded field import]
+ = [IEVar noExtField (to_ie_post_rn $ noLoc (fieldLabelPrintableName fl))]
to_ie _ (AvailTC n [m] [])
| n==m = [IEThingAbs noExtField (to_ie_post_rn $ noLoc n)]
to_ie iface (AvailTC n ns fs)
@@ -1762,6 +1764,23 @@ then the minimal import for module B must be
because when DuplicateRecordFields is enabled, field selectors are
not in scope without their enclosing datatype.
+On the third hand, if we have
+
+ {-# LANGUAGE DuplicateRecordFields #-}
+ module A where
+ pattern MkT { foo } = Just foo
+
+ module B where
+ import A
+ f = ...foo...
+
+then the minimal import for module B must be
+ import A ( foo )
+because foo doesn't have a parent. This might actually be ambiguous if A
+exports another field called foo, but there is no good answer to return and this
+is a very obscure corner, so it seems to be the best we can do. See
+DRFPatSynExport for a test of this.
+
************************************************************************
* *
=====================================
compiler/GHC/Tc/Errors/Hole.hs
=====================================
@@ -23,8 +23,7 @@ import GHC.Core.Type
import GHC.Core.DataCon
import GHC.Types.Name
import GHC.Types.Name.Reader ( pprNameProvenance , GlobalRdrElt (..)
- , globalRdrEnvElts, gre_name
- , isOverloadedRecFldGRE )
+ , globalRdrEnvElts, gre_name, grePrintableName )
import GHC.Builtin.Names ( gHC_ERR )
import GHC.Types.Id
import GHC.Types.Var.Set
@@ -473,9 +472,7 @@ pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (HoleFit {..}) =
holeDisp = if sMs then holeVs
else sep $ replicate (length hfMatches) $ text "_"
occDisp = case hfCand of
- -- AMG TODO: make OutputableBndr GlobalRdrElt instance that does the right thing?
- GreHFCand gre | isOverloadedRecFldGRE gre -> pprPrefixOcc (occName gre)
- | otherwise -> pprPrefixOcc (gre_name gre)
+ GreHFCand gre -> pprPrefixOcc (grePrintableName gre)
NameHFCand name -> pprPrefixOcc name
IdHFCand id_ -> pprPrefixOcc id_
tyDisp = ppWhen sTy $ dcolon <+> ppr hfType
=====================================
compiler/GHC/Tc/Gen/Export.hs
=====================================
@@ -613,11 +613,11 @@ checkPatSynParent parent NoParent child
; case mpat_syn_thing of
AnId i | isId i
, RecSelId { sel_tycon = RecSelPatSyn p } <- idDetails i
- -> handle_pat_syn (selErr i) parent_ty_con p
+ -> handle_pat_syn (selErr child) parent_ty_con p
AConLike (PatSynCon p) -> handle_pat_syn (psErr p) parent_ty_con p
- _ -> failWithDcErr parent mpat_syn (ppr mpat_syn) [] }
+ _ -> failWithDcErr parent mpat_syn (ppr child) [] }
where
psErr = exportErrCtxt "pattern synonym"
selErr = exportErrCtxt "pattern synonym record selector"
=====================================
compiler/GHC/Types/FieldLabel.hs
=====================================
@@ -69,6 +69,7 @@ module GHC.Types.FieldLabel
, FieldLbl(..)
, FieldLabel
, mkFieldLabelOccs
+ , fieldLabelPrintableName
)
where
@@ -134,3 +135,12 @@ mkFieldLabelOccs lbl dc is_overloaded
str = ":" ++ unpackFS lbl ++ ":" ++ occNameString dc
sel_occ | is_overloaded = mkRecFldSelOcc str
| otherwise = mkVarOccFS lbl
+
+-- | Undo the name mangling described in Note [FieldLabel] to produce a Name
+-- that has the user-visible OccName (but the selector's unique). This should
+-- be used only when generating output, when we want to show the label, but may
+-- need to qualify it with a module prefix.
+fieldLabelPrintableName :: FieldLabel -> Name
+fieldLabelPrintableName fl
+ | flIsOverloaded fl = tidyNameOcc (flSelector fl) (mkVarOccFS (flLabel fl))
+ | otherwise = flSelector fl
=====================================
compiler/GHC/Types/Name.hs-boot
=====================================
@@ -22,3 +22,4 @@ class NamedThing a where
nameUnique :: Name -> Unique
setNameUnique :: Name -> Unique -> Name
nameOccName :: Name -> OccName
+tidyNameOcc :: Name -> OccName -> Name
=====================================
compiler/GHC/Types/Name/Reader.hs
=====================================
@@ -57,7 +57,7 @@ module GHC.Types.Name.Reader (
greRdrNames, greSrcSpan, greQualModName,
gresToAvailInfo,
greDefinitionModule, greDefinitionSrcSpan,
- gre_name,
+ gre_name, grePrintableName,
-- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec'
GlobalRdrElt(..), isLocalGRE, isRecFldGRE, isOverloadedRecFldGRE, greLabel,
@@ -656,6 +656,13 @@ gre_name gre = case gre_child gre of
ChildName name -> name
ChildField fl -> flSelector fl
+-- | A Name for the GRE's child suitable for output to the user. Its OccName
+-- will be the greOccName.
+grePrintableName :: GlobalRdrElt -> Name
+grePrintableName gre = case gre_child gre of
+ ChildName name -> name
+ ChildField fl -> fieldLabelPrintableName fl
+
-- | The SrcSpan of the name pointed to by the GRE.
greDefinitionSrcSpan :: GlobalRdrElt -> SrcSpan
greDefinitionSrcSpan = childSrcSpan . gre_child
@@ -750,10 +757,10 @@ gresToAvailInfo gres
comb :: GlobalRdrElt -> AvailInfo -> AvailInfo
comb _ (Avail n) = Avail n -- Duplicated name, should not happen
- comb _ (AvailFL fl) = AvailFL fl -- AMG TODO: shouldn't happen either?
+ comb _ (AvailFL fl) = AvailFL fl
comb gre (AvailTC m ns fls)
= case (gre_par gre, gre_child gre) of
- (NoParent, ChildName me) -> AvailTC m (me:ns) fls -- Not sure this ever happens -- AMG TODO: AvailTC invariant?
+ (NoParent, ChildName me) -> AvailTC m (me:ns) fls -- Not sure this ever happens
(NoParent, ChildField fl) -> AvailTC m ns (fl:fls)
(ParentIs {}, ChildName me) -> AvailTC m (insertChildIntoChildren m ns me) fls
(ParentIs {}, ChildField fl) -> AvailTC m ns (fl:fls)
=====================================
testsuite/tests/overloadedrecflds/ghci/T13438.hs
=====================================
@@ -0,0 +1,3 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+module T13438 where
+data T = MkT { foo :: Int }
=====================================
testsuite/tests/overloadedrecflds/ghci/T13438.script
=====================================
@@ -0,0 +1,5 @@
+:l T13438.hs
+:browse! T13438
+:browse T13438
+:ctags
+:!cat tags
=====================================
testsuite/tests/overloadedrecflds/ghci/T13438.stdout
=====================================
@@ -0,0 +1,10 @@
+-- defined locally
+type T :: *
+data T = ...
+MkT :: Int -> T
+foo :: T -> Int
+type T :: *
+data T = MkT {foo :: Int}
+foo T13438.hs 3;" v file:
+MkT T13438.hs 3;" d
+T T13438.hs 3;" t
=====================================
testsuite/tests/overloadedrecflds/ghci/all.T
=====================================
@@ -1,2 +1,3 @@
test('duplicaterecfldsghci01', combined_output, ghci_script, ['duplicaterecfldsghci01.script'])
test('overloadedlabelsghci01', combined_output, ghci_script, ['overloadedlabelsghci01.script'])
+test('T13438', [expect_broken(13438), combined_output], ghci_script, ['T13438.script'])
=====================================
testsuite/tests/overloadedrecflds/should_compile/DRFPatSynExport.hs
=====================================
@@ -0,0 +1,4 @@
+{-# LANGUAGE DisambiguateRecordFields #-}
+module DRFPatSynExport where
+import DRFPatSynExport_A
+v = MkT { m = () }
=====================================
testsuite/tests/overloadedrecflds/should_compile/DRFPatSynExport.stdout
=====================================
@@ -0,0 +1,3 @@
+[1 of 2] Compiling DRFPatSynExport_A ( DRFPatSynExport_A.hs, DRFPatSynExport_A.o )
+[2 of 2] Compiling DRFPatSynExport ( DRFPatSynExport.hs, DRFPatSynExport.o )
+import DRFPatSynExport_A ( MkT, m )
=====================================
testsuite/tests/overloadedrecflds/should_compile/DRFPatSynExport_A.hs
=====================================
@@ -0,0 +1,5 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE PatternSynonyms #-}
+module DRFPatSynExport_A where
+data S = MkS { m :: Int }
+pattern MkT { m } = m
=====================================
testsuite/tests/overloadedrecflds/should_compile/Makefile
=====================================
@@ -0,0 +1,3 @@
+DRFPatSynExport:
+ '$(TEST_HC)' $(TEST_HC_OPTS) DRFPatSynExport.hs -fforce-recomp -ddump-minimal-imports
+ cat DRFPatSynExport.imports
=====================================
testsuite/tests/overloadedrecflds/should_compile/all.T
=====================================
@@ -2,3 +2,4 @@ test('T11173', [], multimod_compile, ['T11173', '-v0'])
test('T12609', normal, compile, [''])
test('T16597', [], multimod_compile, ['T16597', '-v0'])
test('T17176', normal, compile, [''])
+test('DRFPatSynExport', [], makefile_test, ['DRFPatSynExport'])
=====================================
testsuite/tests/overloadedrecflds/should_fail/DRF9156.hs
=====================================
@@ -0,0 +1,4 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+module DRF9156 where
+data D = D1 { f1 :: Int }
+ | D2 { f1, f1 :: Int }
=====================================
testsuite/tests/overloadedrecflds/should_fail/DRF9156.stderr
=====================================
@@ -0,0 +1,5 @@
+
+DRF9156.hs:4:19: error:
+ Multiple declarations of ‘f1’
+ Declared at: DRF9156.hs:3:15
+ DRF9156.hs:4:19
=====================================
testsuite/tests/overloadedrecflds/should_fail/DRFHoleFits.hs
=====================================
@@ -1,7 +1,8 @@
{-# LANGUAGE DuplicateRecordFields #-}
-
module DRFHoleFits where
+import qualified DRFHoleFits_A as A
data T = MkT { foo :: Int }
bar = _ :: T -> Int
+baz = _ :: A.S -> Int
=====================================
testsuite/tests/overloadedrecflds/should_fail/DRFHoleFits.stderr
=====================================
@@ -1,3 +1,5 @@
+[1 of 2] Compiling DRFHoleFits_A ( DRFHoleFits_A.hs, DRFHoleFits_A.o )
+[2 of 2] Compiling DRFHoleFits ( DRFHoleFits.hs, DRFHoleFits.o )
DRFHoleFits.hs:7:7: error:
• Found hole: _ :: T -> Int
@@ -8,3 +10,15 @@ DRFHoleFits.hs:7:7: error:
Valid hole fits include
foo :: T -> Int (defined at DRFHoleFits.hs:5:16)
bar :: T -> Int (defined at DRFHoleFits.hs:7:1)
+
+DRFHoleFits.hs:8:7: error:
+ • Found hole: _ :: A.S -> Int
+ • In the expression: _ :: A.S -> Int
+ In an equation for ‘baz’: baz = _ :: A.S -> Int
+ • Relevant bindings include
+ baz :: A.S -> Int (bound at DRFHoleFits.hs:8:1)
+ Valid hole fits include
+ baz :: A.S -> Int (defined at DRFHoleFits.hs:8:1)
+ DRFHoleFits_A.foo :: A.S -> Int
+ (imported qualified from ‘DRFHoleFits_A’ at DRFHoleFits.hs:3:1-35
+ (and originally defined at DRFHoleFits_A.hs:5:16-18))
=====================================
testsuite/tests/overloadedrecflds/should_fail/DRFHoleFits_A.hs
=====================================
@@ -0,0 +1,6 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module DRFHoleFits_A where
+
+data S = MkS { foo :: Int }
+data U = MkU { foo :: Int }
=====================================
testsuite/tests/overloadedrecflds/should_fail/all.T
=====================================
@@ -33,6 +33,7 @@ test('T14953', [extra_files(['T14953_A.hs', 'T14953_B.hs'])],
multimod_compile_fail, ['T14953', ''])
test('DuplicateExports', normal, compile_fail, [''])
test('T17965', normal, compile_fail, [''])
-test('DRFHoleFits', normal, compile_fail, [''])
+test('DRFHoleFits', extra_files(['DRFHoleFits_A.hs']), multimod_compile_fail, ['DRFHoleFits', ''])
test('DRFPartialFields', normal, compile_fail, [''])
test('T16745', extra_files(['T16745C.hs', 'T16745B.hs']), multimod_compile_fail, ['T16745A', ''])
+test('DRF9156', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5ceb206d45d7754acedc917af07e7a0646c0ef41...c6d41ff494ef93d5dadc53f0842f109146f36760
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5ceb206d45d7754acedc917af07e7a0646c0ef41...c6d41ff494ef93d5dadc53f0842f109146f36760
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/20201119/104b5a1d/attachment-0001.html>
More information about the ghc-commits
mailing list