Basic rip outwip/T11970

working

Add test files

tabs

test

Formatting

Formatting and comments

comment

Add test

Record usages

25 files changed, 340 insertions, 116 deletions

diff --git a/compiler/basicTypes/Avail.hs b/compiler/basicTypes/Avail.hs
index 9595abc3ff..6999b1d34f 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,14 +164,13 @@ instance Outputable AvailInfo where
    ppr = pprAvail
 
 pprAvail :: AvailInfo -> SDoc
-pprAvail (Avail _ n)         = ppr n
+pprAvail (Avail n)         = ppr n
 pprAvail (AvailTC n ns fs) = ppr n <> braces (hsep (punctuate comma (map ppr ns ++ map (ppr . flLabel) fs)))
 
 instance Binary AvailInfo where
-    put_ bh (Avail 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
@@ -188,18 +180,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 0856597805..126c322a44 100644
--- a/compiler/basicTypes/RdrName.hs
+++ b/compiler/basicTypes/RdrName.hs
@@ -450,15 +450,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]
@@ -466,7 +464,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
@@ -517,19 +514,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]
 
 
@@ -560,6 +550,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]
 ~~~~~~~~~~~~~~~~~~~~~~~~
@@ -670,15 +670,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/iface/LoadIface.hs b/compiler/iface/LoadIface.hs
index ba58c9e456..c971d7bf96 100644
--- a/compiler/iface/LoadIface.hs
+++ b/compiler/iface/LoadIface.hs
@@ -908,7 +908,7 @@ When printing export lists, we print like this:
 -}
 
 pprExport :: IfaceExport -> SDoc
-pprExport (Avail _ n)         = ppr n
+pprExport (Avail n)         = ppr n
 pprExport (AvailTC _ [] []) = Outputable.empty
 pprExport (AvailTC n ns0 fs)
   = case ns0 of
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index 537d9601b7..694d98629e 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -875,7 +875,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 200f642984..b79b638d64 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -1872,7 +1872,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 4ab67ad56c..c5b19d39f2 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -4,7 +4,7 @@
 \section[RnEnv]{Environment manipulation for the renamer monad}
 -}
 
