Associate pattern synonyms with types in module exports

This patch implements #10653.

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

Updates haddock submodule.

Test Plan: ./validate

Reviewers: goldfire, austin, bgamari

Reviewed By: bgamari

Subscribers: simonpj, gridaphobe, thomie

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

GHC Trac Issues: #10653

17 files changed, 408 insertions, 94 deletions

diff --git a/compiler/basicTypes/Avail.hs b/compiler/basicTypes/Avail.hs
index 26bf6eed4d..9e5737f82e 100644
--- a/compiler/basicTypes/Avail.hs
+++ b/compiler/basicTypes/Avail.hs
@@ -7,6 +7,9 @@
 module Avail (
     Avails,
     AvailInfo(..),
+    IsPatSyn(..),
+    avail,
+    patSynAvail,
     availsToNameSet,
     availsToNameSetWithSelectors,
     availsToNameEnv,
@@ -31,7 +34,7 @@ import Data.Function
 -- The AvailInfo type
 
 -- | Records what things are "available", i.e. in scope
-data AvailInfo = Avail Name      -- ^ An ordinary identifier in scope
+data AvailInfo = Avail IsPatSyn Name      -- ^ An ordinary identifier in scope
                | AvailTC Name
                          [Name]
                          [FieldLabel]
@@ -52,6 +55,8 @@ data AvailInfo = Avail Name      -- ^ An ordinary identifier in scope
                         -- Equality used when deciding if the
                         -- interface has changed
 
+data IsPatSyn = NotPatSyn | IsPatSyn deriving Eq
+
 -- | A collection of 'AvailInfo' - several things that are \"available\"
 type Avails = [AvailInfo]
 
@@ -105,7 +110,7 @@ modules.
 
 -- | Compare lexicographically
 stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering
-stableAvailCmp (Avail n1)         (Avail n2)     = n1 `stableNameCmp` n2
+stableAvailCmp (Avail _ n1)       (Avail _ n2)   = n1 `stableNameCmp` n2
 stableAvailCmp (Avail {})         (AvailTC {})   = LT
 stableAvailCmp (AvailTC n ns nfs) (AvailTC m ms mfs) =
     (n `stableNameCmp` m) `thenCmp`
@@ -113,6 +118,12 @@ stableAvailCmp (AvailTC n ns nfs) (AvailTC m ms mfs) =
     (cmpList (stableNameCmp `on` flSelector) nfs mfs)
 stableAvailCmp (AvailTC {})       (Avail {})     = GT
 
+patSynAvail :: Name -> AvailInfo
+patSynAvail n = Avail IsPatSyn n
+
+avail :: Name -> AvailInfo
+avail n = Avail NotPatSyn n
+
 -- -----------------------------------------------------------------------------
 -- Operations on AvailInfo
 
@@ -132,22 +143,22 @@ availsToNameEnv avails = foldr add emptyNameEnv avails
 -- | Just the main name made available, i.e. not the available pieces
 -- of type or class brought into scope by the 'GenAvailInfo'
 availName :: AvailInfo -> Name
-availName (Avail n)       = n
+availName (Avail _ n)     = n
 availName (AvailTC n _ _) = n
 
 -- | All names made available by the availability information (excluding overloaded selectors)
 availNames :: AvailInfo -> [Name]
-availNames (Avail n)         = [n]
+availNames (Avail _ n)         = [n]
 availNames (AvailTC _ ns fs) = ns ++ [ flSelector f | f <- fs, not (flIsOverloaded f) ]
 
 -- | All names made available by the availability information (including overloaded selectors)
 availNamesWithSelectors :: AvailInfo -> [Name]
-availNamesWithSelectors (Avail n)         = [n]
+availNamesWithSelectors (Avail _ n)         = [n]
 availNamesWithSelectors (AvailTC _ ns fs) = ns ++ map flSelector fs
 
 -- | Names for non-fields made available by the availability information
 availNonFldNames :: AvailInfo -> [Name]
-availNonFldNames (Avail n)        = [n]
+availNonFldNames (Avail _ n)        = [n]
 availNonFldNames (AvailTC _ ns _) = ns
 
 -- | Fields made available by the availability information
@@ -155,7 +166,6 @@ availFlds :: AvailInfo -> [FieldLabel]
 availFlds (AvailTC _ _ fs) = fs
 availFlds _                = []
 
-
 -- -----------------------------------------------------------------------------
 -- Printing
 
@@ -163,13 +173,14 @@ instance Outputable AvailInfo where
    ppr = pprAvail
 
 pprAvail :: AvailInfo -> SDoc
-pprAvail (Avail n)         = ppr n
+pprAvail (Avail _ n)         = ppr n
 pprAvail (AvailTC n ns fs) = ppr n <> braces (hsep (punctuate comma (map ppr ns ++ map (ppr . flLabel) fs)))
 
 instance Binary AvailInfo where
-    put_ bh (Avail aa) = do
+    put_ bh (Avail b aa) = do
             putByte bh 0
             put_ bh aa
+            put_ bh b
     put_ bh (AvailTC ab ac ad) = do
             putByte bh 1
             put_ bh ab
@@ -179,8 +190,18 @@ instance Binary AvailInfo where
             h <- getByte bh
             case h of
               0 -> do aa <- get bh
-                      return (Avail aa)
+                      b  <- get bh
+                      return (Avail b aa)
               _ -> do ab <- get bh
                       ac <- get bh
                       ad <- get bh
                       return (AvailTC ab ac ad)
+
+instance Binary IsPatSyn where
+  put_ bh IsPatSyn = putByte bh 0
+  put_ bh NotPatSyn = putByte bh 1
+  get bh = do
+    h <- getByte bh
+    case h of
+      0 -> return IsPatSyn
+      _ -> return NotPatSyn
diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs
index 8af8df4000..e3d1216e18 100644
--- a/compiler/basicTypes/RdrName.hs
+++ b/compiler/basicTypes/RdrName.hs
@@ -428,6 +428,7 @@ data Parent = NoParent
             | ParentIs  { par_is :: Name }
             | FldParent { par_is :: Name, par_lbl :: Maybe FieldLabelString }
               -- ^ See Note [Parents for record fields]
+            | PatternSynonym
             deriving (Eq)
 
 instance Outputable Parent where
@@ -435,6 +436,7 @@ instance Outputable Parent where
    ppr (ParentIs n)    = ptext (sLit "parent:") <> ppr n
    ppr (FldParent n f) = ptext (sLit "fldparent:")
                              <> ppr n <> colon <> ppr f
+   ppr (PatternSynonym) = ptext (sLit "pattern synonym")
 
 plusParent :: Parent -> Parent -> Parent
 -- See Note [Combining parents]
@@ -442,7 +444,8 @@ plusParent p1@(ParentIs _)    p2 = hasParent p1 p2
 plusParent p1@(FldParent _ _) p2 = hasParent p1 p2
 plusParent p1 p2@(ParentIs _)    = hasParent p2 p1
 plusParent p1 p2@(FldParent _ _) = hasParent p2 p1
-plusParent NoParent NoParent     = NoParent
+plusParent PatternSynonym PatternSynonym = PatternSynonym
+plusParent _ _                   = NoParent
 
 hasParent :: Parent -> Parent -> Parent
 #ifdef DEBUG
@@ -628,18 +631,20 @@ greSrcSpan gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss } )
   | otherwise     = pprPanic "greSrcSpan" (ppr gre)
 
 mkParent :: Name -> AvailInfo -> Parent
