[Git][ghc/ghc][wip/amg/renamer-refactor] Simplify definition of AvailInfo
Adam Gundry
gitlab at gitlab.haskell.org
Tue Dec 1 09:32:47 UTC 2020
Adam Gundry pushed to branch wip/amg/renamer-refactor at Glasgow Haskell Compiler / GHC
Commits:
655acd4d by Adam Gundry at 2020-12-01T09:30:11+00:00
Simplify definition of AvailInfo
This bumps the haddock submodule.
- - - - -
13 changed files:
- compiler/GHC/Builtin/Utils.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Rename.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Tc/Gen/Export.hs
- compiler/GHC/Types/Avail.hs
- compiler/GHC/Types/Name/Reader.hs
- compiler/GHC/Types/Name/Shape.hs
- compiler/GHC/Types/TyThing.hs
- testsuite/tests/parser/should_compile/T14189.stderr
- utils/haddock
Changes:
=====================================
compiler/GHC/Builtin/Utils.hs
=====================================
@@ -265,7 +265,7 @@ ghcPrimExports :: [IfaceExport]
ghcPrimExports
= map (avail . idName) ghcPrimIds ++
map (avail . idName . primOpId) allThePrimOps ++
- [ AvailTC n [n] []
+ [ availTC n [n] []
| tc <- exposedPrimTyCons, let n = tyConName tc ]
ghcPrimDeclDocs :: DeclDocMap
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -87,7 +87,6 @@ import GHC.Types.TypeEnv
import GHC.Types.Unique.FM
import GHC.Types.Unique.DSet
import GHC.Types.SrcLoc
-import GHC.Types.FieldLabel
import GHC.Types.TyThing
import GHC.Unit.External
@@ -1120,16 +1119,16 @@ When printing export lists, we print like this:
-}
pprExport :: IfaceExport -> SDoc
-pprExport (Avail n) = ppr n
-pprExport (AvailFL fl) = ppr fl
-pprExport (AvailTC _ [] []) = Outputable.empty
-pprExport (AvailTC n ns0 fs)
- = case ns0 of
- (n':ns) | n==n' -> ppr n <> pp_export ns fs
- _ -> ppr n <> vbar <> pp_export ns0 fs
+pprExport (Avail n) = ppr n
+pprExport (AvailTC _ []) = Outputable.empty
+pprExport avail@(AvailTC n _) =
+ ppr n <> mark <> pp_export (availSubordinateChildren avail)
where
- pp_export [] [] = Outputable.empty
- pp_export names fs = braces (hsep (map ppr names ++ map (ppr . flLabel) fs))
+ mark | availExportsDecl avail = Outputable.empty
+ | otherwise = vbar
+
+ pp_export [] = Outputable.empty
+ pp_export names = braces (hsep (map ppr names))
pprUsage :: Usage -> SDoc
pprUsage usage at UsagePackageModule{}
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -372,15 +372,12 @@ mkIfaceExports exports
where
sort_subs :: AvailInfo -> AvailInfo
sort_subs (Avail n) = Avail n
- sort_subs (AvailFL fl) = AvailFL fl
- sort_subs (AvailTC n [] fs) = AvailTC n [] (sort_flds fs)
- sort_subs (AvailTC n (m:ms) fs)
- | n==m = AvailTC n (m:sortBy stableNameCmp ms) (sort_flds fs)
- | otherwise = AvailTC n (sortBy stableNameCmp (m:ms)) (sort_flds fs)
+ sort_subs (AvailTC n []) = AvailTC n []
+ sort_subs (AvailTC n (m:ms))
+ | ChildName n==m = AvailTC n (m:sortBy stableChildCmp ms)
+ | otherwise = AvailTC n (sortBy stableChildCmp (m:ms))
-- Maintain the AvailTC Invariant
- sort_flds = sortBy (stableNameCmp `on` flSelector)
-
{-
Note [Original module]
~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Iface/Rename.hs
=====================================
@@ -242,21 +242,25 @@ rnModule mod = do
return (renameHoleModule (unitState dflags) hmap mod)
rnAvailInfo :: Rename AvailInfo
-rnAvailInfo (Avail n) = Avail <$> rnIfaceGlobal n
-rnAvailInfo (AvailFL fl) = AvailFL <$> rnFieldLabel fl
-rnAvailInfo (AvailTC n ns fs) = do
+rnAvailInfo (Avail c) = Avail <$> rnChild c
+rnAvailInfo (AvailTC n ns) = do
-- Why don't we rnIfaceGlobal the availName itself? It may not
-- actually be exported by the module it putatively is from, in
-- which case we won't be able to tell what the name actually
-- is. But for the availNames they MUST be exported, so they
-- will rename fine.
- ns' <- mapM rnIfaceGlobal ns
- fs' <- mapM rnFieldLabel fs
- case ns' ++ map flSelector fs' of
+ ns' <- mapM rnChild ns
+ case ns' of
[] -> panic "rnAvailInfoEmpty AvailInfo"
- (rep:rest) -> ASSERT2( all ((== nameModule rep) . nameModule) rest, ppr rep $$ hcat (map ppr rest) ) do
- n' <- setNameModule (Just (nameModule rep)) n
- return (AvailTC n' ns' fs')
+ (rep:rest) -> ASSERT2( all ((== childModule rep) . childModule) rest, ppr rep $$ hcat (map ppr rest) ) do
+ n' <- setNameModule (Just (childModule rep)) n
+ return (AvailTC n' ns')
+ where
+ childModule = nameModule . childName
+
+rnChild :: Rename Child
+rnChild (ChildName n) = ChildName <$> rnIfaceGlobal n
+rnChild (ChildField fl) = ChildField <$> rnFieldLabel fl
rnFieldLabel :: Rename FieldLabel
rnFieldLabel (FieldLabel l b sel) = do
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -2279,7 +2279,7 @@ extendPatSynEnv val_decls local_fix_env thing = do {
; let pat_syn_bndrs = concat [ name: map flSelector fields
| (name, fields) <- names_with_fls ]
; let avails = map avail (map fst names_with_fls)
- ++ map AvailFL (concatMap snd names_with_fls)
+ ++ map availField (concatMap snd names_with_fls)
; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env
; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -762,7 +762,7 @@ getLocalNonValBinders fixity_env
; let fld_env = case unLoc tc_decl of
DataDecl { tcdDataDefn = d } -> mk_fld_env d names flds'
_ -> []
- ; return (AvailTC main_name names flds', fld_env) }
+ ; return (availTC main_name names flds', fld_env) }
-- Calculate the mapping from constructor names to fields, which
@@ -837,7 +837,7 @@ getLocalNonValBinders fixity_env
; let (bndrs, flds) = hsDataFamInstBinders dfid
; sub_names <- mapM newTopSrcBinder bndrs
; flds' <- mapM (newRecordSelector overload_ok sub_names) flds
- ; let avail = AvailTC (unLoc main_name) sub_names flds'
+ ; let avail = availTC (unLoc main_name) sub_names flds'
-- main_name is not bound here!
fld_env = mk_fld_env (feqn_rhs ti_decl) sub_names flds'
; return (avail, fld_env) }
@@ -976,8 +976,8 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
-- 'combine' may also be called for pattern synonyms which appear both
-- unassociated and associated (#11959)
combine :: (Child, AvailInfo, Maybe Name) -> (Child, AvailInfo, Maybe Name) -> (Child, AvailInfo, Maybe Name)
- combine (ChildName name1, a1@(AvailTC p1 _ _), mb1)
- (ChildName name2, a2@(AvailTC p2 _ _), mb2)
+ combine (ChildName name1, a1@(AvailTC p1 _), mb1)
+ (ChildName name2, a2@(AvailTC p2 _), mb2)
= ASSERT2( name1 == name2 && isNothing mb1 && isNothing mb2
, ppr name1 <+> ppr name2 <+> ppr mb1 <+> ppr mb2 )
if p1 == name1 then (ChildName name1, a1, Just p2)
@@ -1055,11 +1055,8 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
Avail {} -- e.g. f(..)
-> [DodgyImport $ ieWrappedName tc]
- AvailFL {} -- e.g. f(..)
- -> [DodgyImport $ ieWrappedName tc]
-
- AvailTC _ subs fs
- | null (drop 1 subs) && null fs -- e.g. T(..) where T is a synonym
+ AvailTC _ subs
+ | null (drop 1 subs) -- e.g. T(..) where T is a synonym
-> [DodgyImport $ ieWrappedName tc]
| not (is_qual decl_spec) -- e.g. import M( T(..) )
@@ -1070,13 +1067,12 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
renamed_ie = IEThingAll noExtField (L l (replaceWrappedName tc name))
sub_avails = case avail of
- Avail {} -> []
- AvailFL {} -> []
- AvailTC name2 subs fs -> [(renamed_ie, AvailTC name2 (subs \\ [name]) fs)]
+ Avail {} -> []
+ AvailTC name2 subs -> [(renamed_ie, AvailTC name2 (subs \\ [ChildName name]))]
case mb_parent of
Nothing -> return ([(renamed_ie, avail)], warns)
-- non-associated ty/cls
- Just parent -> return ((renamed_ie, AvailTC parent [name] []) : sub_avails, warns)
+ Just parent -> return ((renamed_ie, AvailTC parent [ChildName name]) : sub_avails, warns)
-- associated type
IEThingAbs _ (L l tc')
@@ -1100,19 +1096,9 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
(name, avail, mb_parent)
<- lookup_name (IEThingAbs noExtField ltc) (ieWrappedName rdr_tc)
- let (ns,subflds) = case avail of
- AvailTC _ ns' subflds' -> (ns',subflds')
- Avail _ -> panic "filterImports"
- AvailFL {} -> pprPanic "filterImports" (ppr avail)
-
-- Look up the children in the sub-names of the parent
- let subnames = case ns of -- The tc is first in ns,
- [] -> [] -- if it is there at all
- -- See the AvailTC Invariant in
- -- GHC.Types.Avail
- (n1:ns1) | n1 == name -> ns1
- | otherwise -> ns
- case lookupChildren (map ChildName subnames ++ map ChildField subflds) rdr_ns of
+ let subnames = availSubordinateChildren avail
+ case lookupChildren subnames rdr_ns of
Failed rdrs -> failLookupWith (BadImport (IEThingWith xt ltc wc rdrs []))
-- We are trying to import T( a,b,c,d ), and failed
@@ -1126,7 +1112,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
Nothing
-> return ([(IEThingWith noExtField (L l name') wc childnames'
childflds,
- AvailTC name (name:map unLoc childnames) (map unLoc childflds))],
+ availTC name (name:map unLoc childnames) (map unLoc childflds))],
[])
where name' = replaceWrappedName rdr_tc name
childnames' = map to_ie_post_rn childnames
@@ -1135,10 +1121,10 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
Just parent
-> return ([(IEThingWith noExtField (L l name') wc childnames'
childflds,
- AvailTC name (map unLoc childnames) (map unLoc childflds)),
+ availTC name (map unLoc childnames) (map unLoc childflds)),
(IEThingWith noExtField (L l name') wc childnames'
childflds,
- AvailTC parent [name] [])],
+ availTC parent [name] [])],
[])
where name' = replaceWrappedName rdr_tc name
childnames' = map to_ie_post_rn childnames
@@ -1152,7 +1138,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
= (IEThingAbs noExtField (L l (replaceWrappedName tc n)), trimAvail av n)
mkIEThingAbs tc l (n, _, Just parent)
= (IEThingAbs noExtField (L l (replaceWrappedName tc n))
- , AvailTC parent [n] [])
+ , availTC parent [n] [])
handle_bad_import m = catchIELookup m $ \err -> case err of
BadImport ie | want_hiding -> return ([], [BadImportW ie])
@@ -1635,16 +1621,14 @@ getMinimalImports = fmap combine . mapM mk_minimal
-- The main trick here is that if we're importing all the constructors
-- we want to say "T(..)", but if we're importing only a subset we want
-- 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) -- 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)
- = case [(xs,gs) | AvailTC x xs gs <- mi_exports iface
+ to_ie _ (Avail c) -- Note [Overloaded field import]
+ = [IEVar noExtField (to_ie_post_rn $ noLoc (childPrintableName c))]
+ to_ie _ avail@(AvailTC n [_]) -- Exporting the main decl and nothing else
+ | availExportsDecl avail = [IEThingAbs noExtField (to_ie_post_rn $ noLoc n)]
+ to_ie iface (AvailTC n cs)
+ = case [xs | avail@(AvailTC x xs) <- mi_exports iface
, x == n
- , x `elem` xs -- Note [Partial export]
+ , availExportsDecl avail -- Note [Partial export]
] of
[xs] | all_used xs -> [IEThingAll noExtField (to_ie_post_rn $ noLoc n)]
| otherwise ->
@@ -1660,12 +1644,9 @@ getMinimalImports = fmap combine . mapM mk_minimal
(map (to_ie_post_rn . noLoc) (filter (/= n) ns))
(map noLoc fs)]
where
+ (ns, fs) = partitionChildren cs
- fld_lbls = map flLabel fs
-
- all_used (avail_occs, avail_flds)
- = all (`elem` ns) avail_occs
- && all (`elem` fld_lbls) (map flLabel avail_flds)
+ all_used avail_cs = all (`elem` cs) avail_cs
all_non_overloaded = all (not . flIsOverloaded)
@@ -1744,7 +1725,7 @@ Then the minimal import for module B is
not
import A( C( op ) )
which we would usually generate if C was exported from B. Hence
-the (x `elem` xs) test when deciding what to generate.
+the availExportsDecl test when deciding what to generate.
Note [Overloaded field import]
@@ -1799,9 +1780,8 @@ ambiguousImportItemErr rdr avails
= hang (text "Ambiguous name" <+> quotes (ppr rdr) <+> text "in import item. It could refer to:")
2 (vcat (map ppr_avail avails))
where
- ppr_avail (AvailTC parent _ _) = ppr parent <> parens (ppr rdr)
- ppr_avail (Avail name) = ppr name
- ppr_avail (AvailFL fl) = ppr fl
+ ppr_avail (AvailTC parent _) = ppr parent <> parens (ppr rdr)
+ ppr_avail (Avail name) = ppr name
pprImpDeclSpec :: ModIface -> ImpDeclSpec -> SDoc
pprImpDeclSpec iface decl_spec =
@@ -1844,13 +1824,12 @@ badImportItemErr iface decl_spec ie avails
Just con -> badImportItemErrDataCon (availOccName con) iface decl_spec ie
Nothing -> badImportItemErrStd iface decl_spec ie
where
- checkIfDataCon (AvailTC _ ns _) =
- case find (\n -> importedFS == nameOccNameFS n) ns of
- Just n -> isDataConName n
+ checkIfDataCon (AvailTC _ ns) =
+ case find (\n -> importedFS == occNameFS (occName n)) ns of
+ Just n -> isDataConName (childName n)
Nothing -> False
checkIfDataCon _ = False
- availOccName = nameOccName . availName
- nameOccNameFS = occNameFS . nameOccName
+ availOccName = occName . availChild
importedFS = occNameFS . rdrNameOcc $ ieName ie
illegalImportItemErr :: SDoc
=====================================
compiler/GHC/Tc/Gen/Export.hs
=====================================
@@ -246,13 +246,9 @@ exports_from_avail Nothing rdr_env _imports _this_mod
-- Even though we don't check whether this is actually a data family
-- only data families can locally define subordinate things (`ns` here)
-- without locally defining (and instead importing) the parent (`n`)
- fix_faminst (AvailTC n ns flds) =
- let new_ns =
- case ns of
- [] -> [n]
- (p:_) -> if p == n then ns else n:ns
- in AvailTC n new_ns flds
-
+ fix_faminst avail@(AvailTC n ns)
+ | availExportsDecl avail = avail
+ | otherwise = AvailTC n (ChildName n:ns)
fix_faminst avail = avail
@@ -353,7 +349,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
(n, avail, flds) <- lookup_ie_all ie n'
let name = unLoc n
return (IEThingAll noExtField (replaceLWrappedName n' (unLoc n))
- , AvailTC name (name:avail) flds)
+ , availTC name (name:avail) flds)
lookup_ie ie@(IEThingWith _ l wc sub_rdrs _)
@@ -367,7 +363,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
let name = unLoc lname
return (IEThingWith noExtField (replaceLWrappedName l name) wc subs
(flds ++ (map noLoc all_flds)),
- AvailTC name (name : avails ++ all_avail)
+ availTC name (name : avails ++ all_avail)
(map unLoc flds ++ all_flds))
=====================================
compiler/GHC/Types/Avail.hs
=====================================
@@ -10,13 +10,18 @@ module GHC.Types.Avail (
Avails,
AvailInfo(..),
avail,
+ availField,
+ availTC,
availsToNameSet,
availsToNameSetWithSelectors,
availsToNameEnv,
- availName, availNames, availNonFldNames,
+ availExportsDecl,
+ availName, availChild,
+ availNames, availNonFldNames,
availNamesWithSelectors,
availFlds,
availChildren,
+ availSubordinateChildren,
stableAvailCmp,
plusAvail,
trimAvail,
@@ -26,7 +31,10 @@ module GHC.Types.Avail (
Child(..),
childName,
- childSrcSpan
+ childPrintableName,
+ childSrcSpan,
+ partitionChildren,
+ stableChildCmp,
) where
import GHC.Prelude
@@ -44,8 +52,9 @@ import GHC.Utils.Panic
import GHC.Utils.Misc
import Data.Data ( Data )
+import Data.Either ( partitionEithers )
import Data.List ( find )
-import Data.Function
+import Data.Maybe
-- -----------------------------------------------------------------------------
-- The AvailInfo type
@@ -53,24 +62,19 @@ import Data.Function
-- | Records what things are \"available\", i.e. in scope
data AvailInfo
- -- | An ordinary identifier in scope
- = Avail Name
-
- -- | A field label in scope, without a parent type (see
- -- Note [Representing pattern synonym fields in AvailInfo]).
- | AvailFL FieldLabel
+ -- | An ordinary identifier in scope, or a field label without a parent type
+ -- (see Note [Representing pattern synonym fields in AvailInfo]).
+ = Avail Child
-- | A type or class in scope
--
-- The __AvailTC Invariant__: If the type or class is itself to be in scope,
-- it must be /first/ in this list. Thus, typically:
--
- -- > AvailTC Eq [Eq, ==, \/=] []
+ -- > AvailTC Eq [Eq, ==, \/=]
| AvailTC
Name -- ^ The name of the type or class
- [Name] -- ^ The available pieces of type or class,
- -- excluding record fields.
- [FieldLabel] -- ^ The record fields of the type
+ [Child] -- ^ The available pieces of type or class
-- (see Note [Representing fields in AvailInfo]).
deriving ( Eq -- ^ Used when deciding if the interface has changed
@@ -91,11 +95,11 @@ datatype like
gives rise to the AvailInfo
- AvailTC T [T, MkT] [FieldLabel "foo" False foo]
+ AvailTC T [T, MkT, FieldLabel "foo" False foo]
whereas if -XDuplicateRecordFields is enabled it gives
- AvailTC T [T, MkT] [FieldLabel "foo" True $sel:foo:MkT]
+ AvailTC T [T, MkT, FieldLabel "foo" True $sel:foo:MkT]
since the label does not match the selector name.
@@ -109,8 +113,8 @@ multiple distinct fields with the same label. For example,
gives rise to
- AvailTC F [ F, MkFInt, MkFBool ]
- [ FieldLabel "foo" True $sel:foo:MkFInt
+ AvailTC F [ F, MkFInt, MkFBool
+ , FieldLabel "foo" True $sel:foo:MkFInt
, FieldLabel "foo" True $sel:foo:MkFBool ]
Moreover, note that the flIsOverloaded flag need not be the same for
@@ -119,8 +123,8 @@ the two data instances are defined in different modules, one with
`-XDuplicateRecordFields` enabled and one with it disabled. Thus it
is possible to have
- AvailTC F [ F, MkFInt, MkFBool ]
- [ FieldLabel "foo" True $sel:foo:MkFInt
+ AvailTC F [ F, MkFInt, MkFBool
+ , FieldLabel "foo" True $sel:foo:MkFInt
, FieldLabel "foo" False foo ]
If the two data instances are defined in different modules, both
@@ -144,39 +148,42 @@ Thus under -XDuplicateRecordFields -XPatternSynoynms, the declaration
gives rise to the AvailInfo
- Avail MkFoo
- AvailFL (FieldLabel "f" True $sel:f:MkFoo)
+ Avail (ChildName MkFoo)
+ Avail (ChildField (FieldLabel "f" True $sel:f:MkFoo))
However, if `f` is bundled with a type constructor `T` by using `T(MkFoo,f)` in
an export list, then whenever `f` is imported the parent will be `T`,
represented as
- AvailTC T [T,MkFoo] [FieldLabel "f" True $sel:f:MkFoo]
-
-
-TODO: perhaps we should refactor AvailInfo like this?
-
- data AvailInfo = AvailChild Child | AvailTC Name [Child]
+ AvailTC T [ ChildName T
+ , ChildName MkFoo
+ , ChildField (FieldLabel "f" True $sel:f:MkFoo) ]
-}
-- | Compare lexicographically
stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering
-stableAvailCmp (Avail n1) (Avail n2) = n1 `stableNameCmp` n2
-stableAvailCmp (Avail {}) (AvailFL {}) = LT
-stableAvailCmp (Avail {}) (AvailTC {}) = LT
-stableAvailCmp (AvailFL {}) (Avail {}) = GT
-stableAvailCmp (AvailFL f) (AvailFL g) = flSelector f `stableNameCmp` flSelector g
-stableAvailCmp (AvailFL {}) (AvailTC {}) = LT
-stableAvailCmp (AvailTC n ns nfs) (AvailTC m ms mfs) =
- (n `stableNameCmp` m) `thenCmp`
- (cmpList stableNameCmp ns ms) `thenCmp`
- (cmpList (stableNameCmp `on` flSelector) nfs mfs)
-stableAvailCmp (AvailTC {}) (Avail {}) = GT
-stableAvailCmp (AvailTC {}) (AvailFL {}) = GT
+stableAvailCmp (Avail c1) (Avail c2) = c1 `stableChildCmp` c2
+stableAvailCmp (Avail {}) (AvailTC {}) = LT
+stableAvailCmp (AvailTC n ns) (AvailTC m ms) = (n `stableNameCmp` m) `thenCmp`
+ (cmpList stableChildCmp ns ms)
+stableAvailCmp (AvailTC {}) (Avail {}) = GT
+
+stableChildCmp :: Child -> Child -> Ordering
+stableChildCmp (ChildName n1) (ChildName n2) = n1 `stableNameCmp` n2
+stableChildCmp (ChildName {}) (ChildField {}) = LT
+stableChildCmp (ChildField f1) (ChildField f2) = flSelector f1 `stableNameCmp` flSelector f2
+stableChildCmp (ChildField {}) (ChildName {}) = GT
avail :: Name -> AvailInfo
-avail n = Avail n
+avail n = Avail (ChildName n)
+
+availField :: FieldLabel -> AvailInfo
+availField fl = Avail (ChildField fl)
+
+availTC :: Name -> [Name] -> [FieldLabel] -> AvailInfo
+availTC n ns fls = AvailTC n (map ChildName ns ++ map ChildField fls)
+
-- -----------------------------------------------------------------------------
-- Operations on AvailInfo
@@ -194,42 +201,64 @@ availsToNameEnv avails = foldr add emptyNameEnv avails
where add avail env = extendNameEnvList env
(zip (availNames avail) (repeat avail))
+-- | Does this 'AvailInfo' export the parent decl? This depends on the
+-- invariant that the parent is first if it appears at all.
+availExportsDecl :: AvailInfo -> Bool
+availExportsDecl (AvailTC ty_name names)
+ | n : _ <- names = ChildName ty_name == n
+ | otherwise = False
+availExportsDecl _ = True
+
-- | Just the main name made available, i.e. not the available pieces
--- of type or class brought into scope by the 'GenAvailInfo'
+-- of type or class brought into scope by the 'AvailInfo'
availName :: AvailInfo -> Name
-availName (Avail n) = n
-availName (AvailFL f) = flSelector f
-availName (AvailTC n _ _) = n
+availName (Avail n) = childName n
+availName (AvailTC n _) = n
+
+availChild :: AvailInfo -> Child
+availChild (Avail c) = c
+availChild (AvailTC n _) = ChildName n
-- | All names made available by the availability information (excluding overloaded selectors)
availNames :: AvailInfo -> [Name]
-availNames (Avail n) = [n]
-availNames (AvailFL f) = [ flSelector f | not (flIsOverloaded f) ]
-availNames (AvailTC _ ns fs) = ns ++ [ flSelector f | f <- fs, not (flIsOverloaded f) ]
+availNames (Avail c) = childNonOverloadedNames c
+availNames (AvailTC _ cs) = concatMap childNonOverloadedNames cs
+
+childNonOverloadedNames :: Child -> [Name]
+childNonOverloadedNames (ChildName n) = [n]
+childNonOverloadedNames (ChildField fl) = [ flSelector fl | not (flIsOverloaded fl) ]
-- | All names made available by the availability information (including overloaded selectors)
availNamesWithSelectors :: AvailInfo -> [Name]
-availNamesWithSelectors (Avail n) = [n]
-availNamesWithSelectors (AvailFL fl) = [flSelector fl]
-availNamesWithSelectors (AvailTC _ ns fs) = ns ++ map flSelector fs
+availNamesWithSelectors (Avail c) = [childName c]
+availNamesWithSelectors (AvailTC _ cs) = map childName cs
-- | Names for non-fields made available by the availability information
availNonFldNames :: AvailInfo -> [Name]
-availNonFldNames (Avail n) = [n]
-availNonFldNames (AvailFL {}) = []
-availNonFldNames (AvailTC _ ns _) = ns
+availNonFldNames (Avail (ChildName n)) = [n]
+availNonFldNames (Avail (ChildField {})) = []
+availNonFldNames (AvailTC _ ns) = mapMaybe f ns
+ where
+ f (ChildName n) = Just n
+ f (ChildField {}) = Nothing
-- | Fields made available by the availability information
availFlds :: AvailInfo -> [FieldLabel]
-availFlds (Avail {}) = []
-availFlds (AvailFL f) = [f]
-availFlds (AvailTC _ _ fs) = fs
+availFlds (Avail c) = maybeToList (childFieldLabel c)
+availFlds (AvailTC _ cs) = mapMaybe childFieldLabel cs
-- | Children made available by the availability information.
availChildren :: AvailInfo -> [Child]
-availChildren (Avail n) = [ChildName n]
-availChildren (AvailFL fl) = [ChildField fl]
-availChildren (AvailTC _ ns fs) = map ChildName ns ++ map ChildField fs
+availChildren (Avail c) = [c]
+availChildren (AvailTC _ cs) = cs
+
+-- | Children made available by the availability information, other than the
+-- main decl itself.
+availSubordinateChildren :: AvailInfo -> [Child]
+availSubordinateChildren (Avail {}) = []
+availSubordinateChildren avail@(AvailTC _ ns)
+ | availExportsDecl avail = tail ns
+ | otherwise = ns
-- | Used where we may have an ordinary name or a record field label.
@@ -250,10 +279,26 @@ childName :: Child -> Name
childName (ChildName name) = name
childName (ChildField fl) = flSelector fl
+-- | A Name for the child suitable for output to the user. For fields, the
+-- OccName will be the field label. See 'fieldLabelPrintableName'.
+childPrintableName :: Child -> Name
+childPrintableName (ChildName name) = name
+childPrintableName (ChildField fl) = fieldLabelPrintableName fl
+
childSrcSpan :: Child -> SrcSpan
childSrcSpan (ChildName name) = nameSrcSpan name
childSrcSpan (ChildField fl) = nameSrcSpan (flSelector fl)
+childFieldLabel :: Child -> Maybe FieldLabel
+childFieldLabel (ChildName {}) = Nothing
+childFieldLabel (ChildField fl) = Just fl
+
+partitionChildren :: [Child] -> ([Name], [FieldLabel])
+partitionChildren = partitionEithers . map to_either
+ where
+ to_either (ChildName n) = Left n
+ to_either (ChildField fl) = Right fl
+
-- -----------------------------------------------------------------------------
-- Utility
@@ -263,31 +308,22 @@ plusAvail a1 a2
| debugIsOn && availName a1 /= availName a2
= pprPanic "GHC.Rename.Env.plusAvail names differ" (hsep [ppr a1,ppr a2])
plusAvail a1@(Avail {}) (Avail {}) = a1
-plusAvail (AvailTC _ [] []) a2@(AvailTC {}) = a2
-plusAvail a1@(AvailTC {}) (AvailTC _ [] []) = a1
-plusAvail (AvailTC n1 (s1:ss1) fs1) (AvailTC n2 (s2:ss2) fs2)
- = case (n1==s1, n2==s2) of -- Maintain invariant the parent is first
+plusAvail (AvailTC _ []) a2@(AvailTC {}) = a2
+plusAvail a1@(AvailTC {}) (AvailTC _ []) = a1
+plusAvail (AvailTC n1 (s1:ss1)) (AvailTC n2 (s2:ss2))
+ = case (ChildName n1==s1, ChildName n2==s2) of -- Maintain invariant the parent is first
(True,True) -> AvailTC n1 (s1 : (ss1 `unionLists` ss2))
- (fs1 `unionLists` fs2)
(True,False) -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2)))
- (fs1 `unionLists` fs2)
(False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2))
- (fs1 `unionLists` fs2)
(False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2))
- (fs1 `unionLists` fs2)
-plusAvail (AvailTC n1 ss1 fs1) (AvailTC _ [] fs2)
- = AvailTC n1 ss1 (fs1 `unionLists` fs2)
-plusAvail (AvailTC n1 [] fs1) (AvailTC _ ss2 fs2)
- = AvailTC n1 ss2 (fs1 `unionLists` fs2)
plusAvail a1 a2 = pprPanic "GHC.Rename.Env.plusAvail" (hsep [ppr a1,ppr a2])
-- | trims an 'AvailInfo' to keep only a single name
trimAvail :: AvailInfo -> Name -> AvailInfo
-trimAvail (Avail n) _ = Avail n
-trimAvail (AvailFL f) _ = AvailFL f
-trimAvail (AvailTC n ns fs) m = case find ((== m) . flSelector) fs of
- Just x -> AvailTC n [] [x]
- Nothing -> ASSERT( m `elem` ns ) AvailTC n [m] []
+trimAvail avail@(Avail {}) _ = avail
+trimAvail avail@(AvailTC n ns) m = case find ((== m) . childName) ns of
+ Just c -> AvailTC n [c]
+ Nothing -> pprPanic "trimAvail" (hsep [ppr avail, ppr m])
-- | filters 'AvailInfo's by the given predicate
filterAvails :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo]
@@ -297,14 +333,11 @@ filterAvails keep avails = foldr (filterAvail keep) [] avails
filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo]
filterAvail keep ie rest =
case ie of
- Avail n | keep n -> ie : rest
+ Avail c | keep (childName c) -> ie : rest
| otherwise -> rest
- AvailFL fl | keep (flSelector fl) -> ie : rest
- | otherwise -> rest
- AvailTC tc ns fs ->
- let ns' = filter keep ns
- fs' = filter (keep . flSelector) fs in
- if null ns' && null fs' then rest else AvailTC tc ns' fs' : rest
+ AvailTC tc cs ->
+ let cs' = filter (keep . childName) cs
+ in if null cs' then rest else AvailTC tc cs' : rest
-- | Combines 'AvailInfo's from the same family
@@ -326,32 +359,37 @@ instance Outputable AvailInfo where
pprAvail :: AvailInfo -> SDoc
pprAvail (Avail n)
= ppr n
-pprAvail (AvailFL fl)
- = ppr fl
-pprAvail (AvailTC n ns fs)
- = ppr n <> braces (sep [ fsep (punctuate comma (map ppr ns)) <> semi
- , fsep (punctuate comma (map (ppr . flLabel) fs))])
+pprAvail (AvailTC n ns)
+ = ppr n <> braces (fsep (punctuate comma (map ppr ns)))
instance Binary AvailInfo where
put_ bh (Avail aa) = do
putByte bh 0
put_ bh aa
- put_ bh (AvailTC ab ac ad) = do
+ put_ bh (AvailTC ab ac) = do
putByte bh 1
put_ bh ab
put_ bh ac
- put_ bh ad
- put_ bh (AvailFL af) = do
- putByte bh 2
- put_ bh af
get bh = do
h <- getByte bh
case h of
0 -> do aa <- get bh
return (Avail aa)
- 1 -> do ab <- get bh
+ _ -> do ab <- get bh
ac <- get bh
- ad <- get bh
- return (AvailTC ab ac ad)
- _ -> do af <- get bh
- return (AvailFL af)
+ return (AvailTC ab ac)
+
+instance Binary Child where
+ put_ bh (ChildName aa) = do
+ putByte bh 0
+ put_ bh aa
+ put_ bh (ChildField ab) = do
+ putByte bh 1
+ put_ bh ab
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do aa <- get bh
+ return (ChildName aa)
+ _ -> do ab <- get bh
+ return (ChildField ab)
=====================================
compiler/GHC/Types/Name/Reader.hs
=====================================
@@ -659,9 +659,7 @@ gre_name gre = case gre_child gre of
-- | 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
+grePrintableName = childPrintableName . gre_child
-- | The SrcSpan of the name pointed to by the GRE.
greDefinitionSrcSpan :: GlobalRdrElt -> SrcSpan
@@ -703,15 +701,13 @@ greSrcSpan gre@(GRE { gre_lcl = lcl, gre_imp = iss } )
| otherwise = pprPanic "greSrcSpan" (ppr gre)
mkParent :: Name -> AvailInfo -> Parent
-mkParent _ (Avail _) = NoParent
-mkParent _ (AvailFL _) = NoParent
-mkParent n (AvailTC m _ _) | n == m = NoParent
- | otherwise = ParentIs m
+mkParent _ (Avail _) = NoParent
+mkParent n (AvailTC m _) | n == m = NoParent
+ | otherwise = ParentIs m
availParent :: AvailInfo -> Parent
-availParent (AvailTC m _ _) = ParentIs m
-availParent (Avail {}) = NoParent
-availParent (AvailFL {}) = NoParent
+availParent (AvailTC m _) = ParentIs m
+availParent (Avail {}) = NoParent
greParent_maybe :: GlobalRdrElt -> Maybe Name
@@ -749,30 +745,25 @@ gresToAvailInfo gres
-- need to maintain the invariant that the parent is first.
--
-- We also use the invariant that `k` is not already in `ns`.
- insertChildIntoChildren :: Name -> [Name] -> Name -> [Name]
+ insertChildIntoChildren :: Name -> [Child] -> Child -> [Child]
insertChildIntoChildren _ [] k = [k]
insertChildIntoChildren p (n:ns) k
- | p == k = k:n:ns
+ | ChildName p == k = k:n:ns
| otherwise = n:k:ns
comb :: GlobalRdrElt -> AvailInfo -> AvailInfo
- comb _ (Avail n) = Avail n -- Duplicated name, should not happen
- 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
- (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)
+ comb _ (Avail n) = Avail n -- Duplicated name, should not happen
+ comb gre (AvailTC m ns)
+ = case gre_par gre of
+ NoParent -> AvailTC m (gre_child gre:ns) -- Not sure this ever happens
+ ParentIs {} -> AvailTC m (insertChildIntoChildren m ns (gre_child gre))
availFromGRE :: GlobalRdrElt -> AvailInfo
availFromGRE (GRE { gre_child = child, gre_par = parent })
- = case (parent, child) of
- (ParentIs p, ChildName me) -> AvailTC p [me] []
- (ParentIs p, ChildField fl) -> AvailTC p [] [fl]
- (NoParent, ChildName me) | isTyConName me -> AvailTC me [me] []
- | otherwise -> avail me
- (NoParent, ChildField fl) -> AvailFL fl
+ = case parent of
+ ParentIs p -> AvailTC p [child]
+ NoParent | ChildName me <- child, isTyConName me -> AvailTC me [child]
+ | otherwise -> Avail child
emptyGlobalRdrEnv :: GlobalRdrEnv
emptyGlobalRdrEnv = emptyOccEnv
=====================================
compiler/GHC/Types/Name/Shape.hs
=====================================
@@ -183,14 +183,17 @@ substName env n | Just n' <- lookupNameEnv env n = n'
-- for type constructors, where it is sufficient to substitute the 'availName'
-- to induce a substitution on 'availNames'.
substNameAvailInfo :: HscEnv -> ShNameSubst -> AvailInfo -> IO AvailInfo
-substNameAvailInfo _ env (Avail n) = return (Avail (substName env n))
-substNameAvailInfo _ env (AvailFL fl) =
- return (AvailFL fl { flSelector = substName env (flSelector fl) })
-substNameAvailInfo hsc_env env (AvailTC n ns fs) =
+substNameAvailInfo _ env (Avail (ChildName n)) = return (Avail (ChildName (substName env n)))
+substNameAvailInfo _ env (Avail (ChildField fl)) =
+ return (Avail (ChildField fl { flSelector = substName env (flSelector fl) }))
+substNameAvailInfo hsc_env env (AvailTC n ns) =
let mb_mod = fmap nameModule (lookupNameEnv env n)
- in AvailTC (substName env n)
- <$> mapM (initIfaceLoad hsc_env . setNameModule mb_mod) ns
- <*> mapM (setNameFieldSelector hsc_env mb_mod) fs
+ in AvailTC (substName env n) <$> mapM (setNameChild hsc_env mb_mod) ns
+
+setNameChild :: HscEnv -> Maybe Module -> Child -> IO Child
+setNameChild hsc_env mb_mod child = case child of
+ ChildName n -> ChildName <$> initIfaceLoad hsc_env (setNameModule mb_mod n)
+ ChildField fl -> ChildField <$> setNameFieldSelector hsc_env mb_mod fl
-- | Set the 'Module' of a 'FieldSelector'
setNameFieldSelector :: HscEnv -> Maybe Module -> FieldLabel -> IO FieldLabel
@@ -237,8 +240,8 @@ uAvailInfos flexi as1 as2 = -- pprTrace "uAvailInfos" (ppr as1 $$ ppr as2) $
-- with only name holes from @flexi@ unifiable (all other name holes rigid.)
uAvailInfo :: ModuleName -> ShNameSubst -> AvailInfo -> AvailInfo
-> Either SDoc ShNameSubst
-uAvailInfo flexi subst (Avail n1) (Avail n2) = uName flexi subst n1 n2
-uAvailInfo flexi subst (AvailTC n1 _ _) (AvailTC n2 _ _) = uName flexi subst n1 n2
+uAvailInfo flexi subst (Avail (ChildName n1)) (Avail (ChildName n2)) = uName flexi subst n1 n2
+uAvailInfo flexi subst (AvailTC n1 _) (AvailTC n2 _) = uName flexi subst n1 n2
uAvailInfo _ _ a1 a2 = Left $ text "While merging export lists, could not combine"
<+> ppr a1 <+> text "with" <+> ppr a2
<+> parens (text "one is a type, the other is a plain identifier")
=====================================
compiler/GHC/Types/TyThing.hs
=====================================
@@ -253,11 +253,10 @@ tyThingsTyCoVars tts =
tyThingAvailInfo :: TyThing -> [AvailInfo]
tyThingAvailInfo (ATyCon t)
= case tyConClass_maybe t of
- Just c -> [AvailTC n (n : map getName (classMethods c)
- ++ map getName (classATs c))
- [] ]
+ Just c -> [availTC n ((n : map getName (classMethods c)
+ ++ map getName (classATs c))) [] ]
where n = getName c
- Nothing -> [AvailTC n (n : map getName dcs) flds]
+ Nothing -> [availTC n (n : map getName dcs) flds]
where n = getName t
dcs = tyConDataCons t
flds = tyConFieldLabels t
=====================================
testsuite/tests/parser/should_compile/T14189.stderr
=====================================
@@ -138,12 +138,15 @@
{Name: T14189.f}))]))
[(AvailTC
{Name: T14189.MyType}
- [{Name: T14189.MyType}
- ,{Name: T14189.NT}]
- [(FieldLabel
- {FastString: "f"}
- (False)
- {Name: T14189.f})])])])
+ [(ChildName
+ {Name: T14189.MyType})
+ ,(ChildName
+ {Name: T14189.NT})
+ ,(ChildField
+ (FieldLabel
+ {FastString: "f"}
+ (False)
+ {Name: T14189.f}))])])])
(Nothing)))
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit ad9cbad7312a64e6757c32bd9488c55ba4f2fec9
+Subproject commit 3d3308a332468f33b5cc32918179bd3f10ee16db
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/655acd4deacffc5432d9b6615ff30cb9c6bc9f33
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/655acd4deacffc5432d9b6615ff30cb9c6bc9f33
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/20201201/43229d1f/attachment-0001.html>
More information about the ghc-commits
mailing list