Rework renaming of children in export lists.
authorMatthew Pickering <matthewtpickering@gmail.com>
Sat, 8 Oct 2016 09:06:01 +0000 (10:06 +0100)
committerMatthew Pickering <matthewtpickering@gmail.com>
Sat, 8 Oct 2016 09:07:14 +0000 (10:07 +0100)
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

34 files changed:
compiler/basicTypes/Avail.hs
compiler/basicTypes/RdrName.hs
compiler/ghc.cabal.in
compiler/iface/LoadIface.hs
compiler/iface/MkIface.hs
compiler/main/HscTypes.hs
compiler/rename/RnEnv.hs
compiler/rename/RnExpr.hs
compiler/rename/RnNames.hs
compiler/rename/RnSource.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcRnExports.hs [new file with mode: 0644]
compiler/typecheck/TcRnMonad.hs
compiler/typecheck/TcType.hs
compiler/types/TyCoRep.hs
compiler/utils/Util.hs
testsuite/tests/module/MultiExport.hs [new file with mode: 0644]
testsuite/tests/module/MultiExport.stderr [new file with mode: 0644]
testsuite/tests/module/T11970.hs [new file with mode: 0644]
testsuite/tests/module/T11970.stderr [new file with mode: 0644]
testsuite/tests/module/T11970A.hs [new file with mode: 0644]
testsuite/tests/module/T11970A.stderr [new file with mode: 0644]
testsuite/tests/module/T11970A1.hs [new file with mode: 0644]
testsuite/tests/module/T11970B.hs [new file with mode: 0644]
testsuite/tests/module/T11970B.stderr [new file with mode: 0644]
testsuite/tests/module/all.T
testsuite/tests/module/mod10.stderr
testsuite/tests/module/mod17.stderr
testsuite/tests/module/mod3.stderr
testsuite/tests/module/mod4.stderr
testsuite/tests/overloadedrecflds/should_fail/NoParent.hs [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/NoParent.stderr [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/all.T
testsuite/tests/patsyn/should_fail/export-class.stderr

index 4dc6cb6..8844c3f 100644 (file)
@@ -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 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
index ba411af..40c152b 100644 (file)
@@ -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
index 67f0aa6..ec02e1b 100644 (file)
@@ -429,6 +429,7 @@ Library
         TcPatSyn
         TcRnDriver
         TcBackpack
+        TcRnExports
         TcRnMonad
         TcRnTypes
         TcRules
index 6005ba5..97f288f 100644 (file)
@@ -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
index 7cff946..0c2c8a4 100644 (file)
@@ -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)
index 7a585f3..f1c253f 100644 (file)
@@ -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)]
 
index d41e9ef..f924f00 100644 (file)
@@ -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
index 87e5507..7a0f2c8 100644 (file)
@@ -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)
index 70c6b5f..5ea5dac 100644 (file)
@@ -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
index 68038d9..2c493d6 100644 (file)
@@ -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
index e24305d..8b95c1b 100644 (file)
@@ -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 (file)
index 0000000..e04c384
--- /dev/null
@@ -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)
index e2d4da1..3dff875 100644 (file)
@@ -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.
index bd64f54..e77a34d 100644 (file)
@@ -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,
 