-mkParent _ (Avail _)                   = NoParent
+mkParent _ (Avail NotPatSyn _)           = NoParent
+mkParent _ (Avail IsPatSyn  _)           = PatternSynonym
 mkParent n (AvailTC m _ _) | n == m    = NoParent
-                           | otherwise = ParentIs m
+                         | otherwise = ParentIs m
 
 availFromGRE :: GlobalRdrElt -> AvailInfo
 availFromGRE (GRE { gre_name = me, gre_par = parent })
   = case parent of
       ParentIs p                  -> AvailTC p [me] []
       NoParent   | isTyConName me -> AvailTC me [me] []
-                 | otherwise      -> Avail   me
+                 | otherwise      -> avail   me
       FldParent p Nothing         -> AvailTC p [] [FieldLabel (occNameFS $ nameOccName me) False me]
       FldParent p (Just lbl)      -> AvailTC p [] [FieldLabel lbl True me]
+      PatternSynonym              -> patSynAvail me
 
 emptyGlobalRdrEnv :: GlobalRdrEnv
 emptyGlobalRdrEnv = emptyOccEnv
diff --git a/compiler/hsSyn/HsImpExp.hs b/compiler/hsSyn/HsImpExp.hs
index a60f86ea65..b4108bfc31 100644
--- a/compiler/hsSyn/HsImpExp.hs
+++ b/compiler/hsSyn/HsImpExp.hs
@@ -154,7 +154,10 @@ data IE name
 
         -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | IEThingWith (Located name) [Located name] [Located (FieldLbl name)]
+  | IEThingWith (Located name)
+                IEWildcard
+                [Located name]
+                [Located (FieldLbl name)]
                  -- ^ Class/Type plus some methods/constructors
                  -- and record fields; see Note [IEThingWith]
         -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen',
@@ -173,6 +176,8 @@ data IE name
   | IEDocNamed          String           -- ^ Reference to named doc
   deriving (Eq, Data, Typeable)
 
