Commit 96621b1b authored by Matthew Pickering's avatar Matthew Pickering Committed by Ben Gamari

Associate pattern synonyms with types in module exports

This patch implements #10653.

It adds the ability to bundle pattern synonyms with type constructors in
export lists so that users can treat pattern synonyms more like data
constructors.

Updates haddock submodule.

Test Plan: ./validate

Reviewers: goldfire, austin, bgamari

Reviewed By: bgamari

Subscribers: simonpj, gridaphobe, thomie

Differential Revision: https://phabricator.haskell.org/D1258

GHC Trac Issues: #10653
parent 3cfe60ae
......@@ -7,6 +7,9 @@
module Avail (
Avails,
AvailInfo(..),
IsPatSyn(..),
avail,
patSynAvail,
availsToNameSet,
availsToNameSetWithSelectors,
availsToNameEnv,
......@@ -31,7 +34,7 @@ import Data.Function
-- The AvailInfo type
-- | Records what things are "available", i.e. in scope
data AvailInfo = Avail Name -- ^ An ordinary identifier in scope
data AvailInfo = Avail IsPatSyn Name -- ^ An ordinary identifier in scope
| AvailTC Name
[Name]
[FieldLabel]
......@@ -52,6 +55,8 @@ data AvailInfo = Avail Name -- ^ An ordinary identifier in scope
-- Equality used when deciding if the
-- interface has changed
data IsPatSyn = NotPatSyn | IsPatSyn deriving Eq
-- | A collection of 'AvailInfo' - several things that are \"available\"
type Avails = [AvailInfo]
......@@ -105,7 +110,7 @@ modules.
-- | Compare lexicographically
stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering
stableAvailCmp (Avail n1) (Avail n2) = n1 `stableNameCmp` n2
stableAvailCmp (Avail _ n1) (Avail _ n2) = n1 `stableNameCmp` n2
stableAvailCmp (Avail {}) (AvailTC {}) = LT
stableAvailCmp (AvailTC n ns nfs) (AvailTC m ms mfs) =
(n `stableNameCmp` m) `thenCmp`
......@@ -113,6 +118,12 @@ stableAvailCmp (AvailTC n ns nfs) (AvailTC m ms mfs) =
(cmpList (stableNameCmp `on` flSelector) nfs mfs)
stableAvailCmp (AvailTC {}) (Avail {}) = GT
patSynAvail :: Name -> AvailInfo
patSynAvail n = Avail IsPatSyn n
avail :: Name -> AvailInfo
avail n = Avail NotPatSyn n
-- -----------------------------------------------------------------------------
-- Operations on AvailInfo
......@@ -132,22 +143,22 @@ availsToNameEnv avails = foldr add emptyNameEnv avails
-- | Just the main name made available, i.e. not the available pieces
-- of type or class brought into scope by the 'GenAvailInfo'
availName :: AvailInfo -> Name
availName (Avail n) = n
availName (Avail _ n) = n
availName (AvailTC n _ _) = n
-- | All names made available by the availability information (excluding overloaded selectors)
availNames :: AvailInfo -> [Name]
availNames (Avail n) = [n]
availNames (Avail _ n) = [n]
availNames (AvailTC _ ns fs) = ns ++ [ flSelector f | f <- fs, not (flIsOverloaded f) ]
-- | All names made available by the availability information (including overloaded selectors)
availNamesWithSelectors :: AvailInfo -> [Name]
availNamesWithSelectors (Avail n) = [n]
availNamesWithSelectors (Avail _ n) = [n]
availNamesWithSelectors (AvailTC _ ns fs) = ns ++ map flSelector fs
-- | Names for non-fields made available by the availability information
availNonFldNames :: AvailInfo -> [Name]
availNonFldNames (Avail n) = [n]
availNonFldNames (Avail _ n) = [n]
availNonFldNames (AvailTC _ ns _) = ns
-- | Fields made available by the availability information
......@@ -155,7 +166,6 @@ availFlds :: AvailInfo -> [FieldLabel]
availFlds (AvailTC _ _ fs) = fs
availFlds _ = []
-- -----------------------------------------------------------------------------
-- Printing
......@@ -163,13 +173,14 @@ instance Outputable AvailInfo where
ppr = pprAvail
pprAvail :: AvailInfo -> SDoc
pprAvail (Avail n) = ppr n
pprAvail (Avail _ n) = ppr n
pprAvail (AvailTC n ns fs) = ppr n <> braces (hsep (punctuate comma (map ppr ns ++ map (ppr . flLabel) fs)))
instance Binary AvailInfo where
put_ bh (Avail aa) = do
put_ bh (Avail b aa) = do
putByte bh 0
put_ bh aa
put_ bh b
put_ bh (AvailTC ab ac ad) = do
putByte bh 1
put_ bh ab
......@@ -179,8 +190,18 @@ instance Binary AvailInfo where
h <- getByte bh
case h of
0 -> do aa <- get bh
return (Avail aa)
b <- get bh
return (Avail b aa)
_ -> do ab <- get bh
ac <- get bh
ad <- get bh
return (AvailTC ab ac ad)
instance Binary IsPatSyn where
put_ bh IsPatSyn = putByte bh 0
put_ bh NotPatSyn = putByte bh 1
get bh = do
h <- getByte bh
case h of
0 -> return IsPatSyn
_ -> return NotPatSyn
......@@ -428,6 +428,7 @@ data Parent = NoParent
| ParentIs { par_is :: Name }
| FldParent { par_is :: Name, par_lbl :: Maybe FieldLabelString }
-- ^ See Note [Parents for record fields]
| PatternSynonym
deriving (Eq)
instance Outputable Parent where
......@@ -435,6 +436,7 @@ instance Outputable Parent where
ppr (ParentIs n) = ptext (sLit "parent:") <> ppr n
ppr (FldParent n f) = ptext (sLit "fldparent:")
<> ppr n <> colon <> ppr f
ppr (PatternSynonym) = ptext (sLit "pattern synonym")
plusParent :: Parent -> Parent -> Parent
-- See Note [Combining parents]
......@@ -442,7 +444,8 @@ plusParent p1@(ParentIs _) p2 = hasParent p1 p2
plusParent p1@(FldParent _ _) p2 = hasParent p1 p2
plusParent p1 p2@(ParentIs _) = hasParent p2 p1
plusParent p1 p2@(FldParent _ _) = hasParent p2 p1
plusParent NoParent NoParent = NoParent
plusParent PatternSynonym PatternSynonym = PatternSynonym
plusParent _ _ = NoParent
hasParent :: Parent -> Parent -> Parent
#ifdef DEBUG
......@@ -628,18 +631,20 @@ greSrcSpan gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss } )
| otherwise = pprPanic "greSrcSpan" (ppr gre)
mkParent :: Name -> AvailInfo -> Parent
mkParent _ (Avail _) = NoParent
mkParent _ (Avail NotPatSyn _) = NoParent
mkParent _ (Avail IsPatSyn _) = PatternSynonym
mkParent n (AvailTC m _ _) | n == m = NoParent
| otherwise = ParentIs m
| otherwise = ParentIs m
availFromGRE :: GlobalRdrElt -> AvailInfo
availFromGRE (GRE { gre_name = me, gre_par = parent })
= case parent of
ParentIs p -> AvailTC p [me] []
NoParent | isTyConName me -> AvailTC me [me] []
| otherwise -> Avail me
| otherwise -> avail me
FldParent p Nothing -> AvailTC p [] [FieldLabel (occNameFS $ nameOccName me) False me]
FldParent p (Just lbl) -> AvailTC p [] [FieldLabel lbl True me]
PatternSynonym -> patSynAvail me
emptyGlobalRdrEnv :: GlobalRdrEnv
emptyGlobalRdrEnv = emptyOccEnv
......
......@@ -154,7 +154,10 @@ data IE name
-- For details on above see note [Api annotations] in ApiAnnotation
| IEThingWith (Located name) [Located name] [Located (FieldLbl name)]
| IEThingWith (Located name)
IEWildcard
[Located name]
[Located (FieldLbl name)]
-- ^ Class/Type plus some methods/constructors
-- and record fields; see Note [IEThingWith]
-- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen',
......@@ -173,6 +176,8 @@ data IE name
| IEDocNamed String -- ^ Reference to named doc
deriving (Eq, Data, Typeable)
data IEWildcard = NoIEWildcard | IEWildcard Int deriving (Eq, Data, Typeable)
{-
Note [IEThingWith]
~~~~~~~~~~~~~~~~~~
......@@ -191,12 +196,22 @@ See Note [Representing fields in AvailInfo] in Avail for more details.
-}
ieName :: IE name -> name
ieName (IEVar (L _ n)) = n
ieName (IEThingAbs (L _ n)) = n
ieName (IEThingWith (L _ n) _ _) = n
ieName (IEThingAll (L _ n)) = n
ieName (IEVar (L _ n)) = n
ieName (IEThingAbs (L _ n)) = n
ieName (IEThingWith (L _ n) _ _ _) = n
ieName (IEThingAll (L _ n)) = n
ieName _ = panic "ieName failed pattern match!"
ieNames :: IE a -> [a]
ieNames (IEVar (L _ n) ) = [n]
ieNames (IEThingAbs (L _ n) ) = [n]
ieNames (IEThingAll (L _ n) ) = [n]
ieNames (IEThingWith (L _ n) _ ns _) = n : map unLoc ns
ieNames (IEModuleContents _ ) = []
ieNames (IEGroup _ _ ) = []
ieNames (IEDoc _ ) = []
ieNames (IEDocNamed _ ) = []
pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc
pprImpExp name = type_pref <+> pprPrefixOcc name
where
......@@ -208,12 +223,20 @@ instance (HasOccName name, OutputableBndr name) => Outputable (IE name) where
ppr (IEVar var) = pprPrefixOcc (unLoc var)
ppr (IEThingAbs thing) = pprImpExp (unLoc thing)
ppr (IEThingAll thing) = hcat [pprImpExp (unLoc thing), text "(..)"]
ppr (IEThingWith thing withs flds)
ppr (IEThingWith thing wc withs flds)
= pprImpExp (unLoc thing) <> parens (fsep (punctuate comma
(map pprImpExp (map unLoc withs) ++
map (ppr . flLabel . unLoc) flds)))
ppWiths ++
map (ppr . flLabel . unLoc) flds))
where
ppWiths =
case wc of
NoIEWildcard ->
map (pprImpExp . unLoc) withs
IEWildcard pos ->
let (bs, as) = splitAt pos (map (pprImpExp . unLoc) withs)
in bs ++ [text ".."] ++ as
ppr (IEModuleContents mod')
= ptext (sLit "module") <+> ppr mod'
ppr (IEGroup n _) = text ("<IEGroup: " ++ (show n) ++ ">")
ppr (IEGroup n _) = text ("<IEGroup: " ++ show n ++ ">")
ppr (IEDoc doc) = ppr doc
ppr (IEDocNamed string) = text ("<IEDocNamed: " ++ string ++ ">")
......@@ -908,7 +908,7 @@ When printing export lists, we print like this:
-}
pprExport :: IfaceExport -> SDoc
pprExport (Avail n) = ppr n
pprExport (Avail _ n) = ppr n
pprExport (AvailTC _ [] []) = Outputable.empty
pprExport (AvailTC n ns0 fs) = case ns0 of
(n':ns) | n==n' -> ppr n <> pp_export ns fs
......
......@@ -1080,7 +1080,7 @@ mkIfaceExports exports
= sortBy stableAvailCmp (map sort_subs exports)
where
sort_subs :: AvailInfo -> AvailInfo
sort_subs (Avail n) = Avail n
sort_subs (Avail b n) = Avail b n
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)
......
......@@ -1799,7 +1799,7 @@ tyThingAvailInfo (ATyCon t)
dcs = tyConDataCons t
flds = tyConFieldLabels t
tyThingAvailInfo t
= Avail (getName t)
= avail (getName t)
{-
************************************************************************
......
......@@ -33,6 +33,7 @@ import Control.Monad ( unless, liftM )
import GHC.Exts
import Data.Char
import Control.Monad ( mplus )
import Control.Applicative ((<$))
-- compiler/hsSyn
import HsSyn
......@@ -79,6 +80,7 @@ import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilD
-- compiler/utils
import Util ( looksLikePackageName )
import Prelude
}
......@@ -632,9 +634,8 @@ exp_doc :: { OrdList (LIE RdrName) }
-- No longer allow things like [] and (,,,) to be exported
-- They are built in syntax, always available
export :: { OrdList (LIE RdrName) }
: qcname_ext export_subspec {% amsu (sLL $1 $> (mkModuleImpExp $1
(snd $ unLoc $2)))
(fst $ unLoc $2) }
: qcname_ext export_subspec {% mkModuleImpExp $1 (snd $ unLoc $2)
>>= \ie -> amsu (sLL $1 $> ie) (fst $ unLoc $2) }
| 'module' modid {% amsu (sLL $1 $> (IEModuleContents $2))
[mj AnnModule $1] }
| 'pattern' qcon {% amsu (sLL $1 $> (IEVar $2))
......@@ -642,18 +643,34 @@ export :: { OrdList (LIE RdrName) }
export_subspec :: { Located ([AddAnn],ImpExpSubSpec) }
: {- empty -} { sL0 ([],ImpExpAbs) }
| '(' '..' ')' { sLL $1 $> ([mop $1,mcp $3,mj AnnDotdot $2]
, ImpExpAll) }
| '(' ')' { sLL $1 $> ([mop $1,mcp $2],ImpExpList []) }
| '(' qcnames ')' { sLL $1 $> ([mop $1,mcp $3],ImpExpList (reverse $2)) }
qcnames :: { [Located RdrName] } -- A reversed list
: qcnames ',' qcname_ext {% (aa (head $1) (AnnComma, $2)) >>
return ($3 : $1) }
| qcname_ext { [$1] }
qcname_ext :: { Located RdrName } -- Variable or data constructor
-- or tagged type constructor
| '(' qcnames ')' {% mkImpExpSubSpec (reverse (snd $2))
>>= \(as,ie) -> return $ sLL $1 $>
(as ++ [mop $1,mcp $3] ++ fst $2, ie) }
qcnames :: { ([AddAnn], [Located (Maybe RdrName)]) }
: {- empty -} { ([],[]) }
| qcnames1 { $1 }
qcnames1 :: { ([AddAnn], [Located (Maybe RdrName)]) } -- A reversed list
: qcnames1 ',' qcname_ext_w_wildcard {% case (last (snd $1)) of
l@(L _ Nothing) ->
return ([mj AnnComma $2, mj AnnDotdot l]
,($3 : snd $1))
l -> (aa l (AnnComma, $2) >>
return (fst $1, $3 : snd $1)) }
-- Annotations readded in mkImpExpSubSpec
| qcname_ext_w_wildcard { ([],[$1]) }
-- Variable, data constructor or wildcard
-- or tagged type constructor
qcname_ext_w_wildcard :: { Located (Maybe RdrName) }
: qcname_ext { Just `fmap` $1 }
| '..' { Nothing <$ $1 }
qcname_ext :: { Located RdrName }
: qcname { $1 }
| 'type' oqtycon {% amms (mkTypeImpExp (sLL $1 $> (unLoc $2)))
[mj AnnType $1,mj AnnVal $2] }
......@@ -726,7 +743,10 @@ maybeas :: { ([AddAnn],Located (Maybe ModuleName)) }
| {- empty -} { ([],noLoc Nothing) }
maybeimpspec :: { Located (Maybe (Bool, Located [LIE RdrName])) }
: impspec { L (gl $1) (Just (unLoc $1)) }
: impspec {% let (b, ie) = unLoc $1 in
checkImportSpec ie
>>= \checkedIe ->
return (L (gl $1) (Just (b, checkedIe))) }
| {- empty -} { noLoc Nothing }
impspec :: { Located (Bool, Located [LIE RdrName]) }
......
......@@ -56,7 +56,9 @@ module RdrHsSyn (
-- Help with processing exports
ImpExpSubSpec(..),
mkModuleImpExp,
mkTypeImpExp
mkTypeImpExp,
mkImpExpSubSpec,
checkImportSpec
) where
......@@ -87,6 +89,7 @@ import FastString
import Maybes
import Util
import ApiAnnotation
import Data.List
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative ((<$>))
......@@ -1328,16 +1331,31 @@ mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
--------------------------------------------------------------------------------
-- Help with module system imports/exports
data ImpExpSubSpec = ImpExpAbs | ImpExpAll | ImpExpList [Located RdrName]
data ImpExpSubSpec = ImpExpAbs
| ImpExpAll
| ImpExpList [Located RdrName]
| ImpExpAllWith [Located (Maybe RdrName)]
mkModuleImpExp :: Located RdrName -> ImpExpSubSpec -> IE RdrName
mkModuleImpExp :: Located RdrName -> ImpExpSubSpec -> P (IE RdrName)
mkModuleImpExp n@(L l name) subs =
case subs of
ImpExpAbs
| isVarNameSpace (rdrNameSpace name) -> IEVar n
| otherwise -> IEThingAbs (L l name)
ImpExpAll -> IEThingAll (L l name)
ImpExpList xs -> IEThingWith (L l name) xs []
| isVarNameSpace (rdrNameSpace name) -> return $ IEVar n
| otherwise -> return $ IEThingAbs (L l name)
ImpExpAll -> return $ IEThingAll (L l name)
ImpExpList xs ->
return $ IEThingWith (L l name) NoIEWildcard xs []
ImpExpAllWith xs ->
do allowed <- extension patternSynonymsEnabled
if allowed
then
let withs = map unLoc xs
pos = maybe NoIEWildcard IEWildcard
(findIndex isNothing withs)
ies = [L l n | L l (Just n) <- xs]
in return (IEThingWith (L l name) pos ies [])
else parseErrorSDoc l
(text "Illegal export form (use PatternSynonyms to enable)")
mkTypeImpExp :: Located RdrName -- TcCls or Var name space
-> P (Located RdrName)
......@@ -1348,6 +1366,28 @@ mkTypeImpExp name =
else parseErrorSDoc (getLoc name)
(text "Illegal keyword 'type' (use ExplicitNamespaces to enable)")
checkImportSpec :: Located [LIE RdrName] -> P (Located [LIE RdrName])
checkImportSpec ie@(L _ specs) =
case [l | (L l (IEThingWith _ (IEWildcard _) _ _)) <- specs] of
[] -> return ie
(l:_) -> importSpecError l
where
importSpecError l =
parseErrorSDoc l
(text "Illegal import form, this syntax can only be used to bundle"
$+$ text "pattern synonyms with types in module exports.")
-- In the correct order
mkImpExpSubSpec :: [Located (Maybe RdrName)] -> P ([AddAnn], ImpExpSubSpec)
mkImpExpSubSpec [] = return ([], ImpExpList [])
mkImpExpSubSpec [L l Nothing] =
return ([\s -> addAnnotation l AnnDotdot s], ImpExpAll)
mkImpExpSubSpec xs =
if (any (isNothing . unLoc) xs)
then return $ ([], ImpExpAllWith xs)
else return $ ([], ImpExpList ([L l x | L l (Just x) <- xs]))
-----------------------------------------------------------------------------
-- Misc utils
......
......@@ -151,8 +151,8 @@ wired-in Ids.
ghcPrimExports :: [IfaceExport]
ghcPrimExports
= map (Avail . idName) ghcPrimIds ++
map (Avail . idName . primOpId) allThePrimOps ++
= map (avail . idName) ghcPrimIds ++
map (avail . idName . primOpId) allThePrimOps ++
[ AvailTC n [n] []
| tc <- funTyCon : primTyCons, let n = tyConName tc ]
......
......@@ -922,7 +922,7 @@ lookupGreAvailRn rdr_name
Nothing ->
do { traceRn (text "lookupGreRn" <+> ppr rdr_name)
; let name = mkUnboundName rdr_name
; return (name, Avail name) } } }
; return (name, avail name) } } }
{-
*********************************************************
......@@ -1015,6 +1015,7 @@ lookupImpDeprec iface gre
ParentIs p -> mi_warn_fn iface p
FldParent { par_is = p } -> mi_warn_fn iface p
NoParent -> Nothing
PatternSynonym -> Nothing
{-
Note [Used names with interface not loaded]
......@@ -1824,6 +1825,7 @@ warnUnusedTopBinds gres
let isBoot = tcg_src env == HsBootFile
let noParent gre = case gre_par gre of
NoParent -> True
PatternSynonym -> True
_ -> False
-- Don't warn about unused bindings with parents in
-- .hs-boot files, as you are sometimes required to give
......
......@@ -580,7 +580,7 @@ getLocalNonValBinders fixity_env
-- declaration, not just the name
new_simple :: Located RdrName -> RnM AvailInfo
new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name
; return (Avail nm) }
; return (avail nm) }
new_tc :: Bool -> LTyClDecl RdrName
-> RnM (AvailInfo, [(Name, [FieldLabel])])
......@@ -860,7 +860,8 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
-> do nameAvail <- lookup_name tc
return ([mkIEThingAbs l nameAvail], [])
IEThingWith (L l rdr_tc) rdr_ns rdr_fs -> ASSERT2(null rdr_fs, ppr rdr_fs) do
IEThingWith (L l rdr_tc) wc rdr_ns rdr_fs ->
ASSERT2(null rdr_fs, ppr rdr_fs) do
(name, AvailTC _ ns subflds, mb_parent) <- lookup_name rdr_tc
-- Look up the children in the sub-names of the parent
......@@ -875,14 +876,14 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
case mb_parent of
-- non-associated ty/cls
Nothing
-> return ([(IEThingWith (L l name) childnames childflds,
-> return ([(IEThingWith (L l name) wc childnames childflds,
AvailTC name (name:map unLoc childnames) (map unLoc childflds))],
[])
-- associated ty
Just parent
-> return ([(IEThingWith (L l name) childnames childflds,
-> return ([(IEThingWith (L l name) wc childnames childflds,
AvailTC name (map unLoc childnames) (map unLoc childflds)),
(IEThingWith (L l name) childnames childflds,
(IEThingWith (L l name) wc childnames childflds,
AvailTC parent [name] [])],
[])
......@@ -957,7 +958,7 @@ plusAvail a1 a2 = pprPanic "RnEnv.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 (Avail b n) _ = Avail b n
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] []
......@@ -970,7 +971,7 @@ 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 _ n | keep n -> ie : rest
| otherwise -> rest
AvailTC tc ns fs ->
let ns' = filter keep ns
......@@ -1014,6 +1015,14 @@ mkChildEnv gres = foldr add emptyNameEnv gres
FldParent p _ -> extendNameEnv_Acc (:) singleton env p gre
ParentIs p -> extendNameEnv_Acc (:) singleton env p gre
NoParent -> env
PatternSynonym -> env
findPatSyns :: [GlobalRdrElt] -> [GlobalRdrElt]
findPatSyns gres = foldr add [] gres
where
add g@(GRE { gre_par = PatternSynonym }) ps =
g:ps
add _ ps = ps
findChildren :: NameEnv [a] -> Name -> [a]
findChildren env n = lookupNameEnv env n `orElse` []
......@@ -1052,7 +1061,6 @@ classifyGRE gre = case gre_par gre of
where
n = gre_name gre
-- | Combines 'AvailInfo's from the same family
-- 'avails' may have several items with the same availName
-- E.g import Ix( Ix(..), index )
......@@ -1129,7 +1137,7 @@ type ExportOccMap = OccEnv (Name, IE RdrName)
rnExports :: Bool -- False => no 'module M(..) where' header at all
-> Maybe (Located [LIE RdrName]) -- Nothing => no explicit export list
-> TcGblEnv
-> RnM TcGblEnv
-> RnM (Maybe [LIE Name], TcGblEnv)
-- Complains if two distinct exports have same OccName
-- Warns about identical exports.
......@@ -1166,12 +1174,14 @@ rnExports explicit_mod exports
; traceRn (text "rnExports: Exports:" <+> ppr final_avails)
; return (tcg_env { tcg_exports = final_avails,
tcg_rn_exports = case tcg_rn_exports tcg_env of
; let new_tcg_env =
(tcg_env { tcg_exports = final_avails,
tcg_rn_exports = case tcg_rn_exports tcg_env of
Nothing -> Nothing
Just _ -> rn_exports,
tcg_dus = tcg_dus tcg_env `plusDU`
usesOnly final_ns }) }
usesOnly final_ns })
; return (rn_exports, new_tcg_env) }
exports_from_avail :: Maybe (Located [LIE RdrName])
-- Nothing => no explicit export list
......@@ -1201,6 +1211,10 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
kids_env :: NameEnv [GlobalRdrElt]
kids_env = mkChildEnv (globalRdrEnvElts rdr_env)
pat_syns :: [GlobalRdrElt]
pat_syns = findPatSyns (globalRdrEnvElts rdr_env)
imported_modules = [ qual_name
| xs <- moduleEnvElts $ imp_mods imports,
(qual_name, _, _, _) <- xs ]
......@@ -1269,8 +1283,54 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
= do (name, avail) <- lookupGreAvailRn rdr
return (IEThingAbs (L l name), avail)
<