summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorMatthew Pickering <matthewtpickering@gmail.com>2016-10-08 10:06:01 +0100
committerMatthew Pickering <matthewtpickering@gmail.com>2016-10-08 10:07:14 +0100
commite660f4bf546e90fb6719ad268ca3daaecdce4b82 (patch)
tree7c23ed1a6983d951c8950f8105d3889914619d81 /compiler
parent46b78e604c06c8878e436fea93729158dcf55269 (diff)
downloadhaskell-e660f4bf546e90fb6719ad268ca3daaecdce4b82.tar.gz
Rework renaming of children in export lists.
The target of this patch is exports such as: ``` module Foo ( T(A, B, C) ) where ``` Essentially this patch makes sure that we use the correct lookup functions in order to lookup the names in parent-children export lists. This change highlighted the complexity of this small part of GHC which accounts for the scale. This change was motivated by wanting to remove the `PatternSynonym` constructor from `Parent`. As with all these things, it quickly spiraled out of control into a much larger refactor. Reviewers: simonpj, goldfire, bgamari, austin Subscribers: adamgundry, thomie Differential Revision: https://phabricator.haskell.org/D2179 GHC Trac Issues: #11970
Diffstat (limited to 'compiler')
-rw-r--r--compiler/basicTypes/Avail.hs38
-rw-r--r--compiler/basicTypes/RdrName.hs26
-rw-r--r--compiler/ghc.cabal.in1
-rw-r--r--compiler/iface/LoadIface.hs2
-rw-r--r--compiler/iface/MkIface.hs2
-rw-r--r--compiler/main/HscTypes.hs2
-rw-r--r--compiler/rename/RnEnv.hs4
-rw-r--r--compiler/rename/RnExpr.hs2
-rw-r--r--compiler/rename/RnNames.hs449
-rw-r--r--compiler/rename/RnSource.hs2
-rw-r--r--compiler/typecheck/TcRnDriver.hs140
-rw-r--r--compiler/typecheck/TcRnExports.hs848
-rw-r--r--compiler/typecheck/TcRnMonad.hs23
-rw-r--r--compiler/typecheck/TcType.hs2
-rw-r--r--compiler/types/TyCoRep.hs19
-rw-r--r--compiler/utils/Util.hs10
16 files changed, 923 insertions, 647 deletions
diff --git a/compiler/basicTypes/Avail.hs b/compiler/basicTypes/Avail.hs
index 4dc6cb6cce..8844c3faf5 100644
--- a/compiler/basicTypes/Avail.hs
+++ b/compiler/basicTypes/Avail.hs
@@ -5,9 +5,7 @@
module Avail (
Avails,
AvailInfo(..),
- IsPatSyn(..),
avail,
- patSynAvail,
availsToNameSet,
availsToNameSetWithSelectors,
availsToNameEnv,
@@ -32,7 +30,7 @@ import Data.Function
-- The AvailInfo type
-- | Records what things are "available", i.e. in scope
-data AvailInfo = Avail IsPatSyn Name -- ^ An ordinary identifier in scope
+data AvailInfo = Avail Name -- ^ An ordinary identifier in scope
| AvailTC Name
[Name]
[FieldLabel]
@@ -53,8 +51,6 @@ data AvailInfo = Avail IsPatSyn 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]
@@ -108,7 +104,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`
@@ -116,11 +112,8 @@ 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
+avail n = Avail n
-- -----------------------------------------------------------------------------
-- Operations on AvailInfo
@@ -141,22 +134,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
@@ -171,17 +164,16 @@ instance Outputable AvailInfo where
ppr = pprAvail
pprAvail :: AvailInfo -> SDoc
-pprAvail (Avail _ n)
+pprAvail (Avail n)
= ppr n
pprAvail (AvailTC n ns fs)
= ppr n <> braces (sep [ fsep (punctuate comma (map ppr ns)) <> semi
, fsep (punctuate comma (map (ppr . flLabel) fs))])
instance Binary AvailInfo where
- put_ bh (Avail b aa) = do
+ put_ bh (Avail aa) = do
putByte bh 0
put_ bh aa
- put_ bh b
put_ bh (AvailTC ab ac ad) = do
putByte bh 1
put_ bh ab
@@ -191,18 +183,8 @@ instance Binary AvailInfo where
h <- getByte bh
case h of
0 -> do aa <- get bh
- b <- get bh
- return (Avail b aa)
+ return (Avail 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
diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs
index ba411af1fb..40c152b664 100644
--- a/compiler/basicTypes/RdrName.hs
+++ b/compiler/basicTypes/RdrName.hs
@@ -463,15 +463,13 @@ data Parent = NoParent
| ParentIs { par_is :: Name }
| FldParent { par_is :: Name, par_lbl :: Maybe FieldLabelString }
-- ^ See Note [Parents for record fields]
- | PatternSynonym
- deriving (Eq, Data)
+ deriving (Eq, Data, Typeable)
instance Outputable Parent where
ppr NoParent = empty
ppr (ParentIs n) = text "parent:" <> ppr n
ppr (FldParent n f) = text "fldparent:"
<> ppr n <> colon <> ppr f
- ppr (PatternSynonym) = text "pattern synonym"
plusParent :: Parent -> Parent -> Parent
-- See Note [Combining parents]
@@ -479,7 +477,6 @@ 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 PatternSynonym PatternSynonym = PatternSynonym
plusParent _ _ = NoParent
hasParent :: Parent -> Parent -> Parent
@@ -530,19 +527,12 @@ Note [Parents]
class C Class operations
Associated type constructors
-The `PatternSynonym` constructor is so called as pattern synonyms can be
-bundled with any type constructor (during renaming). In other words, they can
-have any parent.
-
~~~~~~~~~~~~~~~~~~~~~~~~~
Constructor Meaning
~~~~~~~~~~~~~~~~~~~~~~~~
NoParent Can not be bundled with a type constructor.
ParentIs n Can be bundled with the type constructor corresponding to
n.
- PatternSynonym Can be bundled with any type constructor. It is so called
- because only pattern synonyms can be bundled with any type
- constructor.
FldParent See Note [Parents for record fields]
@@ -573,6 +563,16 @@ Note that the OccName used when adding a GRE to the environment
(greOccName) now depends on the parent field: for FldParent it is the
field label, if present, rather than the selector name.
+~~
+
+Record pattern synonym selectors are treated differently. Their parent
+information is `NoParent` in the module in which they are defined. This is because
+a pattern synonym `P` has no parent constructor either.
+
+However, if `f` is bundled with a type constructor `T` then whenever `f` is
+imported the parent will use the `Parent` constructor so the parent of `f` is
+now `T`.
+
Note [Combining parents]
~~~~~~~~~~~~~~~~~~~~~~~~
@@ -683,15 +683,13 @@ greSrcSpan gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss } )
| otherwise = pprPanic "greSrcSpan" (ppr gre)
mkParent :: Name -> AvailInfo -> Parent
-mkParent _ (Avail NotPatSyn _) = NoParent
-mkParent _ (Avail IsPatSyn _) = PatternSynonym
+mkParent _ (Avail _) = NoParent
mkParent n (AvailTC m _ _) | n == m = NoParent
| otherwise = ParentIs m
availFromGRE :: GlobalRdrElt -> AvailInfo
availFromGRE (GRE { gre_name = me, gre_par = parent })
= case parent of
- PatternSynonym -> patSynAvail me
ParentIs p -> AvailTC p [me] []
NoParent | isTyConName me -> AvailTC me [me] []
| otherwise -> avail me
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 67f0aa623f..ec02e1b481 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -429,6 +429,7 @@ Library
TcPatSyn
TcRnDriver
TcBackpack
+ TcRnExports
TcRnMonad
TcRnTypes
TcRules
diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs
index 6005ba5053..97f288f7ba 100644
--- a/compiler/iface/LoadIface.hs
+++ b/compiler/iface/LoadIface.hs
@@ -1017,7 +1017,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
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index 7cff9463ac..0c2c8a4831 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -910,7 +910,7 @@ mkIfaceExports exports
= sortBy stableAvailCmp (map sort_subs exports)
where
sort_subs :: AvailInfo -> AvailInfo
- sort_subs (Avail b n) = Avail b n
+ sort_subs (Avail n) = Avail 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)
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index 7a585f3bba..f1c253f414 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -1954,7 +1954,7 @@ tyThingAvailInfo (ATyCon t)
dcs = tyConDataCons t
flds = tyConFieldLabels t
tyThingAvailInfo (AConLike (PatSynCon p))
- = map patSynAvail ((getName p) : map flSelector (patSynFieldLabels p))
+ = map avail ((getName p) : map flSelector (patSynFieldLabels p))
tyThingAvailInfo t
= [avail (getName t)]
diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index d41e9ef48e..f924f0028f 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -14,7 +14,7 @@ module RnEnv (
lookupLocalOccThLvl_maybe,
lookupTypeOccRn, lookupKindOccRn,
lookupGlobalOccRn, lookupGlobalOccRn_maybe,
- lookupOccRn_overloaded, lookupGlobalOccRn_overloaded,
+ lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, lookupExactOcc,
reportUnboundName, unknownNameSuggestions,
addNameClashErrRn,
@@ -1058,7 +1058,6 @@ lookupImpDeprec iface gre
ParentIs p -> mi_warn_fn iface (nameOccName p)
FldParent { par_is = p } -> mi_warn_fn iface (nameOccName p)
NoParent -> Nothing
- PatternSynonym -> Nothing
{-
Note [Used names with interface not loaded]
@@ -2094,7 +2093,6 @@ 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
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index 87e5507f98..7a0f2c89b9 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -121,7 +121,7 @@ rnExpr (HsVar (L l v))
Just (Right fs@(_:_:_)) -> return (HsRecFld (Ambiguous (L l v)
PlaceHolder)
, mkFVs (map selectorFieldOcc fs));
- Just (Right []) -> error "runExpr/HsVar" } }
+ Just (Right []) -> panic "runExpr/HsVar" } }
rnExpr (HsIPVar v)
= return (HsIPVar v, emptyFVs)
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index 70c6b5fcad..5ea5dacdb4 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -4,16 +4,20 @@
\section[RnNames]{Extracting imported and top-level names in scope}
-}
-{-# LANGUAGE CPP, NondecreasingIndentation #-}
+{-# LANGUAGE CPP, NondecreasingIndentation, MultiWayIf, NamedFieldPuns #-}
module RnNames (
rnImports, getLocalNonValBinders, newRecordSelector,
- rnExports, extendGlobalRdrEnvRn,
+ extendGlobalRdrEnvRn,
gresFromAvails,
calculateAvails,
reportUnusedNames,
plusAvail,
checkConName
+ nubAvails,
+ mkChildEnv,
+ findChildren,
+ dodgyMsg
) where
#include "HsVersions.h"
@@ -22,7 +26,6 @@ import DynFlags
import HsSyn
import TcEnv
import RnEnv
-import RnHsDoc ( rnHsDoc )
import LoadIface ( loadSrcInterface )
import TcRnMonad
import PrelNames
@@ -39,7 +42,6 @@ import Outputable
import Maybes
import SrcLoc
import BasicTypes ( TopLevelFlag(..), StringLiteral(..) )
-import ErrUtils
import Util
import FastString
import FastStringEnv
@@ -1010,7 +1012,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 b n) _ = Avail b n
+trimAvail (Avail n) _ = Avail 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] []
@@ -1023,7 +1025,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
@@ -1067,14 +1069,6 @@ 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` []
@@ -1102,16 +1096,7 @@ lookupChildren all_kids rdr_items
[(either (occNameFS . nameOccName) flLabel x, [x]) | x <- all_kids]
-classifyGREs :: [GlobalRdrElt] -> ([Name], [FieldLabel])
-classifyGREs = partitionEithers . map classifyGRE
-classifyGRE :: GlobalRdrElt -> Either Name FieldLabel
-classifyGRE gre = case gre_par gre of
- FldParent _ Nothing -> Right (FieldLabel (occNameFS (nameOccName n)) False n)
- FldParent _ (Just lbl) -> Right (FieldLabel lbl True n)
- _ -> Left n
- where
- n = gre_name gre
-- | Combines 'AvailInfo's from the same family
-- 'avails' may have several items with the same availName
@@ -1123,375 +1108,8 @@ nubAvails avails = nameEnvElts (foldl add emptyNameEnv avails)
where
add env avail = extendNameEnv_C plusAvail env (availName avail) avail
-{-
-************************************************************************
-* *
-\subsection{Export list processing}
-* *
-************************************************************************
-
-Processing the export list.
-
-You might think that we should record things that appear in the export
-list as ``occurrences'' (using @addOccurrenceName@), but you'd be
-wrong. We do check (here) that they are in scope, but there is no
-need to slurp in their actual declaration (which is what
-@addOccurrenceName@ forces).
-
-Indeed, doing so would big trouble when compiling @PrelBase@, because
-it re-exports @GHC@, which includes @takeMVar#@, whose type includes
-@ConcBase.StateAndSynchVar#@, and so on...
-
-Note [Exports of data families]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose you see (Trac #5306)
- module M where
- import X( F )
- data instance F Int = FInt
-What does M export? AvailTC F [FInt]
- or AvailTC F [F,FInt]?
-The former is strictly right because F isn't defined in this module.
-But then you can never do an explicit import of M, thus
- import M( F( FInt ) )
-because F isn't exported by M. Nor can you import FInt alone from here
- import M( FInt )
-because we don't have syntax to support that. (It looks like an import of
-the type FInt.)
-
-At one point I implemented a compromise:
- * When constructing exports with no export list, or with module M(
- module M ), we add the parent to the exports as well.
- * But not when you see module M( f ), even if f is a
- class method with a parent.
- * Nor when you see module M( module N ), with N /= M.
-
-But the compromise seemed too much of a hack, so we backed it out.
-You just have to use an explicit export list:
- module M( F(..) ) where ...
--}
-
-type ExportAccum -- The type of the accumulating parameter of
- -- the main worker function in rnExports
- = ([LIE Name], -- Export items with Names
- ExportOccMap, -- Tracks exported occurrence names
- [AvailInfo]) -- The accumulated exported stuff
- -- Not nub'd!
-
-emptyExportAccum :: ExportAccum
-emptyExportAccum = ([], emptyOccEnv, [])
-
-type ExportOccMap = OccEnv (Name, IE RdrName)
- -- Tracks what a particular exported OccName
- -- in an export list refers to, and which item
- -- it came from. It's illegal to export two distinct things
- -- that have the same occurrence name
-
-rnExports :: Bool -- False => no 'module M(..) where' header at all
- -> Maybe (Located [LIE RdrName]) -- Nothing => no explicit export list
- -> TcGblEnv
- -> RnM (Maybe [LIE Name], TcGblEnv)
-
- -- Complains if two distinct exports have same OccName
- -- Warns about identical exports.
- -- Complains about exports items not in scope
-
-rnExports explicit_mod exports
- tcg_env@(TcGblEnv { tcg_mod = this_mod,
- tcg_rdr_env = rdr_env,
- tcg_imports = imports })
- = unsetWOptM Opt_WarnWarningsDeprecations $
- -- Do not report deprecations arising from the export
- -- list, to avoid bleating about re-exporting a deprecated
- -- thing (especially via 'module Foo' export item)
- do {
- -- If the module header is omitted altogether, then behave
- -- as if the user had written "module Main(main) where..."
- -- EXCEPT in interactive mode, when we behave as if he had
- -- written "module Main where ..."
- -- Reason: don't want to complain about 'main' not in scope
- -- in interactive mode
- ; dflags <- getDynFlags
- ; let real_exports
- | explicit_mod = exports
- | ghcLink dflags == LinkInMemory = Nothing
- | otherwise
- = Just (noLoc [noLoc (IEVar (noLoc main_RDR_Unqual))])
- -- ToDo: the 'noLoc' here is unhelpful if 'main'
- -- turns out to be out of scope
-
- ; (rn_exports, avails) <- exports_from_avail real_exports rdr_env imports this_mod
- ; traceRn (ppr avails)
- ; let final_avails = nubAvails avails -- Combine families
- final_ns = availsToNameSetWithSelectors final_avails
-
- ; traceRn (text "rnExports: Exports:" <+> ppr final_avails)
-
- ; 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 })
- ; return (rn_exports, new_tcg_env) }
-
-exports_from_avail :: Maybe (Located [LIE RdrName])
- -- Nothing => no explicit export list
- -> GlobalRdrEnv
- -> ImportAvails
- -> Module
- -> RnM (Maybe [LIE Name], [AvailInfo])
-
-exports_from_avail Nothing rdr_env _imports _this_mod
- -- The same as (module M) where M is the current module name,
- -- so that's how we handle it, except we also export the data family
- -- when a data instance is exported.
- = let avails = [ fix_faminst $ availFromGRE gre
- | gre <- globalRdrEnvElts rdr_env
- , isLocalGRE gre ]
- in return (Nothing, avails)
- where
- -- #11164: when we define a data instance
- -- but not data family, re-export the family
- -- 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)
- | not (n `elem` ns)
- = AvailTC n (n:ns) flds
-
- fix_faminst avail = avail
-
-
-exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
- = do (ie_names, _, exports) <- foldlM do_litem emptyExportAccum rdr_items
- return (Just ie_names, exports)
- where
- do_litem :: ExportAccum -> LIE RdrName -> RnM ExportAccum
- do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie)
-
- -- Maps a parent to its in-scope children
- kids_env :: NameEnv [GlobalRdrElt]
- kids_env = mkChildEnv (globalRdrEnvElts rdr_env)
-
- pat_syns :: [GlobalRdrElt]
- pat_syns = findPatSyns (globalRdrEnvElts rdr_env)
-
- imported_modules = [ imv_name imv
- | xs <- moduleEnvElts $ imp_mods imports, imv <- xs ]
-
- exports_from_item :: ExportAccum -> LIE RdrName -> RnM ExportAccum
- exports_from_item acc@(ie_names, occs, exports)
- (L loc (IEModuleContents (L lm mod)))
- | let earlier_mods = [ mod
- | (L _ (IEModuleContents (L _ mod))) <- ie_names ]
- , mod `elem` earlier_mods -- Duplicate export of M
- = do { warnIf (Reason Opt_WarnDuplicateExports) True
- (dupModuleExport mod) ;
- return acc }
-
- | otherwise
- = do { let { exportValid = (mod `elem` imported_modules)
- || (moduleName this_mod == mod)
- ; gre_prs = pickGREsModExp mod (globalRdrEnvElts rdr_env)
- ; new_exports = map (availFromGRE . fst) gre_prs
- ; names = map (gre_name . fst) gre_prs
- ; all_gres = foldr (\(gre1,gre2) gres -> gre1 : gre2 : gres) [] gre_prs
- }
-
- ; checkErr exportValid (moduleNotImported mod)
- ; warnIf (Reason Opt_WarnDodgyExports)
- (exportValid && null gre_prs)
- (nullModuleExport mod)
-
- ; traceRn (text "efa" <+> (ppr mod $$ ppr all_gres))
- ; addUsedGREs all_gres
-
- ; occs' <- check_occs (IEModuleContents (noLoc mod)) occs names
- -- This check_occs not only finds conflicts
- -- between this item and others, but also
- -- internally within this item. That is, if
- -- 'M.x' is in scope in several ways, we'll have
- -- several members of mod_avails with the same
- -- OccName.
- ; traceRn (vcat [ text "export mod" <+> ppr mod
- , ppr new_exports ])
- ; return (L loc (IEModuleContents (L lm mod)) : ie_names,
- occs', new_exports ++ exports) }
-
- exports_from_item acc@(lie_names, occs, exports) (L loc ie)
- | isDoc ie
- = do new_ie <- lookup_doc_ie ie
- return (L loc new_ie : lie_names, occs, exports)
-
- | otherwise
- = do (new_ie, avail) <- lookup_ie ie
- if isUnboundName (ieName new_ie)
- then return acc -- Avoid error cascade
- else do
-
- occs' <- check_occs ie occs (availNames avail)
-
- return (L loc new_ie : lie_names, occs', avail : exports)
-
- -------------
- lookup_ie :: IE RdrName -> RnM (IE Name, AvailInfo)
- lookup_ie (IEVar (L l rdr))
- = do (name, avail) <- lookupGreAvailRn rdr
- return (IEVar (L l name), avail)
-
- lookup_ie (IEThingAbs (L l rdr))
- = do (name, avail) <- lookupGreAvailRn rdr
- return (IEThingAbs (L l name), avail)
-
- lookup_ie ie@(IEThingAll n)
- = do
- (n, avail, flds) <- lookup_ie_all ie n
- let name = unLoc n
- return (IEThingAll n, AvailTC name (name:avail) flds)
-
-
- lookup_ie ie@(IEThingWith l wc sub_rdrs _)
- = do
- (lname, subs, avails, flds) <- lookup_ie_with ie l sub_rdrs
- (_, all_avail, all_flds) <-
- case wc of
- NoIEWildcard -> return (lname, [], [])
- IEWildcard _ -> lookup_ie_all ie l
- let name = unLoc lname
- return (IEThingWith lname wc subs [],
- AvailTC name (name : avails ++ all_avail)
- (flds ++ all_flds))
-
-
-
-
- lookup_ie _ = panic "lookup_ie" -- Other cases covered earlier
-
- lookup_ie_with :: IE RdrName -> Located RdrName -> [Located RdrName]
- -> RnM (Located Name, [Located Name], [Name], [FieldLabel])
- lookup_ie_with ie (L l rdr) sub_rdrs
- = do name <- lookupGlobalOccRn rdr
- let gres = findChildren kids_env name
- mchildren =
- lookupChildren (map classifyGRE (gres ++ pat_syns)) sub_rdrs
- addUsedKids rdr gres
- if isUnboundName name
- then return (L l name, [], [name], [])
- else
- case mchildren of
- Nothing -> do
- addErr (exportItemErr ie)
- return (L l name, [], [name], [])
- Just (non_flds, flds) -> do
- addUsedKids rdr gres
- return (L l name, non_flds
- , map unLoc non_flds
- , map unLoc flds)
- lookup_ie_all :: IE RdrName -> Located RdrName
- -> RnM (Located Name, [Name], [FieldLabel])
- lookup_ie_all ie (L l rdr) =
- do name <- lookupGlobalOccRn rdr
- let gres = findChildren kids_env name
- (non_flds, flds) = classifyGREs gres
- addUsedKids rdr gres
- warnDodgyExports <- woptM Opt_WarnDodgyExports
- when (null gres) $
- if isTyConName name
- then when warnDodgyExports $
- addWarn (Reason Opt_WarnDodgyExports)
- (dodgyExportWarn name)
- else -- This occurs when you export T(..), but
- -- only import T abstractly, or T is a synonym.
- addErr (exportItemErr ie)
- return (L l name, non_flds, flds)
-
- -------------
- lookup_doc_ie :: IE RdrName -> RnM (IE Name)
- lookup_doc_ie (IEGroup lev doc) = do rn_doc <- rnHsDoc doc
- return (IEGroup lev rn_doc)
- lookup_doc_ie (IEDoc doc) = do rn_doc <- rnHsDoc doc
- return (IEDoc rn_doc)
- lookup_doc_ie (IEDocNamed str) = return (IEDocNamed str)
- lookup_doc_ie _ = panic "lookup_doc_ie" -- Other cases covered earlier
-
- -- In an export item M.T(A,B,C), we want to treat the uses of
- -- A,B,C as if they were M.A, M.B, M.C
- -- Happily pickGREs does just the right thing
- addUsedKids :: RdrName -> [GlobalRdrElt] -> RnM ()
- addUsedKids parent_rdr kid_gres = addUsedGREs (pickGREs parent_rdr kid_gres)
-
-isDoc :: IE RdrName -> Bool
-isDoc (IEDoc _) = True
-isDoc (IEDocNamed _) = True
-isDoc (IEGroup _ _) = True
-isDoc _ = False
-
-------------------------------
-check_occs :: IE RdrName -> ExportOccMap -> [Name] -> RnM ExportOccMap
-check_occs ie occs names -- 'names' are the entities specifed by 'ie'
- = foldlM check occs names
- where
- check occs name
- = case lookupOccEnv occs name_occ of
- Nothing -> return (extendOccEnv occs name_occ (name, ie))
-
- Just (name', ie')
- | name == name' -- Duplicate export
- -- But we don't want to warn if the same thing is exported
- -- by two different module exports. See ticket #4478.
- -> do { warnIf (Reason Opt_WarnDuplicateExports)
- (not (dupExport_ok name ie ie'))
- (dupExportWarn name_occ ie ie')
- ; return occs }
-
- | otherwise -- Same occ name but different names: an error
- -> do { global_env <- getGlobalRdrEnv ;
- addErr (exportClashErr global_env name' name ie' ie) ;
- return occs }
- where
- name_occ = nameOccName name
-
-
-dupExport_ok :: Name -> IE RdrName -> IE RdrName -> Bool
--- The Name is exported by both IEs. Is that ok?
--- "No" iff the name is mentioned explicitly in both IEs
--- or one of the IEs mentions the name *alone*
--- "Yes" otherwise
---
--- Examples of "no": module M( f, f )
--- module M( fmap, Functor(..) )
--- module M( module Data.List, head )
---
--- Example of "yes"
--- module M( module A, module B ) where
--- import A( f )
--- import B( f )
---
--- Example of "yes" (Trac #2436)
--- module M( C(..), T(..) ) where
--- class C a where { data T a }
--- instance C Int where { data T Int = TInt }
---
--- Example of "yes" (Trac #2436)
--- module Foo ( T ) where
--- data family T a
--- module Bar ( T(..), module Foo ) where
--- import Foo
--- data instance T Int = TInt
-
-dupExport_ok n ie1 ie2
- = not ( single ie1 || single ie2
- || (explicit_in ie1 && explicit_in ie2) )
- where
- explicit_in (IEModuleContents _) = False -- module M
- explicit_in (IEThingAll r) = nameOccName n == rdrNameOcc (unLoc r) -- T(..)
- explicit_in _ = True
-
- single (IEVar {}) = True
- single (IEThingAbs {}) = True
- single _ = False
{-
*********************************************************
@@ -1827,7 +1445,7 @@ printMinimalImports imports_w_usage
-- 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)
+ to_ie _ (Avail n)
= [IEVar (noLoc n)]
to_ie _ (AvailTC n [m] [])
| n==m = [IEThingAbs (noLoc n)]
@@ -1958,8 +1576,6 @@ illegalImportItemErr = text "Illegal import item"
dodgyImportWarn :: RdrName -> SDoc
dodgyImportWarn item = dodgyMsg (text "import") item
-dodgyExportWarn :: Name -> SDoc
-dodgyExportWarn item = dodgyMsg (text "export") item
dodgyMsg :: (OutputableBndr n, HasOccName n) => SDoc -> n -> SDoc
dodgyMsg kind tc
@@ -1969,32 +1585,6 @@ dodgyMsg kind tc
quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,",
text "but it has none" ]
-exportItemErr :: IE RdrName -> SDoc
-exportItemErr export_item
- = sep [ text "The export item" <+> quotes (ppr export_item),
- text "attempts to export constructors or class methods that are not visible here" ]
-
-exportClashErr :: GlobalRdrEnv -> Name -> Name -> IE RdrName -> IE RdrName
- -> MsgDoc
-exportClashErr global_env name1 name2 ie1 ie2
- = vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon
- , ppr_export ie1' name1'
- , ppr_export ie2' name2' ]
- where
- occ = nameOccName name1
- ppr_export ie name = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+>
- quotes (ppr name))
- 2 (pprNameProvenance (get_gre name)))
-
- -- get_gre finds a GRE for the Name, so that we can show its provenance
- get_gre name
- = case lookupGRE_Name global_env name of
- Just gre -> gre
- Nothing -> pprPanic "exportClashErr" (ppr name)
- get_loc name = greSrcSpan (get_gre name)
- (name1', ie1', name2', ie2') = if get_loc name1 < get_loc name2
- then (name1, ie1, name2, ie2)
- else (name2, ie2, name1, ie1)
addDupDeclErr :: [GlobalRdrElt] -> TcRn ()
addDupDeclErr [] = panic "addDupDeclErr: empty list"
@@ -2012,26 +1602,7 @@ addDupDeclErr gres@(gre : _)
name = gre_name gre
sorted_names = sortWith nameSrcLoc (map gre_name gres)
-dupExportWarn :: OccName -> IE RdrName -> IE RdrName -> SDoc
-dupExportWarn occ_name ie1 ie2
- = hsep [quotes (ppr occ_name),
- text "is exported by", quotes (ppr ie1),
- text "and", quotes (ppr ie2)]
-
-dupModuleExport :: ModuleName -> SDoc
-dupModuleExport mod
- = hsep [text "Duplicate",
- quotes (text "Module" <+> ppr mod),
- text "in export list"]
-
-moduleNotImported :: ModuleName -> SDoc
-moduleNotImported mod
- = text "The export item `module" <+> ppr mod <>
- text "' is not imported"
-
-nullModuleExport :: ModuleName -> SDoc
-nullModuleExport mod
- = text "The export item `module" <+> ppr mod <> ptext (sLit "' exports nothing")
+
missingImportListWarn :: ModuleName -> SDoc
missingImportListWarn mod
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 68038d98bb..2c493d6909 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -2086,7 +2086,7 @@ extendPatSynEnv val_decls local_fix_env thing = do {
names_with_fls <- new_ps val_decls
; let pat_syn_bndrs = concat [ name: map flSelector fields
| (name, fields) <- names_with_fls ]
- ; let avails = map patSynAvail pat_syn_bndrs
+ ; let avails = map avail pat_syn_bndrs
; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env
; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index e24305dcf3..8b95c1b876 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -66,6 +66,7 @@ import RdrName
import TcHsSyn
import TcExpr
import TcRnMonad
+import TcRnExports
import TcEvidence
import PprTyThing( pprTyThing )
import MkIface( tyThingToIfaceDecl )
@@ -95,7 +96,6 @@ import RnEnv
import RnSource
import ErrUtils
import Id
-import IdInfo
import VarEnv
import Module
import UniqDFM
@@ -110,7 +110,6 @@ import ListSetOps
import Outputable
import ConLike
import DataCon
-import PatSyn
import Type
import Class
import BasicTypes hiding( SuccessFlag(..) )
@@ -249,8 +248,7 @@ tcRnModuleTcRnM hsc_env hsc_src
-- Process the export list
traceRn (text "rn4a: before exports");
- (rn_exports, tcg_env) <- rnExports explicit_mod_hdr export_ies tcg_env ;
- tcExports rn_exports ;
+ tcg_env <- tcRnExports explicit_mod_hdr export_ies tcg_env ;
traceRn (text "rn4b: after exports") ;
-- Check that main is exported (must be after rnExports)
@@ -2289,140 +2287,6 @@ loadUnqualIfaces hsc_env ictxt
, unQualOK gre ] -- In scope unqualified
doc = text "Need interface for module whose export(s) are in scope unqualified"
-{-
-******************************************************************************
-** Typechecking module exports
-The renamer makes sure that only the correct pieces of a type or class can be
-bundled with the type or class in the export list.
-
-When it comes to pattern synonyms, in the renamer we have no way to check that
-whether a pattern synonym should be allowed to be bundled or not so we allow
-them to be bundled with any type or class. Here we then check that
-
-1) Pattern synonyms are only bundled with types which are able to
- have data constructors. Datatypes, newtypes and data families.
-2) Are the correct type, for example if P is a synonym
- then if we export Foo(P) then P should be an instance of Foo.
-
-******************************************************************************
--}
-
-tcExports :: Maybe [LIE Name]
- -> TcM ()
-tcExports Nothing = return ()
-tcExports (Just ies) = checkNoErrs $ mapM_ tc_export ies
-
-tc_export :: LIE Name -> TcM ()
-tc_export ie@(L _ (IEThingWith name _ names sels)) =
- addExportErrCtxt ie
- $ tc_export_with (unLoc name) (map unLoc names
- ++ map (flSelector . unLoc) sels)
-tc_export _ = return ()
-
-addExportErrCtxt :: LIE Name -> TcM a -> TcM a
-addExportErrCtxt (L l ie) = setSrcSpan l . addErrCtxt exportCtxt
- where
- exportCtxt = text "In the export:" <+> ppr ie
-
-
--- Note: [Types of TyCon]
---
--- This check appears to be overlly complicated, Richard asked why it
--- is not simply just `isAlgTyCon`. The answer for this is that
--- a classTyCon is also an `AlgTyCon` which we explicitly want to disallow.
--- (It is either a newtype or data depending on the number of methods)
---
---
--- Note: [Typing Pattern Synonym Exports]
--- It proved quite a challenge to precisely specify which pattern synonyms
--- should be allowed to be bundled with which type constructors.
--- In the end it was decided to be quite liberal in what we allow. Below is
--- how Simon described the implementation.
---
--- "Personally I think we should Keep It Simple. All this talk of
--- satisfiability makes me shiver. I suggest this: allow T( P ) in all
--- situations except where `P`'s type is ''visibly incompatible'' with
--- `T`.
---
--- What does "visibly incompatible" mean? `P` is visibly incompatible
--- with
--- `T` if
--- * `P`'s type is of form `... -> S t1 t2`
--- * `S` is a data/newtype constructor distinct from `T`
---
--- Nothing harmful happens if we allow `P` to be exported with
--- a type it can't possibly be useful for, but specifying a tighter
--- relationship is very awkward as you have discovered."
---
--- Note that this allows *any* pattern synonym to be bundled with any
--- datatype type constructor. For example, the following pattern `P` can be
--- bundled with any type.
---
--- ```
--- pattern P :: (A ~ f) => f
--- ```
---
--- So we provide basic type checking in order to help the user out, most
--- pattern synonyms are defined with definite type constructors, but don't
--- actually prevent a library author completely confusing their users if
--- they want to.
-
-exportErrCtxt :: Outputable o => String -> o -> SDoc
-exportErrCtxt herald exp =
- text "In the" <+> text (herald ++ ":") <+> ppr exp
-
-tc_export_with :: Name -- ^ Type constructor
- -> [Name] -- ^ A mixture of data constructors, pattern syonyms
- -- , class methods and record selectors.
- -> TcM ()
-tc_export_with n ns = do
- ty_con <- tcLookupTyCon n
- things <- mapM tcLookupGlobal ns
- let psErr = exportErrCtxt "pattern synonym"
- selErr = exportErrCtxt "pattern synonym record selector"
- ps = [(psErr p,p) | AConLike (PatSynCon p) <- things]
- sels = [(selErr i,p) | AnId i <- things
- , isId i
- , RecSelId {sel_tycon = RecSelPatSyn p} <- [idDetails i]]
- pat_syns = ps ++ sels
-
-
- -- See note [Types of TyCon]
- checkTc ( null pat_syns || isTyConWithSrcDataCons ty_con) assocClassErr
-
- let actual_res_ty =
- mkTyConApp ty_con (mkTyVarTys (tyConTyVars ty_con))
- mapM_ (tc_one_export_with actual_res_ty ty_con ) pat_syns
-
- where
- assocClassErr :: SDoc
- assocClassErr =
- text "Pattern synonyms can be bundled only with datatypes."
-
-
- tc_one_export_with :: TcTauType -- ^ TyCon type
- -> TyCon -- ^ Parent TyCon
- -> (SDoc, PatSyn) -- ^ Corresponding bundled PatSyn
- -- and pretty printed origin
- -> TcM ()
- tc_one_export_with actual_res_ty ty_con (errCtxt, pat_syn)
- = addErrCtxt errCtxt $
- let (_, _, _, _, _, res_ty) = patSynSig pat_syn
- mtycon = tcSplitTyConApp_maybe res_ty
- typeMismatchError :: SDoc
- typeMismatchError =
- text "Pattern synonyms can only be bundled with matching type constructors"
- $$ text "Couldn't match expected type of"
- <+> quotes (ppr actual_res_ty)
- <+> text "with actual type of"
- <+> quotes (ppr res_ty)
- in case mtycon of
- Nothing -> return ()
- Just (p_ty_con, _) ->
- -- See note [Typing Pattern Synonym Exports]
- unless (p_ty_con == ty_con)
- (addErrTc typeMismatchError)
-
{-
diff --git a/compiler/typecheck/TcRnExports.hs b/compiler/typecheck/TcRnExports.hs
new file mode 100644
index 0000000000..e04c3845c0
--- /dev/null
+++ b/compiler/typecheck/TcRnExports.hs
@@ -0,0 +1,848 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE OverloadedStrings #-}
+module TcRnExports (tcRnExports) where
+
+import HsSyn
+import PrelNames
+import RdrName
+import TcRnMonad
+import TcEnv
+import TcMType
+import TcType
+import RnNames
+import RnEnv
+import ErrUtils
+import Id
+import IdInfo
+import Module
+import Name
+import NameEnv
+import NameSet
+import Avail
+import TyCon
+import SrcLoc
+import HscTypes
+import Outputable
+import ConLike
+import DataCon
+import PatSyn
+import FastString
+import Maybes
+import qualified GHC.LanguageExtensions as LangExt
+import Util (capitalise)
+
+
+import Control.Monad
+import DynFlags
+import RnHsDoc ( rnHsDoc )
+import RdrHsSyn ( setRdrNameSpace )
+import Data.Either ( partitionEithers )
+
+{-
+************************************************************************
+* *
+\subsection{Export list processing}
+* *
+************************************************************************
+
+Processing the export list.
+
+You might think that we should record things that appear in the export
+list as ``occurrences'' (using @addOccurrenceName@), but you'd be
+wrong. We do check (here) that they are in scope, but there is no
+need to slurp in their actual declaration (which is what
+@addOccurrenceName@ forces).
+
+Indeed, doing so would big trouble when compiling @PrelBase@, because
+it re-exports @GHC@, which includes @takeMVar#@, whose type includes
+@ConcBase.StateAndSynchVar#@, and so on...
+
+Note [Exports of data families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose you see (Trac #5306)
+ module M where
+ import X( F )
+ data instance F Int = FInt
+What does M export? AvailTC F [FInt]
+ or AvailTC F [F,FInt]?
+The former is strictly right because F isn't defined in this module.
+But then you can never do an explicit import of M, thus
+ import M( F( FInt ) )
+because F isn't exported by M. Nor can you import FInt alone from here
+ import M( FInt )
+because we don't have syntax to support that. (It looks like an import of
+the type FInt.)
+
+At one point I implemented a compromise:
+ * When constructing exports with no export list, or with module M(
+ module M ), we add the parent to the exports as well.
+ * But not when you see module M( f ), even if f is a
+ class method with a parent.
+ * Nor when you see module M( module N ), with N /= M.
+
+But the compromise seemed too much of a hack, so we backed it out.
+You just have to use an explicit export list:
+ module M( F(..) ) where ...
+-}
+
+data ExportAccum -- The type of the accumulating parameter of
+ -- the main worker function in rnExports
+ = ExportAccum
+ [LIE Name] -- Export items with Names
+ ExportOccMap -- Tracks exported occurrence names
+ [AvailInfo] -- The accumulated exported stuff
+ -- Not nub'd!
+
+emptyExportAccum :: ExportAccum
+emptyExportAccum = ExportAccum [] emptyOccEnv []
+
+type ExportOccMap = OccEnv (Name, IE RdrName)
+ -- Tracks what a particular exported OccName
+ -- in an export list refers to, and which item
+ -- it came from. It's illegal to export two distinct things
+ -- that have the same occurrence name
+
+tcRnExports :: Bool -- False => no 'module M(..) where' header at all
+ -> Maybe (Located [LIE RdrName]) -- Nothing => no explicit export list
+ -> TcGblEnv
+ -> RnM TcGblEnv
+
+ -- Complains if two distinct exports have same OccName
+ -- Warns about identical exports.
+ -- Complains about exports items not in scope
+
+tcRnExports explicit_mod exports
+ tcg_env@TcGblEnv { tcg_mod = this_mod,
+ tcg_rdr_env = rdr_env,
+ tcg_imports = imports }
+ = unsetWOptM Opt_WarnWarningsDeprecations $
+ -- Do not report deprecations arising from the export
+ -- list, to avoid bleating about re-exporting a deprecated
+ -- thing (especially via 'module Foo' export item)
+ do {
+ -- If the module header is omitted altogether, then behave
+ -- as if the user had written "module Main(main) where..."
+ -- EXCEPT in interactive mode, when we behave as if he had
+ -- written "module Main where ..."
+ -- Reason: don't want to complain about 'main' not in scope
+ -- in interactive mode
+ ; dflags <- getDynFlags
+ ; let real_exports
+ | explicit_mod = exports
+ | ghcLink dflags == LinkInMemory = Nothing
+ | otherwise
+ = Just (noLoc [noLoc (IEVar (noLoc main_RDR_Unqual))])
+ -- ToDo: the 'noLoc' here is unhelpful if 'main'
+ -- turns out to be out of scope
+
+ ; (rn_exports, avails) <- exports_from_avail real_exports rdr_env imports this_mod
+ ; traceRn (ppr avails)
+ ; let final_avails = nubAvails avails -- Combine families
+ final_ns = availsToNameSetWithSelectors final_avails
+
+ ; traceRn (text "rnExports: Exports:" <+> ppr final_avails)
+
+ ; 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 }
+ ; failIfErrsM
+ ; return new_tcg_env }
+
+exports_from_avail :: Maybe (Located [LIE RdrName])
+ -- Nothing => no explicit export list
+ -> GlobalRdrEnv
+ -> ImportAvails
+ -> Module
+ -> RnM (Maybe [LIE Name], [AvailInfo])
+
+exports_from_avail Nothing rdr_env _imports _this_mod
+ -- The same as (module M) where M is the current module name,
+ -- so that's how we handle it, except we also export the data family
+ -- when a data instance is exported.
+ = let avails = [ fix_faminst $ availFromGRE gre
+ | gre <- globalRdrEnvElts rdr_env
+ , isLocalGRE gre ]
+ in return (Nothing, avails)
+ where
+ -- #11164: when we define a data instance
+ -- but not data family, re-export the family
+ -- 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)
+ | n `notElem` ns
+ = AvailTC n (n:ns) flds
+
+ fix_faminst avail = avail
+
+
+exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
+ = do ExportAccum ie_names _ exports
+ <- checkNoErrs $ foldAndRecoverM do_litem emptyExportAccum rdr_items
+ return (Just ie_names, exports)
+ where
+ do_litem :: ExportAccum -> LIE RdrName -> RnM ExportAccum
+ do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie)
+
+ -- Maps a parent to its in-scope children
+ kids_env :: NameEnv [GlobalRdrElt]
+ kids_env = mkChildEnv (globalRdrEnvElts rdr_env)
+
+
+ imported_modules = [ imv_name imv
+ | xs <- moduleEnvElts $ imp_mods imports, imv <- xs ]
+
+ exports_from_item :: ExportAccum -> LIE RdrName -> RnM ExportAccum
+ exports_from_item acc@(ExportAccum ie_names occs exports)
+ (L loc (IEModuleContents (L lm mod)))
+ | let earlier_mods = [ mod
+ | (L _ (IEModuleContents (L _ mod))) <- ie_names ]
+ , mod `elem` earlier_mods -- Duplicate export of M
+ = do { warnIf (Reason Opt_WarnDuplicateExports) True
+ (dupModuleExport mod) ;
+ return acc }
+
+ | otherwise
+ = do { let { exportValid = (mod `elem` imported_modules)
+ || (moduleName this_mod == mod)
+ ; gre_prs = pickGREsModExp mod (globalRdrEnvElts rdr_env)
+ ; new_exports = map (availFromGRE . fst) gre_prs
+ ; names = map (gre_name . fst) gre_prs
+ ; all_gres = foldr (\(gre1,gre2) gres -> gre1 : gre2 : gres) [] gre_prs
+ }
+
+ ; checkErr exportValid (moduleNotImported mod)
+ ; warnIf (Reason Opt_WarnDodgyExports)
+ (exportValid && null gre_prs)
+ (nullModuleExport mod)
+
+ ; traceRn (text "efa" <+> (ppr mod $$ ppr all_gres))
+ ; addUsedGREs all_gres
+
+ ; occs' <- check_occs (IEModuleContents (noLoc mod)) occs names
+ -- This check_occs not only finds conflicts
+ -- between this item and others, but also
+ -- internally within this item. That is, if
+ -- 'M.x' is in scope in several ways, we'll have
+ -- several members of mod_avails with the same
+ -- OccName.
+ ; traceRn (vcat [ text "export mod" <+> ppr mod
+ , ppr new_exports ])
+ ; return (ExportAccum (L loc (IEModuleContents (L lm mod)) : ie_names)
+ occs'
+ (new_exports ++ exports)) }
+
+ exports_from_item acc@(ExportAccum lie_names occs exports) (L loc ie)
+ | isDoc ie
+ = do new_ie <- lookup_doc_ie ie
+ return (ExportAccum (L loc new_ie : lie_names) occs exports)
+
+ | otherwise
+ = do (new_ie, avail) <-
+ setSrcSpan loc $ lookup_ie ie
+ if isUnboundName (ieName new_ie)
+ then return acc -- Avoid error cascade
+ else do
+
+ occs' <- check_occs ie occs (availNames avail)
+
+ return (ExportAccum (L loc new_ie : lie_names) occs' (avail : exports))
+
+ -------------
+ lookup_ie :: IE RdrName -> RnM (IE Name, AvailInfo)
+ lookup_ie (IEVar (L l rdr))
+ = do (name, avail) <- lookupGreAvailRn rdr
+ return (IEVar (L l name), avail)
+
+ lookup_ie (IEThingAbs (L l rdr))
+ = do (name, avail) <- lookupGreAvailRn rdr
+ return (IEThingAbs (L l name), avail)
+
+ lookup_ie ie@(IEThingAll n)
+ = do
+ (n, avail, flds) <- lookup_ie_all ie n
+ let name = unLoc n
+ return (IEThingAll n, AvailTC name (name:avail) flds)
+
+
+ lookup_ie ie@(IEThingWith l wc sub_rdrs _)
+ = do
+ (lname, subs, avails, flds)
+ <- addExportErrCtxt ie $ lookup_ie_with l sub_rdrs
+ (_, all_avail, all_flds) <-
+ case wc of
+ NoIEWildcard -> return (lname, [], [])
+ IEWildcard _ -> lookup_ie_all ie l
+ let name = unLoc lname
+ return (IEThingWith lname wc subs (map noLoc (flds ++ all_flds)),
+ AvailTC name (name : avails ++ all_avail)
+ (flds ++ all_flds))
+
+
+
+
+ lookup_ie _ = panic "lookup_ie" -- Other cases covered earlier
+
+ lookup_ie_with :: Located RdrName -> [Located RdrName]
+ -> RnM (Located Name, [Located Name], [Name], [FieldLabel])
+ lookup_ie_with (L l rdr) sub_rdrs
+ = do name <- lookupGlobalOccRn rdr
+ (non_flds, flds) <- lookupChildrenExport name sub_rdrs
+ if isUnboundName name
+ then return (L l name, [], [name], [])
+ else return (L l name, non_flds
+ , map unLoc non_flds
+ , map unLoc flds)
+ lookup_ie_all :: IE RdrName -> Located RdrName
+ -> RnM (Located Name, [Name], [FieldLabel])
+ lookup_ie_all ie (L l rdr) =
+ do name <- lookupGlobalOccRn rdr
+ let gres = findChildren kids_env name
+ (non_flds, flds) = classifyGREs gres
+ addUsedKids rdr gres
+ warnDodgyExports <- woptM Opt_WarnDodgyExports
+ when (null gres) $
+ if isTyConName name
+ then when warnDodgyExports $
+ addWarn (Reason Opt_WarnDodgyExports)
+ (dodgyExportWarn name)
+ else -- This occurs when you export T(..), but
+ -- only import T abstractly, or T is a synonym.
+ addErr (exportItemErr ie)
+ return (L l name, non_flds, flds)
+
+ -------------
+ lookup_doc_ie :: IE RdrName -> RnM (IE Name)
+ lookup_doc_ie (IEGroup lev doc) = do rn_doc <- rnHsDoc doc
+ return (IEGroup lev rn_doc)
+ lookup_doc_ie (IEDoc doc) = do rn_doc <- rnHsDoc doc
+ return (IEDoc rn_doc)
+ lookup_doc_ie (IEDocNamed str) = return (IEDocNamed str)
+ lookup_doc_ie _ = panic "lookup_doc_ie" -- Other cases covered earlier
+
+ -- In an export item M.T(A,B,C), we want to treat the uses of
+ -- A,B,C as if they were M.A, M.B, M.C
+ -- Happily pickGREs does just the right thing
+ addUsedKids :: RdrName -> [GlobalRdrElt] -> RnM ()
+ addUsedKids parent_rdr kid_gres = addUsedGREs (pickGREs parent_rdr kid_gres)
+
+classifyGREs :: [GlobalRdrElt] -> ([Name], [FieldLabel])
+classifyGREs = partitionEithers . map classifyGRE
+
+classifyGRE :: GlobalRdrElt -> Either Name FieldLabel
+classifyGRE gre = case gre_par gre of
+ FldParent _ Nothing -> Right (FieldLabel (occNameFS (nameOccName n)) False n)
+ FldParent _ (Just lbl) -> Right (FieldLabel lbl True n)
+ _ -> Left n
+ where
+ n = gre_name gre
+
+isDoc :: IE RdrName -> Bool
+isDoc (IEDoc _) = True
+isDoc (IEDocNamed _) = True
+isDoc (IEGroup _ _) = True
+isDoc _ = False
+
+-- Renaming and typechecking of exports happens after everything else has
+-- been typechecked.
+
+
+
+-- Renaming exports lists is a minefield. Five different things can appear in
+-- children export lists ( T(A, B, C) ).
+-- 1. Record selectors
+-- 2. Type constructors
+-- 3. Data constructors
+-- 4. Pattern Synonyms
+-- 5. Pattern Synonym Selectors
+--
+-- However, things get put into weird name spaces.
+-- 1. Some type constructors are parsed as variables (-.->) for example.
+-- 2. All data constructors are parsed as type constructors
+-- 3. When there is ambiguity, we default type constructors to data
+-- constructors and require the explicit `type` keyword for type
+-- constructors.
+--
+-- This function first establishes the possible namespaces that an
+-- identifier might be in (`choosePossibleNameSpaces`).
+--
+-- Then for each namespace in turn, tries to find the correct identifier
+-- there returning the first positive result or the first terminating
+-- error.
+--
+
+
+-- Records the result of looking up a child.
+data ChildLookupResult
+ = NameNotFound -- We couldn't find a suitable name
+ | NameErr ErrMsg -- We found an unambiguous name
+ -- but there's another error
+ -- we should abort from
+ | FoundName Name -- We resolved to a normal name
+ | FoundFL FieldLabel -- We resolved to a FL
+
+instance Outputable ChildLookupResult where
+ ppr NameNotFound = text "NameNotFound"
+ ppr (FoundName n) = text "Found:" <+> ppr n
+ ppr (FoundFL fls) = text "FoundFL:" <+> ppr fls
+ ppr (NameErr _) = text "Error"
+
+-- Left biased accumulation monoid. Chooses the left-most positive occurence.
+instance Monoid ChildLookupResult where
+ mempty = NameNotFound
+ NameNotFound `mappend` m2 = m2
+ NameErr m `mappend` _ = NameErr m -- Abort from the first error
+ FoundName n1 `mappend` _ = FoundName n1
+ FoundFL fls `mappend` _ = FoundFL fls
+
+lookupChildrenExport :: Name -> [Located RdrName]
+ -> RnM ([Located Name], [Located FieldLabel])
+lookupChildrenExport parent rdr_items =
+ do
+ xs <- mapAndReportM doOne rdr_items
+ return $ partitionEithers xs
+ where
+ -- Pick out the possible namespaces in order of priority
+ -- This is a consequence of how the parser parses all
+ -- data constructors as type constructors.
+ choosePossibleNamespaces :: NameSpace -> [NameSpace]
+ choosePossibleNamespaces ns
+ | ns == varName = [varName, tcName]
+ | ns == tcName = [dataName, tcName]
+ | otherwise = [ns]
+ -- Process an individual child
+ doOne :: Located RdrName
+ -> RnM (Either (Located Name) (Located FieldLabel))
+ doOne n = do
+
+ let bareName = unLoc n
+ lkup v = lookupExportChild parent (setRdrNameSpace bareName v)
+
+ name <- fmap mconcat . mapM lkup $
+ (choosePossibleNamespaces (rdrNameSpace bareName))
+
+ -- Default to data constructors for slightly better error
+ -- messages
+ let unboundName :: RdrName
+ unboundName = if rdrNameSpace bareName == varName
+ then bareName
+ else setRdrNameSpace bareName dataName
+
+ case name of
+ NameNotFound -> Left . L (getLoc n) <$> reportUnboundName unboundName
+ FoundFL fls -> return $ Right (L (getLoc n) fls)
+ FoundName name -> return $ Left (L (getLoc n) name)
+ NameErr err_msg -> reportError err_msg >> failM
+
+
+
+-- | Also captures the current context
+mkNameErr :: SDoc -> TcM ChildLookupResult
+mkNameErr errMsg = do
+ tcinit <- tcInitTidyEnv
+ NameErr <$> mkErrTcM (tcinit, errMsg)
+
+
+-- | Used in export lists to lookup the children.
+lookupExportChild :: Name -> RdrName -> RnM ChildLookupResult
+lookupExportChild parent rdr_name
+ | isUnboundName parent
+ -- Avoid an error cascade
+ = return (FoundName (mkUnboundNameRdr rdr_name))
+
+ | otherwise = do
+ gre_env <- getGlobalRdrEnv
+
+ let original_gres = lookupGRE_RdrName rdr_name gre_env
+ -- Disambiguate the lookup based on the parent information.
+ -- The remaining GREs are things that we *could* export here, note that
+ -- this includes things which have `NoParent`. Those are sorted in
+ -- `checkPatSynParent`.
+ traceRn (text "lookupExportChild original_gres:" <+> ppr original_gres)
+ case picked_gres original_gres of
+ NoOccurence ->
+ noMatchingParentErr original_gres
+ UniqueOccurence g ->
+ checkPatSynParent parent (gre_name g)
+ DisambiguatedOccurence g ->
+ checkFld g
+ AmbiguousOccurence gres ->
+ mkNameClashErr gres
+ where
+ -- Convert into FieldLabel if necessary
+ checkFld :: GlobalRdrElt -> RnM ChildLookupResult
+ checkFld g@GRE{gre_name, gre_par} = do
+ addUsedGRE True g
+ return $ case gre_par of
+ FldParent _ mfs -> do
+ FoundFL (fldParentToFieldLabel gre_name mfs)
+ _ -> FoundName gre_name
+
+ fldParentToFieldLabel :: Name -> Maybe FastString -> FieldLabel
+ fldParentToFieldLabel name mfs =
+ case mfs of
+ Nothing ->
+ let fs = occNameFS (nameOccName name)
+ in FieldLabel fs False name
+ Just fs -> FieldLabel fs True name
+
+ -- Called when we fine no matching GREs after disambiguation but
+ -- there are three situations where this happens.
+ -- 1. There were none to begin with.
+ -- 2. None of the matching ones were the parent but
+ -- a. They were from an overloaded record field so we can report
+ -- a better error
+ -- b. The original lookup was actually ambiguous.
+ -- For example, the case where overloading is off and two
+ -- record fields are in scope from different record
+ -- constructors, neither of which is the parent.
+ noMatchingParentErr :: [GlobalRdrElt] -> RnM ChildLookupResult
+ noMatchingParentErr original_gres = do
+ overload_ok <- xoptM LangExt.DuplicateRecordFields
+ case original_gres of
+ [] -> return NameNotFound
+ [g] -> mkDcErrMsg parent (gre_name g) [p | Just p <- [getParent g]]
+ gss@(g:_:_) ->
+ if all isRecFldGRE gss && overload_ok
+ then mkNameErr (dcErrMsg parent "record selector"
+ (expectJust "noMatchingParentErr" (greLabel g))
+ [ppr p | x <- gss, Just p <- [getParent x]])
+ else mkNameClashErr gss
+
+ mkNameClashErr :: [GlobalRdrElt] -> RnM ChildLookupResult
+ mkNameClashErr gres = do
+ addNameClashErrRn rdr_name gres
+ return (FoundName (gre_name (head gres)))
+
+ getParent :: GlobalRdrElt -> Maybe Name
+ getParent (GRE { gre_par = p } ) =
+ case p of
+ ParentIs cur_parent -> Just cur_parent
+ FldParent { par_is = cur_parent } -> Just cur_parent
+ NoParent -> Nothing
+
+ picked_gres :: [GlobalRdrElt] -> DisambigInfo
+ picked_gres gres
+ | isUnqual rdr_name = mconcat (map right_parent gres)
+ | otherwise = mconcat (map right_parent (pickGREs rdr_name gres))
+
+
+ right_parent :: GlobalRdrElt -> DisambigInfo
+ right_parent p
+ | Just cur_parent <- getParent p
+ = if parent == cur_parent
+ then DisambiguatedOccurence p
+ else NoOccurence
+ | otherwise
+ = UniqueOccurence p
+
+-- This domain specific datatype is used to record why we decided it was
+-- possible that a GRE could be exported with a parent.
+data DisambigInfo
+ = NoOccurence
+ -- The GRE could never be exported. It has the wrong parent.
+ | UniqueOccurence GlobalRdrElt
+ -- The GRE has no parent. It could be a pattern synonym.
+ | DisambiguatedOccurence GlobalRdrElt
+ -- The parent of the GRE is the correct parent
+ | AmbiguousOccurence [GlobalRdrElt]
+ -- For example, two normal identifiers with the same name are in
+ -- scope. They will both be resolved to "UniqueOccurence" and the
+ -- monoid will combine them to this failing case.
+
+instance Monoid DisambigInfo where
+ mempty = NoOccurence
+ -- This is the key line: We prefer disambiguated occurences to other
+ -- names.
+ UniqueOccurence _ `mappend` DisambiguatedOccurence g' = DisambiguatedOccurence g'
+ DisambiguatedOccurence g' `mappend` UniqueOccurence _ = DisambiguatedOccurence g'
+
+
+ NoOccurence `mappend` m = m
+ m `mappend` NoOccurence = m
+ UniqueOccurence g `mappend` UniqueOccurence g' = AmbiguousOccurence [g, g']
+ UniqueOccurence g `mappend` AmbiguousOccurence gs = AmbiguousOccurence (g:gs)
+ DisambiguatedOccurence g `mappend` DisambiguatedOccurence g' = AmbiguousOccurence [g, g']
+ DisambiguatedOccurence g `mappend` AmbiguousOccurence gs = AmbiguousOccurence (g:gs)
+ AmbiguousOccurence gs `mappend` UniqueOccurence g' = AmbiguousOccurence (g':gs)
+ AmbiguousOccurence gs `mappend` DisambiguatedOccurence g' = AmbiguousOccurence (g':gs)
+ AmbiguousOccurence gs `mappend` AmbiguousOccurence gs' = AmbiguousOccurence (gs ++ gs')
+
+
+
+
+--
+-- Note: [Typing Pattern Synonym Exports]
+-- It proved quite a challenge to precisely specify which pattern synonyms
+-- should be allowed to be bundled with which type constructors.
+-- In the end it was decided to be quite liberal in what we allow. Below is
+-- how Simon described the implementation.
+--
+-- "Personally I think we should Keep It Simple. All this talk of
+-- satisfiability makes me shiver. I suggest this: allow T( P ) in all
+-- situations except where `P`'s type is ''visibly incompatible'' with
+-- `T`.
+--
+-- What does "visibly incompatible" mean? `P` is visibly incompatible
+-- with
+-- `T` if
+-- * `P`'s type is of form `... -> S t1 t2`
+-- * `S` is a data/newtype constructor distinct from `T`
+--
+-- Nothing harmful happens if we allow `P` to be exported with
+-- a type it can't possibly be useful for, but specifying a tighter
+-- relationship is very awkward as you have discovered."
+--
+-- Note that this allows *any* pattern synonym to be bundled with any
+-- datatype type constructor. For example, the following pattern `P` can be
+-- bundled with any type.
+--
+-- ```
+-- pattern P :: (A ~ f) => f
+-- ```
+--
+-- So we provide basic type checking in order to help the user out, most
+-- pattern synonyms are defined with definite type constructors, but don't
+-- actually prevent a library author completely confusing their users if
+-- they want to.
+--
+-- So, we check for exactly four things
+-- 1. The name arises from a pattern synonym definition. (Either a pattern
+-- synonym constructor or a pattern synonym selector)
+-- 2. The pattern synonym is only bundled with a datatype or newtype.
+-- 3. Check that the head of the result type constructor is an actual type
+-- constructor and not a type variable. (See above example)
+-- 4. Is so, check that this type constructor is the same as the parent
+-- type constructor.
+--
+--
+-- Note: [Types of TyCon]
+--
+-- This check appears to be overlly complicated, Richard asked why it
+-- is not simply just `isAlgTyCon`. The answer for this is that
+-- a classTyCon is also an `AlgTyCon` which we explicitly want to disallow.
+-- (It is either a newtype or data depending on the number of methods)
+--
+
+-- | Given a resolved name in the children export list and a parent. Decide
+-- whether we are allowed to export the child with the parent.
+-- Invariant: gre_par == NoParent
+-- See note [Typing Pattern Synonym Exports]
+checkPatSynParent :: Name -- ^ Type constructor
+ -> Name -- ^ Either a
+ -- a) Pattern Synonym Constructor
+ -- b) A pattern synonym selector
+ -> TcM ChildLookupResult
+checkPatSynParent parent mpat_syn = do
+ parent_ty_con <- tcLookupTyCon parent
+ mpat_syn_thing <- tcLookupGlobal mpat_syn
+ let expected_res_ty =
+ mkTyConApp parent_ty_con (mkTyVarTys (tyConTyVars parent_ty_con))
+
+ handlePatSyn errCtxt =
+ addErrCtxt errCtxt
+ . tc_one_ps_export_with expected_res_ty parent_ty_con
+ -- 1. Check that the Id was actually from a thing associated with patsyns
+ case mpat_syn_thing of
+ AnId i
+ | isId i ->
+ case idDetails i of
+ RecSelId { sel_tycon = RecSelPatSyn p } -> handlePatSyn (selErr i) p
+ _ -> mkDcErrMsg parent mpat_syn []
+ AConLike (PatSynCon p) -> handlePatSyn (psErr p) p
+ _ -> mkDcErrMsg parent mpat_syn []
+ where
+
+ psErr = exportErrCtxt "pattern synonym"
+ selErr = exportErrCtxt "pattern synonym record selector"
+
+ assocClassErr :: SDoc
+ assocClassErr =
+ text "Pattern synonyms can be bundled only with datatypes."
+
+ tc_one_ps_export_with :: TcTauType -- ^ TyCon type
+ -> TyCon -- ^ Parent TyCon
+ -> PatSyn -- ^ Corresponding bundled PatSyn
+ -- and pretty printed origin
+ -> TcM ChildLookupResult
+ tc_one_ps_export_with expected_res_ty ty_con pat_syn
+
+ -- 2. See note [Types of TyCon]
+ | not $ isTyConWithSrcDataCons ty_con = mkNameErr assocClassErr
+ -- 3. Is the head a type variable?
+ | Nothing <- mtycon = return (FoundName mpat_syn)
+ -- 4. Ok. Check they are actually the same type constructor.
+ | Just p_ty_con <- mtycon, p_ty_con /= ty_con = mkNameErr typeMismatchError
+ -- 5. We passed!
+ | otherwise = return (FoundName mpat_syn)
+
+ where
+ (_, _, _, _, _, res_ty) = patSynSig pat_syn
+ mtycon = fst <$> tcSplitTyConApp_maybe res_ty
+ typeMismatchError :: SDoc
+ typeMismatchError =
+ text "Pattern synonyms can only be bundled with matching type constructors"
+ $$ text "Couldn't match expected type of"
+ <+> quotes (ppr expected_res_ty)
+ <+> text "with actual type of"
+ <+> quotes (ppr res_ty)
+
+
+
+
+{-===========================================================================-}
+
+
+check_occs :: IE RdrName -> ExportOccMap -> [Name] -> RnM ExportOccMap
+check_occs ie occs names -- 'names' are the entities specifed by 'ie'
+ = foldlM check occs names
+ where
+ check occs name
+ = case lookupOccEnv occs name_occ of
+ Nothing -> return (extendOccEnv occs name_occ (name, ie))
+
+ Just (name', ie')
+ | name == name' -- Duplicate export
+ -- But we don't want to warn if the same thing is exported
+ -- by two different module exports. See ticket #4478.
+ -> do { warnIf (Reason Opt_WarnDuplicateExports)
+ (not (dupExport_ok name ie ie'))
+ (dupExportWarn name_occ ie ie')
+ ; return occs }
+
+ | otherwise -- Same occ name but different names: an error
+ -> do { global_env <- getGlobalRdrEnv ;
+ addErr (exportClashErr global_env name' name ie' ie) ;
+ return occs }
+ where
+ name_occ = nameOccName name
+
+
+dupExport_ok :: Name -> IE RdrName -> IE RdrName -> Bool
+-- The Name is exported by both IEs. Is that ok?
+-- "No" iff the name is mentioned explicitly in both IEs
+-- or one of the IEs mentions the name *alone*
+-- "Yes" otherwise
+--
+-- Examples of "no": module M( f, f )
+-- module M( fmap, Functor(..) )
+-- module M( module Data.List, head )
+--
+-- Example of "yes"
+-- module M( module A, module B ) where
+-- import A( f )
+-- import B( f )
+--
+-- Example of "yes" (Trac #2436)
+-- module M( C(..), T(..) ) where
+-- class C a where { data T a }
+-- instance C Int where { data T Int = TInt }
+--
+-- Example of "yes" (Trac #2436)
+-- module Foo ( T ) where
+-- data family T a
+-- module Bar ( T(..), module Foo ) where
+-- import Foo
+-- data instance T Int = TInt
+
+dupExport_ok n ie1 ie2
+ = not ( single ie1 || single ie2
+ || (explicit_in ie1 && explicit_in ie2) )
+ where
+ explicit_in (IEModuleContents _) = False -- module M
+ explicit_in (IEThingAll r) = nameOccName n == rdrNameOcc (unLoc r) -- T(..)
+ explicit_in _ = True
+
+ single IEVar {} = True
+ single IEThingAbs {} = True
+ single _ = False
+
+
+dupModuleExport :: ModuleName -> SDoc
+dupModuleExport mod
+ = hsep [text "Duplicate",
+ quotes (text "Module" <+> ppr mod),
+ text "in export list"]
+
+moduleNotImported :: ModuleName -> SDoc
+moduleNotImported mod
+ = text "The export item `module" <+> ppr mod <>
+ text "' is not imported"
+
+nullModuleExport :: ModuleName -> SDoc
+nullModuleExport mod
+ = text "The export item `module" <+> ppr mod <> ptext (sLit "' exports nothing")
+
+
+dodgyExportWarn :: Name -> SDoc
+dodgyExportWarn item = dodgyMsg (text "export") item
+
+exportErrCtxt :: Outputable o => String -> o -> SDoc
+exportErrCtxt herald exp =
+ text "In the" <+> text (herald ++ ":") <+> ppr exp
+
+
+addExportErrCtxt :: (HasOccName s, OutputableBndr s) => IE s -> TcM a -> TcM a
+addExportErrCtxt ie = addErrCtxt exportCtxt
+ where
+ exportCtxt = text "In the export:" <+> ppr ie
+
+exportItemErr :: IE RdrName -> SDoc
+exportItemErr export_item
+ = sep [ text "The export item" <+> quotes (ppr export_item),
+ text "attempts to export constructors or class methods that are not visible here" ]
+
+
+dupExportWarn :: OccName -> IE RdrName -> IE RdrName -> SDoc
+dupExportWarn occ_name ie1 ie2
+ = hsep [quotes (ppr occ_name),
+ text "is exported by", quotes (ppr ie1),
+ text "and", quotes (ppr ie2)]
+
+dcErrMsg :: Outputable a => Name -> String -> a -> [SDoc] -> SDoc
+dcErrMsg ty_con what_is thing parents =
+ text "The type constructor" <+> quotes (ppr ty_con)
+ <+> text "is not the parent of the" <+> text what_is
+ <+> quotes (ppr thing) <> char '.'
+ $$ text (capitalise what_is)
+ <> text "s can only be exported with their parent type constructor."
+ $$ (case parents of
+ [] -> empty
+ [_] -> text "Parent:"
+ _ -> text "Parents:") <+> fsep (punctuate comma parents)
+
+mkDcErrMsg :: Name -> Name -> [Name] -> TcM ChildLookupResult
+mkDcErrMsg parent thing parents = do
+ ty_thing <- tcLookupGlobal thing
+ mkNameErr (dcErrMsg parent (tyThingCategory' ty_thing) thing (map ppr parents))
+ where
+ tyThingCategory' :: TyThing -> String
+ tyThingCategory' (AnId i)
+ | isRecordSelector i = "record selector"
+ tyThingCategory' i = tyThingCategory i
+
+
+exportClashErr :: GlobalRdrEnv -> Name -> Name -> IE RdrName -> IE RdrName
+ -> MsgDoc
+exportClashErr global_env name1 name2 ie1 ie2
+ = vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon
+ , ppr_export ie1' name1'
+ , ppr_export ie2' name2' ]
+ where
+ occ = nameOccName name1
+ ppr_export ie name = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+>
+ quotes (ppr name))
+ 2 (pprNameProvenance (get_gre name)))
+
+ -- get_gre finds a GRE for the Name, so that we can show its provenance
+ get_gre name
+ = fromMaybe (pprPanic "exportClashErr" (ppr name)) (lookupGRE_Name global_env name)
+ get_loc name = greSrcSpan (get_gre name)
+ (name1', ie1', name2', ie2') = if get_loc name1 < get_loc name2
+ then (name1, ie1, name2, ie2)
+ else (name2, ie2, name1, ie1)
diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs
index e2d4da1e9c..3dff875114 100644
--- a/compiler/typecheck/TcRnMonad.hs
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -66,7 +66,7 @@ module TcRnMonad(
-- * Shared error message stuff: renamer and typechecker
mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError,
- reportWarning, recoverM, mapAndRecoverM, mapAndReportM,
+ reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM,
tryTc,
askNoErrs, discardErrs,
tryTcErrs, tryTcLIE_,
@@ -950,15 +950,20 @@ recoverM recover thing
-----------------------
-mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
--- Drop elements of the input that fail, so the result
+
+-- | Drop elements of the input that fail, so the result
-- list can be shorter than the argument list
-mapAndRecoverM _ [] = return []
-mapAndRecoverM f (x:xs) = do { mb_r <- try_m (f x)
- ; rs <- mapAndRecoverM f xs
- ; return (case mb_r of
- Left _ -> rs
- Right r -> r:rs) }
+mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
+mapAndRecoverM f = fmap reverse . foldAndRecoverM (\xs x -> (:xs) <$> f x ) []
+
+-- | The accumulator is not updated if the action fails
+foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b
+foldAndRecoverM _ acc [] = return acc
+foldAndRecoverM f acc (x:xs) =
+ do { mb_r <- try_m (f acc x)
+ ; case mb_r of
+ Left _ -> foldAndRecoverM f acc xs
+ Right acc' -> foldAndRecoverM f acc' xs }
-- | Succeeds if applying the argument to all members of the lists succeeds,
-- but nevertheless runs it on all arguments, to collect all errors.
diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs
index bd64f541ac..e77a34d4e4 100644
--- a/compiler/typecheck/TcType.hs
+++ b/compiler/typecheck/TcType.hs
@@ -178,7 +178,7 @@ module TcType (
toTcTypeBag, -- :: Bag EvVar -> Bag EvVar
pprKind, pprParendKind, pprSigmaType,
- pprType, pprParendType, pprTypeApp, pprTyThingCategory,
+ pprType, pprParendType, pprTypeApp, pprTyThingCategory, tyThingCategory,
pprTheta, pprThetaArrowTy, pprClassPred,
pprTvBndr, pprTvBndrs,
diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs
index 7525f12439..714212c081 100644
--- a/compiler/types/TyCoRep.hs
+++ b/compiler/types/TyCoRep.hs
@@ -22,7 +22,7 @@ Note [The Type-related module hierarchy]
{-# LANGUAGE ImplicitParams #-}
module TyCoRep (
- TyThing(..), pprTyThingCategory, pprShortTyThing,
+ TyThing(..), tyThingCategory, pprTyThingCategory, pprShortTyThing,
-- * Types
Type(..),
@@ -216,13 +216,16 @@ pprShortTyThing thing
= pprTyThingCategory thing <+> quotes (ppr (getName thing))
pprTyThingCategory :: TyThing -> SDoc
-pprTyThingCategory (ATyCon tc)
- | isClassTyCon tc = text "Class"
- | otherwise = text "Type constructor"
-pprTyThingCategory (ACoAxiom _) = text "Coercion axiom"
-pprTyThingCategory (AnId _) = text "Identifier"
-pprTyThingCategory (AConLike (RealDataCon _)) = text "Data constructor"
-pprTyThingCategory (AConLike (PatSynCon _)) = text "Pattern synonym"
+pprTyThingCategory = text . capitalise . tyThingCategory
+
+tyThingCategory :: TyThing -> String
+tyThingCategory (ATyCon tc)
+ | isClassTyCon tc = "class"
+ | otherwise = "type constructor"
+tyThingCategory (ACoAxiom _) = "coercion axiom"
+tyThingCategory (AnId _) = "identifier"
+tyThingCategory (AConLike (RealDataCon _)) = "data constructor"
+tyThingCategory (AConLike (PatSynCon _)) = "pattern synonym"
{- **********************************************************************
diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs
index 687ced2f47..5f66b53171 100644
--- a/compiler/utils/Util.hs
+++ b/compiler/utils/Util.hs
@@ -56,7 +56,7 @@ module Util (
-- * List operations controlled by another list
takeList, dropList, splitAtList, split,
- dropTail,
+ dropTail, capitalise,
-- * For loop
nTimes,
@@ -147,7 +147,7 @@ import System.IO.Error as IO ( isDoesNotExistError )
import System.Directory ( doesDirectoryExist, getModificationTime )
import System.FilePath
-import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit )
+import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit, toUpper)
import Data.Int
import Data.Ratio ( (%) )
import Data.Ord ( comparing )
@@ -720,6 +720,12 @@ split c s = case rest of
_:rest -> chunk : split c rest
where (chunk, rest) = break (==c) s
+-- | Convert a word to title case by capitalising the first letter
+capitalise :: String -> String
+capitalise [] = []
+capitalise (c:cs) = toUpper c : cs
+
+
{-
************************************************************************
* *
View Lorry Controller Status