+data IEWildcard = NoIEWildcard | IEWildcard Int deriving (Eq, Data, Typeable)
+
 {-
 Note [IEThingWith]
 ~~~~~~~~~~~~~~~~~~
@@ -191,12 +196,22 @@ See Note [Representing fields in AvailInfo] in Avail for more details.
 -}
 
 ieName :: IE name -> name
-ieName (IEVar (L _ n))           = n
-ieName (IEThingAbs  (L _ n))     = n
-ieName (IEThingWith (L _ n) _ _) = n
-ieName (IEThingAll  (L _ n))     = n
+ieName (IEVar (L _ n))              = n
+ieName (IEThingAbs  (L _ n))        = n
+ieName (IEThingWith (L _ n) _ _ _)  = n
+ieName (IEThingAll  (L _ n))        = n
 ieName _ = panic "ieName failed pattern match!"
 
+ieNames :: IE a -> [a]
+ieNames (IEVar       (L _ n)   )     = [n]
+ieNames (IEThingAbs  (L _ n)   )     = [n]
+ieNames (IEThingAll  (L _ n)   )     = [n]
+ieNames (IEThingWith (L _ n) _ ns _) = n : map unLoc ns
+ieNames (IEModuleContents _    )     = []
+ieNames (IEGroup          _ _  )     = []
+ieNames (IEDoc            _    )     = []
+ieNames (IEDocNamed       _    )     = []
+
 pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc
 pprImpExp name = type_pref <+> pprPrefixOcc name
     where
@@ -208,12 +223,20 @@ instance (HasOccName name, OutputableBndr name) => Outputable (IE name) where
     ppr (IEVar          var)    = pprPrefixOcc (unLoc var)
     ppr (IEThingAbs     thing)  = pprImpExp (unLoc thing)
     ppr (IEThingAll      thing) = hcat [pprImpExp (unLoc thing), text "(..)"]