index 7525f12..714212c 100644 (file)
@@ -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"
 
 
 {- **********************************************************************
index 687ced2..5f66b53 100644 (file)
@@ -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
+
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/testsuite/tests/module/MultiExport.hs b/testsuite/tests/module/MultiExport.hs
new file mode 100644 (file)
index 0000000..4f8079e
--- /dev/null
@@ -0,0 +1,6 @@
+{-# LANGUAGE PatternSynonyms #-}
+module Foo ( A(x, x) ) where
+
+data A = A  Int
+
+pattern Pattern{x} = A x
diff --git a/testsuite/tests/module/MultiExport.stderr b/testsuite/tests/module/MultiExport.stderr
new file mode 100644 (file)
index 0000000..d117b69
--- /dev/null
@@ -0,0 +1,3 @@
+
+MultiExport.hs:2:14: warning: [-Wduplicate-exports (in -Wdefault)]
+    ‘x’ is exported by ‘A(x, x)’ and ‘A(x, x)’
diff --git a/testsuite/tests/module/T11970.hs b/testsuite/tests/module/T11970.hs
new file mode 100644 (file)
index 0000000..3c90c69
--- /dev/null
@@ -0,0 +1,19 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PatternSynonyms #-}
+
+module T11970(B(recSel), Foo((--.->)), C(C,P,x,Q, B, recSel)) where
+
+pattern D = Nothing
+
+newtype B = B { recSel :: Int }
+
+class Foo a where
+  type (--.->) a
+
+newtype C = C Int
+
+pattern P x = C x
+
+pattern Q{x} = C x
diff --git a/testsuite/tests/module/T11970.stderr b/testsuite/tests/module/T11970.stderr
new file mode 100644 (file)
index 0000000..c6799a1
--- /dev/null
@@ -0,0 +1,12 @@
+
+T11970.hs:6:40: error:
+    • The type constructor ‘C’ is not the parent of the data constructor ‘B’.
+      Data constructors can only be exported with their parent type constructor.
+      Parent: B
+    • In the export: C(C, P, x, Q, B, recSel)
+
+T11970.hs:6:40: error:
+    • The type constructor ‘C’ is not the parent of the record selector ‘recSel’.
+      Record selectors can only be exported with their parent type constructor.
+      Parent: B
+    • In the export: C(C, P, x, Q, B, recSel)
diff --git a/testsuite/tests/module/T11970A.hs b/testsuite/tests/module/T11970A.hs
new file mode 100644 (file)
index 0000000..e9d6e95
--- /dev/null
@@ -0,0 +1,3 @@
+module T11970A ( Fail(a) ) where
+
+import T11970A1 ( Fail(a, b) )
diff --git a/testsuite/tests/module/T11970A.stderr b/testsuite/tests/module/T11970A.stderr
new file mode 100644 (file)
index 0000000..6b478a7
--- /dev/null
@@ -0,0 +1,5 @@
+[1 of 2] Compiling T11970A1         ( T11970A1.hs, T11970A1.o )
+[2 of 2] Compiling T11970A          ( T11970A.hs, T11970A.o )
+
+T11970A.hs:3:1: warning: [-Wunused-imports (in -Wextra)]
+    The import of ‘Fail(b)’ from module ‘T11970A1’ is redundant
diff --git a/testsuite/tests/module/T11970A1.hs b/testsuite/tests/module/T11970A1.hs
new file mode 100644 (file)
index 0000000..6c9c6d2
--- /dev/null
@@ -0,0 +1,3 @@
+module T11970A1 where
+
+data Fail = Fail { a :: Int, b :: Int }
diff --git a/testsuite/tests/module/T11970B.hs b/testsuite/tests/module/T11970B.hs
new file mode 100644 (file)
index 0000000..70a091f
--- /dev/null
@@ -0,0 +1,5 @@
+module T11970B ( A(f) ) where
+
+data A = A
+
+f = A
diff --git a/testsuite/tests/module/T11970B.stderr b/testsuite/tests/module/T11970B.stderr
new file mode 100644 (file)
index 0000000..240a5fa
--- /dev/null
@@ -0,0 +1,5 @@
+
+T11970B.hs:1:18: error:
+    • The type constructor ‘A’ is not the parent of the identifier ‘f’.
+      Identifiers can only be exported with their parent type constructor.
+    • In the export: A(f)
index 89bdcc0..c7097b2 100644 (file)
@@ -350,3 +350,7 @@ test('T10233', extra_clean(['T01233a.hi', 'T01233a.o']),
 test('T11432', normal, compile_fail, [''])
 test('T11432a', normal, compile_fail, [''])
 test('T12026', normal, compile_fail, [''])
+test('T11970', normal, compile_fail, [''])
+test('T11970A', [], multimod_compile, ['T11970A','-Wunused-imports'])
+test('T11970B', normal, compile_fail, [''])
+test('MultiExport', normal, compile, [''])
index dd08d88..1412b6a 100644 (file)
@@ -1,2 +1,4 @@
 
-mod10.hs:2:10: Not in scope: type constructor or class ‘T’
+mod10.hs:2:10: error:
+    • Not in scope: type constructor or class ‘T’
+    • In the export: T(K1)
index 9dcf0e6..91c4ff2 100644 (file)
@@ -1,4 +1,6 @@
 
-mod17.hs:2:10:
-    The export item ‘C(m1, m2, m3, Left)’
-    attempts to export constructors or class methods that are not visible here
+mod17.hs:2:10: error:
+    • The type constructor ‘C’ is not the parent of the data constructor ‘Left’.
+      Data constructors can only be exported with their parent type constructor.
+      Parent: Either
+    • In the export: C(m1, m2, m3, Left)
index 6e7a88b..c0c620e 100644 (file)
@@ -1,4 +1,6 @@
 
-mod3.hs:2:10:
-    The export item ‘T(K1)’
-    attempts to export constructors or class methods that are not visible here
+mod3.hs:2:10: error:
+    • The type constructor ‘T’ is not the parent of the data constructor ‘K1’.
+      Data constructors can only be exported with their parent type constructor.
+      Parent: T'
+    • In the export: T(K1)
index 2391dad..d9e8339 100644 (file)
@@ -1,4 +1,5 @@
 
-mod4.hs:2:10:
-    The export item ‘T(K1, K2)’
-    attempts to export constructors or class methods that are not visible here
+mod4.hs:2:10: error:
+    • Not in scope: data constructor ‘K2’
+      Perhaps you meant ‘K1’ (line 3)
+    • In the export: T(K1, K2)
diff --git a/testsuite/tests/overloadedrecflds/should_fail/NoParent.hs b/testsuite/tests/overloadedrecflds/should_fail/NoParent.hs
new file mode 100644 (file)
index 0000000..2d05c47
--- /dev/null
@@ -0,0 +1,6 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+module NoParent (A(x)) where
+
+data A = A
+data B = B { x :: Int }
+data C = C { x :: String }
diff --git a/testsuite/tests/overloadedrecflds/should_fail/NoParent.stderr b/testsuite/tests/overloadedrecflds/should_fail/NoParent.stderr
new file mode 100644 (file)
index 0000000..309536c
--- /dev/null
@@ -0,0 +1,6 @@
+
+NoParent.hs:2:18: error:
+    • The type constructor ‘A’ is not the parent of the record selector ‘x’.
+      Record selectors can only be exported with their parent type constructor.
+      Parents: C, B
+    • In the export: A(x)
index 3626405..b7d1bff 100644 (file)
@@ -30,3 +30,4 @@ test('T11167_ambiguous_fixity',
      extra_clean([ 'T11167_ambiguous_fixity_A.hi', 'T11167_ambiguous_fixity_A.o'
                  , 'T11167_ambiguous_fixity_B.hi', 'T11167_ambiguous_fixity_B.o' ]),
      multimod_compile_fail, ['T11167_ambiguous_fixity', ''])
+test('NoParent', normal, compile_fail, [''])
index 15be2de..3f8031f 100644 (file)
@@ -1,4 +1,5 @@
 
 export-class.hs:3:13: error:
-    Pattern synonyms can be bundled only with datatypes.
-    In the export: MyClass(.., P)
+    • Pattern synonyms can be bundled only with datatypes.
+    • In the pattern synonym: P
+      In the export: MyClass(.., P)