-{-# LANGUAGE CPP, MultiWayIf #-}
+{-# LANGUAGE CPP, MultiWayIf, NamedFieldPuns #-}
 
 module RnEnv (
         newTopSrcBinder,
@@ -14,7 +14,7 @@ module RnEnv (
         lookupLocalOccThLvl_maybe,
         lookupTypeOccRn, lookupKindOccRn,
         lookupGlobalOccRn, lookupGlobalOccRn_maybe,
-        lookupOccRn_overloaded, lookupGlobalOccRn_overloaded,
+        lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, lookupExportChild,
         reportUnboundName, unknownNameSuggestions,
         addNameClashErrRn,
 
@@ -549,6 +549,94 @@ lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name
       | FldParent { par_is = parent } <- p = parent == the_parent
       | otherwise                          = False
 
+
+
+-- | Used in export lists to lookup the children.
+lookupExportChild :: Name -> RdrName -> RnM (Maybe (Either Name [FieldLabel]))
+lookupExportChild parent rdr_name
+  | Just n <- isExact_maybe rdr_name   -- This happens in derived code
+  = Just . Left  <$> lookupExactOcc n
+
+  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
+  = Just . Left <$> lookupOrig rdr_mod rdr_occ
+
+  | isUnboundName parent
+    -- Avoid an error cascade from malformed decls:
+    --   instance Int where { foo = e }
+    -- We have already generated an error in rnLHsInstDecl
+  = return (Just (Left (mkUnboundNameRdr rdr_name)))
+
+  | otherwise = do
+  gre_env <- getGlobalRdrEnv
+  overload_ok <- xoptM LangExt.DuplicateRecordFields
+
+
+  case lookupGRE_RdrName rdr_name gre_env of
+    [] -> return Nothing
+    [x] -> do
+      addUsedGRE True x
+      return (Just ((:[]) <$> checkFld x))
+    xs  -> Just <$> checkAmbig overload_ok rdr_name parent xs
+  where
+
+
+        checkFld :: GlobalRdrElt -> Either Name FieldLabel
+        checkFld GRE{gre_name, gre_par} =
+          case gre_par of
+            FldParent _ mfs -> Right (fldParentToFieldLabel gre_name mfs)
+            _ -> Left 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
+
+        checkAmbig :: Bool
+                   -> RdrName
+                   -> Name -- parent
+                   -> [GlobalRdrElt]
+                   -> RnM (Either Name [FieldLabel])
+        checkAmbig overload_ok rdr_name parent gres
+          -- Don't record ambiguous selector usage
+          | all isRecFldGRE
+                   gres && overload_ok
+                = return $
+                    Right [fldParentToFieldLabel (gre_name gre) mfs
+                            | gre <- gres
+                            , let FldParent _ mfs = gre_par gre ]
+          | Just gre <- disambigChildren rdr_name parent gres
+            = do
+                addUsedGRE True gre
+                return ((:[]) <$> checkFld gre)
+          | otherwise = do
+              addNameClashErrRn rdr_name gres
+              return (Left (gre_name (head gres)))
+
+        -- Return the single child with the matching parent
+        disambigChildren :: RdrName -> Name
+                            -> [GlobalRdrElt] -> Maybe GlobalRdrElt
+        disambigChildren rdr_name the_parent gres =
+          case picked_gres of
+            [] -> Nothing
+            [x] -> Just x
+            _  -> Nothing
+          where
+            picked_gres :: [GlobalRdrElt]
+            picked_gres
+              | isUnqual rdr_name = filter right_parent gres
+              | otherwise         = filter right_parent (pickGREs rdr_name gres)
+
+            right_parent (GRE { gre_par = p })
+              | ParentIs parent <- p               =
+                  parent == the_parent
+              | FldParent { par_is = parent } <- p =
+                  parent == the_parent
+              | otherwise                          = False
+
 {-
 Note [Family instance binders]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1081,7 +1169,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]
@@ -2099,7 +2186,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 c92f69e6e3..b848b3352a 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 2fc62637e8..2434bd9cce 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -4,7 +4,7 @@
 \section[RnNames]{Extracting imported and top-level names in scope}
 -}
 
-{-# LANGUAGE CPP, NondecreasingIndentation #-}
+{-# LANGUAGE CPP, NondecreasingIndentation, MultiWayIf, NamedFieldPuns #-}
 
 module RnNames (
         rnImports, getLocalNonValBinders, newRecordSelector,
@@ -12,7 +12,8 @@ module RnNames (
         gresFromAvails,
         calculateAvails,
         reportUnusedNames,
-        checkConName
+        checkConName,
+        exportItemErr
     ) where
 
 #include "HsVersions.h"
@@ -49,6 +50,7 @@ import PatSyn
 import qualified GHC.LanguageExtensions as LangExt
 
 import Control.Monad
+import Data.Foldable (asum)
 import Data.Either      ( partitionEithers, isRight, rights )
 -- import qualified Data.Foldable as Foldable
 import Data.Map         ( Map )
@@ -996,7 +998,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] []
@@ -1009,7 +1011,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
@@ -1053,14 +1055,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` []
@@ -1088,6 +1082,58 @@ lookupChildren all_kids rdr_items
                       [(either (occNameFS . nameOccName) flLabel x, [x]) | x <- all_kids]
 
 
+-- This is a minefield. Three different things can appear in exports list.
+-- 1. Record selectors
+-- 2. Type constructors
+-- 3. Data constructors
+--
+-- 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.
+--
+--
+-- Further to this madness, duplicate record fields complicate
+-- things as we must find the FieldLabel rather than just the Name.
+--
+lookupChildrenExport :: Name -> [Located RdrName]
+                     -> RnM ([Located Name], [Located FieldLabel])
+lookupChildrenExport parent rdr_items =
+  do
+    let
+
+        doOne :: Located RdrName
+              -> RnM (Either (Located Name) [Located FieldLabel])
+        doOne n = do
+
+          let bareName = unLoc n
+              lkup = lookupExportChild parent
+
+          mname <- runMaybeT . asum . map (MaybeT . lkup) $
+            [ (setRdrNameSpace bareName varName)  -- Record selector
+            , (setRdrNameSpace bareName dataName) -- data constructor
+            , (setRdrNameSpace bareName tcName)   -- type constructor
+            ]
+
+          -- Default to data constructors for slightly better error
+          -- messages
+          let unboundName :: RdrName
+              unboundName = if rdrNameSpace bareName == varName
+                                then bareName
+                                else setRdrNameSpace bareName dataName
+
+
+          name <- maybe (Left <$> reportUnboundName unboundName) return mname
+
+          case name of
+            Right fls -> return $ Right (map (L (getLoc n)) fls)
+            Left name -> return $ Left (L (getLoc n) name)
+
+    xs <- mapM doOne rdr_items
+    return $ (fmap concat . partitionEithers) xs
+
 classifyGREs :: [GlobalRdrElt] -> ([Name], [FieldLabel])
 classifyGREs = partitionEithers . map classifyGRE
 
@@ -1219,6 +1265,7 @@ rnExports explicit_mod exports
                                                 Just _  -> rn_exports,
                             tcg_dus = tcg_dus tcg_env `plusDU`
                                       usesOnly final_ns })
+        ; failIfErrsM
         ; return (rn_exports, new_tcg_env) }
 
 exports_from_avail :: Maybe (Located [LIE RdrName])
@@ -1260,8 +1307,6 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
     kids_env :: NameEnv [GlobalRdrElt]
     kids_env = mkChildEnv (globalRdrEnvElts rdr_env)
 
-    pat_syns :: [GlobalRdrElt]
-    pat_syns = findPatSyns (globalRdrEnvElts rdr_env)
 
     imported_modules = [ imv_name imv
                        | xs <- moduleEnvElts $ imp_mods imports, imv <- xs ]
@@ -1339,13 +1384,13 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
 
     lookup_ie ie@(IEThingWith l wc sub_rdrs _)
         = do
-            (lname, subs, avails, flds) <- lookup_ie_with ie l sub_rdrs
+            (lname, subs, avails, flds) <- 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 [],
+            return (IEThingWith lname wc subs (map noLoc (flds ++ all_flds)),
                     AvailTC name (name : avails ++ all_avail)
                                  (flds ++ all_flds))
 
@@ -1354,26 +1399,16 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
 
     lookup_ie _ = panic "lookup_ie"    -- Other cases covered earlier
 
-    lookup_ie_with :: IE RdrName -> Located RdrName -> [Located RdrName]
+    lookup_ie_with :: Located RdrName -> [Located RdrName]
                    -> RnM (Located Name, [Located Name], [Name], [FieldLabel])
-    lookup_ie_with ie (L l rdr) sub_rdrs
+    lookup_ie_with (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
+             (non_flds, flds) <- lookupChildrenExport name sub_rdrs
              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)
+                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) =
@@ -1811,7 +1846,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)]
diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs
index 98ca38bf66..6adb436390 100644
--- a/compiler/rename/RnPat.hs
+++ b/compiler/rename/RnPat.hs
@@ -595,14 +595,14 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
                    -- ignoring the record field itself
                    -- Eg.  data R = R { x,y :: Int }
                    --      f x = R { .. }   -- Should expand to R {x=x}, not R{x=x,y=y}
-                 arg_in_scope lbl
+                 arg_in_scope lbl sel_name
                    = rdr `elemLocalRdrEnv` lcl_env
                    || notNull [ gre | gre <- lookupGRE_RdrName rdr rdr_env
                                     , case gre_par gre of
                                         ParentIs p     -> Just p /= parent_tc
                                         FldParent p _  -> Just p /= parent_tc
-                                        PatternSynonym -> False
-                                        NoParent       -> True ]
+                                        NoParent       -> True
+                                    , gre_name gre /= sel_name ]
                    where
                      rdr = mkVarUnqual lbl
 
@@ -614,7 +614,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
                                 , let gres = lookupGRE_Field_Name rdr_env sel lbl
                                 , not (null gres)  -- Check selector is in scope
                                 , case ctxt of
-                                    HsRecFieldCon {} -> arg_in_scope lbl
+                                    HsRecFieldCon {} -> arg_in_scope lbl sel
                                     _other           -> True ]
 
            ; addUsedGREs (map thdOf3 dot_dot_gres)
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index d43945f7ff..1d216de16a 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -2011,7 +2011,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 9d3bd99ab9..337f277e8d 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -103,6 +103,7 @@ import CoAxiom
 import Annotations
 import Data.List ( sortBy )
 import Data.Ord
+import Data.Char
 import FastString
 import Maybes
 import Util
@@ -111,6 +112,7 @@ import Inst (tcGetInsts)
 import qualified GHC.LanguageExtensions as LangExt
 
 import Control.Monad
+import GHC.Exts (groupWith, sortWith)
 
 #include "HsVersions.h"
 
@@ -2256,9 +2258,6 @@ loadUnqualIfaces hsc_env ictxt
 {-
 ******************************************************************************
 ** 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
@@ -2268,6 +2267,8 @@ them to be bundled with any type or class. Here we then check that
 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.
 
+We also check for normal parent-child relationships here as well.
+
 ******************************************************************************
 -}
 
@@ -2279,8 +2280,8 @@ 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_with (unLoc name) (map unLoc names)
+                                  (map unLoc sels)
 tc_export _ = return ()
 
 addExportErrCtxt :: LIE Name -> TcM a -> TcM a
@@ -2338,38 +2339,89 @@ exportErrCtxt herald exp =
 tc_export_with :: Name  -- ^ Type constructor
                -> [Name] -- ^ A mixture of data constructors, pattern syonyms
                          -- , class methods and record selectors.
+               -> [FieldLbl Name]
                -> TcM ()
-tc_export_with n ns = do
+tc_export_with n ns fls = 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
+  let data_cons = [(c,  dataConTyCon c)
+                        | AConLike (RealDataCon c) <- things ]
+      ps        = [(psErr p,p) | AConLike (PatSynCon p) <- things]
+      ps_sels   = [(selErr i,p)
+                    | AnId i <- things
+                    , isId i
+                    , RecSelId {sel_tycon = RecSelPatSyn p} <- [idDetails i]]
+
+  let actual_res_ty =
+          mkTyConApp ty_con (mkTyVarTys (tyConTyVars ty_con))
+
+  mapM_ (tc_one_dc_export_with ty_con) data_cons
+  mapM_ (tc_flds ty_con)  (partitionFieldLabels fls)
 
+  let pat_syns = ps ++ 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
+  mapM_ (tc_one_ps_export_with actual_res_ty ty_con ) pat_syns
 
   where
+    psErr = exportErrCtxt "pattern synonym"
+    selErr = exportErrCtxt "pattern synonym record selector"
+    -- Partition based on source-level name
+    partitionFieldLabels :: [FieldLbl Name] -> [(FastString, [Name])]
+    partitionFieldLabels = map assemble
+                         . groupWith flLabel
+                         . sortWith flLabel
+      where
+        assemble :: [FieldLbl Name] -> (FastString, [Name])
+        assemble [] = panic "partitionFieldLabels"
+        assemble fls@(fl:_) = (flLabel fl, map flSelector fls)
+
+    dcErrMsg :: Outputable a => TyCon -> String -> a -> [SDoc] -> SDoc
+    dcErrMsg ty_con what_is thing parents =
+            let capitalise [] = []
+                capitalise (c:cs) = toUpper c : cs
+            in
+              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)
+
+    -- This is only used for normal record field labels
+    tc_flds :: TyCon -> (FastString, [Name]) -> TcM ()
+    tc_flds ty_con (fs, flds) = do
+      fldIds <- mapM tcLookupId flds
+      traceTc "tc_flds" (ppr fldIds)
+      let parents = [tc | i <- fldIds, RecSelId { sel_tycon = RecSelData tc }
+                                        <- [idDetails i]]
+      unless (any (ty_con ==) parents) $
+        addErrTc (dcErrMsg ty_con "record selector" fs (map ppr parents))
+
+
+
     assocClassErr :: SDoc
     assocClassErr =
       text "Pattern synonyms can be bundled only with datatypes."
 
+    -- Check whether a data constructor is exported with its parent.
+    tc_one_dc_export_with :: Outputable a =>
+                              TyCon -> (a, TyCon) -> TcM ()
+    tc_one_dc_export_with ty_con (thing, tc) =
+      unless (ty_con == tc)
+        (addErrTc (dcErrMsg ty_con "data constructor" thing [ppr tc]))
+
+
 
-    tc_one_export_with :: TcTauType -- ^ TyCon type
+    tc_one_ps_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)
+    tc_one_ps_export_with actual_res_ty ty_con (errCtxt, pat_syn)
       = addErrCtxt errCtxt $
       let (_, _, _, _, _, res_ty) = patSynSig pat_syn
           mtycon = tcSplitTyConApp_maybe res_ty
diff --git a/testsuite/tests/module/MultiExport.hs b/testsuite/tests/module/MultiExport.hs
new file mode 100644
index 0000000000..4f8079ee81
--- /dev/null
+++ b/testsuite/tests/module/MultiExport.hs
@@ -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
index 0000000000..d117b69c8b
--- /dev/null
+++ b/testsuite/tests/module/MultiExport.stderr
@@ -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
index 0000000000..3c90c6913d
--- /dev/null
+++ b/testsuite/tests/module/T11970.hs
@@ -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
index 0000000000..c6799a1898
--- /dev/null
+++ b/testsuite/tests/module/T11970.stderr
@@ -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
index 0000000000..e9d6e95568
--- /dev/null
+++ b/testsuite/tests/module/T11970A.hs
@@ -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
index 0000000000..6b478a7335
--- /dev/null
+++ b/testsuite/tests/module/T11970A.stderr
@@ -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
index 0000000000..6c9c6d2a7a
--- /dev/null
+++ b/testsuite/tests/module/T11970A1.hs
@@ -0,0 +1,3 @@
+module T11970A1 where
+
+data Fail = Fail { a :: Int, b :: Int }
diff --git a/testsuite/tests/module/all.T b/testsuite/tests/module/all.T
index ca81c5e9e8..10fc4d87c7 100644
--- a/testsuite/tests/module/all.T
+++ b/testsuite/tests/module/all.T
@@ -350,3 +350,6 @@ 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('MultiExport', normal, compile, [''])
diff --git a/testsuite/tests/module/mod17.stderr b/testsuite/tests/module/mod17.stderr
index 9dcf0e612f..91c4ff2731 100644
--- a/testsuite/tests/module/mod17.stderr
+++ b/testsuite/tests/module/mod17.stderr
@@ -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)
diff --git a/testsuite/tests/module/mod3.stderr b/testsuite/tests/module/mod3.stderr
index 6e7a88bd6d..c0c620e240 100644
--- a/testsuite/tests/module/mod3.stderr
+++ b/testsuite/tests/module/mod3.stderr
@@ -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)
diff --git a/testsuite/tests/module/mod4.stderr b/testsuite/tests/module/mod4.stderr
index 2391dadcdc..751600575d 100644
--- a/testsuite/tests/module/mod4.stderr
+++ b/testsuite/tests/module/mod4.stderr
@@ -1,4 +1,4 @@
 
-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)
diff --git a/testsuite/tests/overloadedrecflds/should_fail/NoParent.hs b/testsuite/tests/overloadedrecflds/should_fail/NoParent.hs
new file mode 100644
index 0000000000..2d05c4758e
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/NoParent.hs
@@ -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
index 0000000000..cea2b761c0
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/NoParent.stderr
@@ -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, x)
diff --git a/testsuite/tests/overloadedrecflds/should_fail/all.T b/testsuite/tests/overloadedrecflds/should_fail/all.T
index 362640539e..b7d1bff336 100644
--- a/testsuite/tests/overloadedrecflds/should_fail/all.T
+++ b/testsuite/tests/overloadedrecflds/should_fail/all.T
@@ -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, [''])