-    ppr (IEThingWith thing withs flds)
+    ppr (IEThingWith thing wc withs flds)
         = pprImpExp (unLoc thing) <> parens (fsep (punctuate comma
-                                            (map pprImpExp (map unLoc withs) ++
-                                                map (ppr . flLabel . unLoc) flds)))
+                                              ppWiths ++
+                                              map (ppr . flLabel . unLoc) flds))
+      where
+        ppWiths =
+          case wc of
+              NoIEWildcard ->
+                map (pprImpExp . unLoc) withs
+              IEWildcard pos ->
+                let (bs, as) = splitAt pos (map (pprImpExp . unLoc) withs)
+                in bs ++ [text ".."] ++ as
     ppr (IEModuleContents mod')
         = ptext (sLit "module") <+> ppr mod'
-    ppr (IEGroup n _)           = text ("<IEGroup: " ++ (show n) ++ ">")
+    ppr (IEGroup n _)           = text ("<IEGroup: " ++ show n ++ ">")
     ppr (IEDoc doc)             = ppr doc
     ppr (IEDocNamed string)     = text ("<IEDocNamed: " ++ string ++ ">")
diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs
index cbf8048db2..d2e16c67cb 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
                                  (n':ns) | n==n' -> ppr n <> pp_export ns fs
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index b7bdc38ae5..d48d6e78fb 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -1080,7 +1080,7 @@ mkIfaceExports exports
   = sortBy stableAvailCmp (map sort_subs exports)
   where
     sort_subs :: AvailInfo -> AvailInfo
-    sort_subs (Avail n) = Avail n
+    sort_subs (Avail b n) = Avail b n
     sort_subs (AvailTC n [] fs) = AvailTC n [] (sort_flds fs)
     sort_subs (AvailTC n (m:ms) fs)
        | n==m      = AvailTC n (m:sortBy stableNameCmp ms) (sort_flds fs)
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index b711ffea51..5056f694a2 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -1799,7 +1799,7 @@ tyThingAvailInfo (ATyCon t)
                    dcs  = tyConDataCons t
                    flds = tyConFieldLabels t
 tyThingAvailInfo t
-   = Avail (getName t)
+   = avail (getName t)
 
 {-
 ************************************************************************
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index d72f50d871..e4ff162181 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -33,6 +33,7 @@ import Control.Monad    ( unless, liftM )
 import GHC.Exts
 import Data.Char
 import Control.Monad    ( mplus )
+import Control.Applicative ((<$))
 
 -- compiler/hsSyn
 import HsSyn
@@ -79,6 +80,7 @@ import TysWiredIn       ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilD
 
 -- compiler/utils
 import Util             ( looksLikePackageName )
+import Prelude
 
 }
 
@@ -632,9 +634,8 @@ exp_doc :: { OrdList (LIE RdrName) }
    -- No longer allow things like [] and (,,,) to be exported
    -- They are built in syntax, always available
 export  :: { OrdList (LIE RdrName) }
-        : qcname_ext export_subspec  {% amsu (sLL $1 $> (mkModuleImpExp $1
-                                                    (snd $ unLoc $2)))
-                                             (fst $ unLoc $2) }
+        : qcname_ext export_subspec  {% mkModuleImpExp $1 (snd $ unLoc $2)
+                                          >>= \ie -> amsu (sLL $1 $> ie) (fst $ unLoc $2) }
         |  'module' modid            {% amsu (sLL $1 $> (IEModuleContents $2))
                                              [mj AnnModule $1] }
         |  'pattern' qcon            {% amsu (sLL $1 $> (IEVar $2))
@@ -642,18 +643,34 @@ export  :: { OrdList (LIE RdrName) }
 
 export_subspec :: { Located ([AddAnn],ImpExpSubSpec) }
         : {- empty -}             { sL0 ([],ImpExpAbs) }
-        | '(' '..' ')'            { sLL $1 $> ([mop $1,mcp $3,mj AnnDotdot $2]
-                                       , ImpExpAll) }
-        | '(' ')'                 { sLL $1 $> ([mop $1,mcp $2],ImpExpList []) }
-        | '(' qcnames ')'         { sLL $1 $> ([mop $1,mcp $3],ImpExpList (reverse $2)) }
-
-qcnames :: { [Located RdrName] }     -- A reversed list
-        :  qcnames ',' qcname_ext       {% (aa (head $1) (AnnComma, $2)) >>
-                                           return ($3  : $1) }
-        |  qcname_ext                   { [$1]  }
-
-qcname_ext :: { Located RdrName }       -- Variable or data constructor
-                                        -- or tagged type constructor
+        | '(' qcnames ')'         {% mkImpExpSubSpec (reverse (snd $2))
+                                      >>= \(as,ie) -> return $ sLL $1 $>
+                                            (as ++ [mop $1,mcp $3] ++ fst $2, ie) }
+
+
+qcnames :: { ([AddAnn], [Located (Maybe RdrName)]) }
+  : {- empty -}                   { ([],[]) }
+  | qcnames1                      { $1 }
+
+qcnames1 :: { ([AddAnn], [Located (Maybe RdrName)]) }     -- A reversed list
+        :  qcnames1 ',' qcname_ext_w_wildcard  {% case (last (snd $1)) of
+                                                    l@(L _ Nothing) ->
+                                                      return ([mj AnnComma $2, mj AnnDotdot l]
+                                                              ,($3  : snd $1))
+                                                    l -> (aa l (AnnComma, $2) >>
+                                                          return (fst $1, $3 : snd $1)) }
+
+
+        -- Annotations readded in mkImpExpSubSpec
+        |  qcname_ext_w_wildcard                   { ([],[$1])  }
+
+-- Variable, data constructor or wildcard
+-- or tagged type constructor
+qcname_ext_w_wildcard :: { Located (Maybe RdrName) }
+        :  qcname_ext               { Just `fmap` $1 }
+        |  '..'                     { Nothing <$ $1 }
+
+qcname_ext :: { Located RdrName }
         :  qcname                   { $1 }
         |  'type' oqtycon           {% amms (mkTypeImpExp (sLL $1 $> (unLoc $2)))
                                             [mj AnnType $1,mj AnnVal $2] }
@@ -726,7 +743,10 @@ maybeas :: { ([AddAnn],Located (Maybe ModuleName)) }
         | {- empty -}                          { ([],noLoc Nothing) }
 
 maybeimpspec :: { Located (Maybe (Bool, Located [LIE RdrName])) }
-        : impspec                  { L (gl $1) (Just (unLoc $1)) }
+        : impspec                  {% let (b, ie) = unLoc $1 in
+                                       checkImportSpec ie
+                                        >>= \checkedIe ->
+                                          return (L (gl $1) (Just (b, checkedIe)))  }
         | {- empty -}              { noLoc Nothing }
 
 impspec :: { Located (Bool, Located [LIE RdrName]) }
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 2d2b43b480..b24ba0968a 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -56,7 +56,9 @@ module RdrHsSyn (
         -- Help with processing exports
         ImpExpSubSpec(..),
         mkModuleImpExp,
-        mkTypeImpExp
+        mkTypeImpExp,
+        mkImpExpSubSpec,
+        checkImportSpec
 
     ) where
 
@@ -87,6 +89,7 @@ import FastString
 import Maybes
 import Util
 import ApiAnnotation
+import Data.List
 
 #if __GLASGOW_HASKELL__ < 709
 import Control.Applicative ((<$>))
@@ -1328,16 +1331,31 @@ mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
 --------------------------------------------------------------------------------
 -- Help with module system imports/exports
 
-data ImpExpSubSpec = ImpExpAbs | ImpExpAll | ImpExpList [Located RdrName]
+data ImpExpSubSpec = ImpExpAbs
+                   | ImpExpAll
+                   | ImpExpList [Located RdrName]
+                   | ImpExpAllWith [Located (Maybe RdrName)]
 
-mkModuleImpExp :: Located RdrName -> ImpExpSubSpec -> IE RdrName
+mkModuleImpExp :: Located RdrName -> ImpExpSubSpec -> P (IE RdrName)
 mkModuleImpExp n@(L l name) subs =
   case subs of
     ImpExpAbs
-      | isVarNameSpace (rdrNameSpace name) -> IEVar       n
-      | otherwise                          -> IEThingAbs  (L l name)
-    ImpExpAll                              -> IEThingAll  (L l name)
-    ImpExpList xs                          -> IEThingWith (L l name) xs []
+      | isVarNameSpace (rdrNameSpace name) -> return $ IEVar  n
+      | otherwise                          -> return $ IEThingAbs  (L l name)
+    ImpExpAll                              -> return $ IEThingAll  (L l name)
+    ImpExpList xs                          ->
+      return $ IEThingWith (L l name) NoIEWildcard xs []
+    ImpExpAllWith xs                       ->
+      do allowed <- extension patternSynonymsEnabled
+         if allowed
+          then
+            let withs = map unLoc xs
+                pos   = maybe NoIEWildcard IEWildcard
+                          (findIndex isNothing withs)
+                ies   = [L l n | L l (Just n) <- xs]
+            in return (IEThingWith (L l name) pos ies [])
+          else parseErrorSDoc l
+            (text "Illegal export form (use PatternSynonyms to enable)")
 
 mkTypeImpExp :: Located RdrName   -- TcCls or Var name space
              -> P (Located RdrName)
@@ -1348,6 +1366,28 @@ mkTypeImpExp name =
        else parseErrorSDoc (getLoc name)
               (text "Illegal keyword 'type' (use ExplicitNamespaces to enable)")
 
+checkImportSpec :: Located [LIE RdrName] -> P (Located [LIE RdrName])
+checkImportSpec ie@(L _ specs) =
+    case [l | (L l (IEThingWith _ (IEWildcard _) _ _)) <- specs] of
+      [] -> return ie
+      (l:_) -> importSpecError l
+  where
+    importSpecError l =
+      parseErrorSDoc l
+        (text "Illegal import form, this syntax can only be used to bundle"
+        $+$ text "pattern synonyms with types in module exports.")
+
+-- In the correct order
+mkImpExpSubSpec :: [Located (Maybe RdrName)] -> P ([AddAnn], ImpExpSubSpec)
+mkImpExpSubSpec [] = return ([], ImpExpList [])
+mkImpExpSubSpec [L l Nothing] =
+  return ([\s -> addAnnotation l AnnDotdot s], ImpExpAll)
+mkImpExpSubSpec xs =
+  if (any (isNothing . unLoc) xs)
+    then return $ ([], ImpExpAllWith xs)
+    else return $ ([], ImpExpList ([L l x | L l (Just x) <- xs]))
+
+
 -----------------------------------------------------------------------------
 -- Misc utils
 
diff --git a/compiler/prelude/PrelInfo.hs b/compiler/prelude/PrelInfo.hs
index f76b62ee00..1a7e056ada 100644
--- a/compiler/prelude/PrelInfo.hs
+++ b/compiler/prelude/PrelInfo.hs
@@ -151,8 +151,8 @@ wired-in Ids.
 
 ghcPrimExports :: [IfaceExport]
 ghcPrimExports
- = map (Avail . idName) ghcPrimIds ++
-   map (Avail . idName . primOpId) allThePrimOps ++
+ = map (avail . idName) ghcPrimIds ++
+   map (avail . idName . primOpId) allThePrimOps ++
    [ AvailTC n [n] []
    | tc <- funTyCon : primTyCons, let n = tyConName tc  ]
 
diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index 0404013f0f..8893fc5fe2 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -922,7 +922,7 @@ lookupGreAvailRn rdr_name
             Nothing  ->
     do  { traceRn (text "lookupGreRn" <+> ppr rdr_name)
         ; let name = mkUnboundName rdr_name
-        ; return (name, Avail name) } } }
+        ; return (name, avail name) } } }
 
 {-
 *********************************************************
@@ -1015,6 +1015,7 @@ lookupImpDeprec iface gre
        ParentIs  p              -> mi_warn_fn iface p
        FldParent { par_is = p } -> mi_warn_fn iface p
        NoParent                 -> Nothing
+       PatternSynonym           -> Nothing
 
 {-
 Note [Used names with interface not loaded]
@@ -1824,6 +1825,7 @@ warnUnusedTopBinds gres
          let isBoot = tcg_src env == HsBootFile
          let noParent gre = case gre_par gre of
                             NoParent -> True
+                            PatternSynonym -> True
                             _        -> False
              -- Don't warn about unused bindings with parents in
              -- .hs-boot files, as you are sometimes required to give
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index d542a880d3..3d26b89c89 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -580,7 +580,7 @@ getLocalNonValBinders fixity_env
       -- declaration, not just the name
     new_simple :: Located RdrName -> RnM AvailInfo
     new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name
-                            ; return (Avail nm) }
+                            ; return (avail nm) }
 
     new_tc :: Bool -> LTyClDecl RdrName
            -> RnM (AvailInfo, [(Name, [FieldLabel])])
@@ -860,7 +860,8 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
             -> do nameAvail <- lookup_name tc
                   return ([mkIEThingAbs l nameAvail], [])
 
-        IEThingWith (L l rdr_tc) rdr_ns rdr_fs -> ASSERT2(null rdr_fs, ppr rdr_fs) do
+        IEThingWith (L l rdr_tc) wc rdr_ns rdr_fs ->
+          ASSERT2(null rdr_fs, ppr rdr_fs) do
            (name, AvailTC _ ns subflds, mb_parent) <- lookup_name rdr_tc
 
            -- Look up the children in the sub-names of the parent
@@ -875,14 +876,14 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
                case mb_parent of
                  -- non-associated ty/cls
                  Nothing
-                   -> return ([(IEThingWith (L l name) childnames childflds,
+                   -> return ([(IEThingWith (L l name) wc childnames childflds,
                                AvailTC name (name:map unLoc childnames) (map unLoc childflds))],
                               [])
                  -- associated ty
                  Just parent
-                   -> return ([(IEThingWith (L l name) childnames childflds,
+                   -> return ([(IEThingWith (L l name) wc childnames childflds,
                                 AvailTC name (map unLoc childnames) (map unLoc childflds)),
-                               (IEThingWith (L l name) childnames childflds,
+                               (IEThingWith (L l name) wc childnames childflds,
                                 AvailTC parent [name] [])],
                               [])
 
@@ -957,7 +958,7 @@ plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])
 
 -- | trims an 'AvailInfo' to keep only a single name
 trimAvail :: AvailInfo -> Name -> AvailInfo
-trimAvail (Avail n)         _ = Avail n
+trimAvail (Avail b n)         _ = Avail b n
 trimAvail (AvailTC n ns fs) m = case find ((== m) . flSelector) fs of
     Just x  -> AvailTC n [] [x]
     Nothing -> ASSERT( m `elem` ns ) AvailTC n [m] []
@@ -970,7 +971,7 @@ filterAvails keep avails = foldr (filterAvail keep) [] avails
 filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo]
 filterAvail keep ie rest =
   case ie of
-    Avail n | keep n    -> ie : rest
+    Avail _ n | keep n    -> ie : rest
             | otherwise -> rest
     AvailTC tc ns fs ->
         let ns' = filter keep ns
@@ -1014,6 +1015,14 @@ mkChildEnv gres = foldr add emptyNameEnv gres
         FldParent p _  -> extendNameEnv_Acc (:) singleton env p gre
         ParentIs  p    -> extendNameEnv_Acc (:) singleton env p gre
         NoParent       -> env
+        PatternSynonym -> env
+
+findPatSyns :: [GlobalRdrElt] -> [GlobalRdrElt]
+findPatSyns gres = foldr add [] gres
+  where
+    add g@(GRE { gre_par = PatternSynonym }) ps =
+      g:ps
+    add _ ps = ps
 
 findChildren :: NameEnv [a] -> Name -> [a]
 findChildren env n = lookupNameEnv env n `orElse` []
@@ -1052,7 +1061,6 @@ classifyGRE gre = case gre_par gre of
   where
     n = gre_name gre
 
-
 -- | Combines 'AvailInfo's from the same family
 -- 'avails' may have several items with the same availName
 -- E.g  import Ix( Ix(..), index )
@@ -1129,7 +1137,7 @@ type ExportOccMap = OccEnv (Name, IE RdrName)
 rnExports :: Bool       -- False => no 'module M(..) where' header at all
           -> Maybe (Located [LIE RdrName]) -- Nothing => no explicit export list
           -> TcGblEnv
-          -> RnM TcGblEnv
+          -> RnM (Maybe [LIE Name], TcGblEnv)
 
         -- Complains if two distinct exports have same OccName
         -- Warns about identical exports.
@@ -1166,12 +1174,14 @@ rnExports explicit_mod exports
 
         ; traceRn (text "rnExports: Exports:" <+> ppr final_avails)
 
-        ; return (tcg_env { tcg_exports    = final_avails,
-                            tcg_rn_exports = case tcg_rn_exports tcg_env of
+        ; let new_tcg_env =
+                  (tcg_env { tcg_exports    = final_avails,
+                             tcg_rn_exports = case tcg_rn_exports tcg_env of
                                                 Nothing -> Nothing
                                                 Just _  -> rn_exports,
                             tcg_dus = tcg_dus tcg_env `plusDU`
-                                      usesOnly final_ns }) }
+                                      usesOnly final_ns })
+        ; return (rn_exports, new_tcg_env) }
 
 exports_from_avail :: Maybe (Located [LIE RdrName])
                          -- Nothing => no explicit export list
@@ -1201,6 +1211,10 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
     kids_env :: NameEnv [GlobalRdrElt]
     kids_env = mkChildEnv (globalRdrEnvElts rdr_env)
 
+    pat_syns :: [GlobalRdrElt]
+    pat_syns = findPatSyns (globalRdrEnvElts rdr_env)
+
+
     imported_modules = [ qual_name
                        | xs <- moduleEnvElts $ imp_mods imports,
                          (qual_name, _, _, _) <- xs ]
@@ -1269,9 +1283,55 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
         = do (name, avail) <- lookupGreAvailRn rdr
              return (IEThingAbs (L l name), avail)
 
-    lookup_ie ie@(IEThingAll (L l rdr))
+    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
@@ -1281,25 +1341,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
                   else -- This occurs when you export T(..), but
                        -- only import T abstractly, or T is a synonym.
                        addErr (exportItemErr ie)
-             return ( IEThingAll (L l name)
-                    , AvailTC name (name:non_flds) flds )
-
-    lookup_ie ie@(IEThingWith (L l rdr) sub_rdrs sub_flds) = ASSERT2(null sub_flds, ppr sub_flds)
-          do name <- lookupGlobalOccRn rdr
-             let gres = findChildren kids_env name
-             if isUnboundName name
-                then return ( IEThingWith (L l name) [] []
-                            , AvailTC name [name] [] )
-                else case lookupChildren (map classifyGRE gres) sub_rdrs of
-                       Nothing -> do addErr (exportItemErr ie)
-                                     return ( IEThingWith (L l name) [] []
-                                            , AvailTC name [name] [] )
-                       Just (non_flds, flds) ->
-                         do addUsedKids rdr gres
-                            return ( IEThingWith (L l name) non_flds flds
-                                   , AvailTC name (name:map unLoc non_flds) (map unLoc flds) )
-
-    lookup_ie _ = panic "lookup_ie"    -- Other cases covered earlier
+             return (L l name, non_flds, flds)
 
     -------------
     lookup_doc_ie :: IE RdrName -> RnM (IE Name)
@@ -1529,9 +1571,13 @@ findImportUsage imports used_gres
         add_unused (IEVar (L _ n))      acc = add_unused_name n acc
         add_unused (IEThingAbs (L _ n)) acc = add_unused_name n acc
         add_unused (IEThingAll (L _ n)) acc = add_unused_all  n acc
-        add_unused (IEThingWith (L _ p) ns fs) acc = add_unused_with p xs acc
+        add_unused (IEThingWith (L _ p) wc ns fs) acc =
+          add_wc_all (add_unused_with p xs acc)
           where xs = map unLoc ns ++ map (flSelector . unLoc) fs
-        add_unused _                    acc = acc
+                add_wc_all = case wc of
+                            NoIEWildcard -> id
+                            IEWildcard _ -> add_unused_all p
+        add_unused _ acc = acc
 
         add_unused_name n acc
           | n `elemNameSet` used_names = acc
@@ -1664,7 +1710,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)]
@@ -1674,13 +1720,13 @@ printMinimalImports imports_w_usage
                  , x `elem` xs    -- Note [Partial export]
                  ] of
            [xs] | all_used xs -> [IEThingAll (noLoc n)]
-                | otherwise   -> [IEThingWith (noLoc n)
+                | otherwise   -> [IEThingWith (noLoc n) NoIEWildcard
                                               (map noLoc (filter (/= n) ns))
                                               (map noLoc fs)]
                                           -- Note [Overloaded field import]
            _other | all_non_overloaded fs
                               -> map (IEVar . noLoc) $ ns ++ map flSelector fs
-                  | otherwise -> [IEThingWith (noLoc n)
+                  | otherwise -> [IEThingWith (noLoc n) NoIEWildcard
                                               (map noLoc (filter (/= n) ns)) (map noLoc fs)]
         where
           fld_lbls = map flLabel fs
diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs
index f5005740df..483ea9915e 100644
--- a/compiler/rename/RnPat.hs
+++ b/compiler/rename/RnPat.hs
@@ -597,6 +597,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
                                     , case gre_par gre of
                                         ParentIs p               -> p /= parent_tc
                                         FldParent { par_is = p } -> p /= parent_tc
+                                        PatternSynonym           -> True
                                         NoParent                 -> True ]
                    where
                      rdr = mkVarUnqual lbl
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 90bf09a708..4e3359f546 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -127,7 +127,7 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
    let { id_bndrs = collectHsIdBinders new_lhs } ;  -- Excludes pattern-synonym binders
                                                     -- They are already in scope
    traceRn (text "rnSrcDecls" <+> ppr id_bndrs) ;
-   tc_envs <- extendGlobalRdrEnvRn (map Avail id_bndrs) local_fix_env ;
+   tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ;
    traceRn (text "D2" <+> ppr (tcg_rdr_env (fst tc_envs)));
    setEnvs tc_envs $ do {
 
@@ -1548,7 +1548,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 Avail pat_syn_bndrs
+   ; let avails = map patSynAvail pat_syn_bndrs
    ; (gbl_env, lcl_env) <-
         extendGlobalRdrEnvRn avails local_fix_env
 
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index 95d47887c7..28502b6249 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -487,7 +487,7 @@ renameDeriv is_boot inst_infos bagBinds
         ; let aux_val_binds = ValBindsIn aux_binds (bagToList aux_sigs)
         ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds
         ; let bndrs = collectHsValBinders rn_aux_lhs
-        ; envs <- extendGlobalRdrEnvRn (map Avail bndrs) emptyFsEnv ;
+        ; envs <- extendGlobalRdrEnvRn (map avail bndrs) emptyFsEnv ;
         ; setEnvs envs $
     do  { (rn_aux, dus_aux) <- rnValBindsRHS (TopSigCtxt (mkNameSet bndrs)) rn_aux_lhs
         ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 3a93e6e99e..febd8900f5 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -29,7 +29,6 @@ module TcRnDriver (
 import {-# SOURCE #-} TcSplice ( runQuasi )
 import RnSplice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) )
 import IfaceEnv( externaliseName )
-import TcType   ( isUnitTy, isTauTy )
 import TcHsType
 import TcMatches
 import RnTypes
@@ -65,6 +64,7 @@ import TcForeign
 import TcInstDcls
 import TcIface
 import TcMType
+import TcType
 import MkIface
 import TcSimplify
 import TcTyClsDecls
@@ -91,6 +91,7 @@ import ListSetOps
 import Outputable
 import ConLike
 import DataCon
+import PatSyn
 import Type
 import Class
 import BasicTypes hiding( SuccessFlag(..) )
@@ -102,6 +103,7 @@ import FastString
 import Maybes
 import Util
 import Bag
+import IdInfo
 
 import Control.Monad
 
@@ -326,7 +328,8 @@ tcRnModuleTcRnM hsc_env hsc_src
 
                 -- Process the export list
         traceRn (text "rn4a: before exports");
-        tcg_env <- rnExports explicit_mod_hdr export_ies tcg_env ;
+        (rn_exports, tcg_env) <- rnExports explicit_mod_hdr export_ies tcg_env ;
+        tcExports rn_exports ;
         traceRn (text "rn4b: after exports") ;
 
                 -- Check that main is exported (must be after rnExports)
@@ -2024,6 +2027,141 @@ loadUnqualIfaces hsc_env ictxt
                   , unQualOK gre ]               -- In scope unqualified
     doc = ptext (sLit "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/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index dbeefb155b..6f495635f1 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -445,6 +445,8 @@ data TcGblEnv
 
         tcg_rn_exports :: Maybe [Located (IE Name)],
                 -- Nothing <=> no explicit export list
+                -- Is always Nothing if we don't want to retain renamed
+                -- exports
 
         tcg_rn_imports :: [LImportDecl Name],
                 -- Keep the renamed imports regardless.  They are not
diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs
index 21598450c2..a9482906e9 100644
--- a/compiler/types/TyCon.hs
+++ b/compiler/types/TyCon.hs
@@ -57,6 +57,7 @@ module TyCon(
         isTyConAssoc, tyConAssoc_maybe,
         isRecursiveTyCon,
         isImplicitTyCon,
+        isTyConWithSrcDataCons,
 
         -- ** Extracting information out of TyCons
         tyConName,
@@ -1689,6 +1690,21 @@ expandSynTyCon_maybe tc tys
 
 ----------------
 
+-- | Check if the tycon actually refers to a proper `data` or `newtype`
+--  with user defined constructors rather than one from a class or other
+--  construction.
+isTyConWithSrcDataCons :: TyCon -> Bool
+isTyConWithSrcDataCons (AlgTyCon { algTcRhs = rhs, algTcParent = parent }) =
+  case rhs of
+    DataTyCon {}  -> isSrcParent
+    NewTyCon {}   -> isSrcParent
+    TupleTyCon {} -> isSrcParent
+    _ -> False
+  where
+    isSrcParent = isNoParent parent
+isTyConWithSrcDataCons _ = False
+
+
 -- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no
 -- constructors could be found
 tyConDataCons :: TyCon -> [DataCon]