Uphold AvailTC Invariant for associated data fams

The AvailTC was not be upheld for explicit export module
export lists when the module contains associated data families.

    module A (module A) where
    class    C a  where { data T a }
    instance C () where { data T () = D }

Used to (incorrectly) report avails as `[C{C, T;}, T{D;}]`. Note that
although `T` is exported, the avail where it is the parent does _not_
list it as its first element. This avail is now correctly listed as
`[C{C, T;}, T{T, D;}]`.

This was induces a [crash in Haddock][0].

See #16077.

[0]: https://github.com/haskell/haddock/issues/979

2 files changed, 68 insertions, 26 deletions

diff --git a/compiler/basicTypes/Avail.hs b/compiler/basicTypes/Avail.hs
index cefa934ab1..291c95abe8 100644
--- a/compiler/basicTypes/Avail.hs
+++ b/compiler/basicTypes/Avail.hs
@@ -47,27 +47,27 @@ import Data.Function
 -- -----------------------------------------------------------------------------
 -- The AvailInfo type
 
--- | Records what things are "available", i.e. in scope
-data AvailInfo = Avail Name      -- ^ An ordinary identifier in scope
-               | AvailTC Name
-                         [Name]
-                         [FieldLabel]
-                                 -- ^ A type or class in scope. Parameters:
-                                 --
-                                 --  1) The name of the type or class
-                                 --  2) The available pieces of type or class,
-                                 --     excluding field selectors.
-                                 --  3) The record fields of the type
-                                 --     (see Note [Representing fields in AvailInfo]).
-                                 --
-                                 -- The AvailTC Invariant:
-                                 --   * If the type or class is itself
-                                 --     to be in scope, it must be
-                                 --     *first* in this list.  Thus,
-                                 --     typically: @AvailTC Eq [Eq, ==, \/=]@
-                deriving( Eq, Data )
-                        -- Equality used when deciding if the
-                        -- interface has changed
+-- | Records what things are \"available\", i.e. in scope
+data AvailInfo
+
+  -- | An ordinary identifier in scope
+  = Avail Name
+
+  -- | A type or class in scope
+  --
+  -- The __AvailTC Invariant__: If the type or class is itself to be in scope,
+  -- it must be /first/ in this list.  Thus, typically:
+  --
+  -- > AvailTC Eq [Eq, ==, \/=] []
+  | AvailTC
+       Name         -- ^ The name of the type or class
+       [Name]       -- ^ The available pieces of type or class,
+                    -- excluding field selectors.
+       [FieldLabel] -- ^ The record fields of the type
+                    -- (see Note [Representing fields in AvailInfo]).
+
+   deriving ( Eq    -- ^ Used when deciding if the interface has changed
+            , Data )
 
 -- | A collection of 'AvailInfo' - several things that are \"available\"
 type Avails = [AvailInfo]
diff --git a/compiler/typecheck/TcRnExports.hs b/compiler/typecheck/TcRnExports.hs
index 28c1773308..b3baf6c406 100644
--- a/compiler/typecheck/TcRnExports.hs
+++ b/compiler/typecheck/TcRnExports.hs
@@ -89,6 +89,41 @@ At one point I implemented a compromise:
 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 ...
+
+Note [Avails of associated data families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose you have (Trac #16077)
+
+    {-# LANGUAGE TypeFamilies #-}
+    module A (module A) where
+
+    class    C a  where { data T a }
+    instance C () where { data T () = D }
+
+Because @A@ is exported explicitly, GHC tries to produce an export list
+from the @GlobalRdrEnv@. In this case, it pulls out the following:
+
+    [ C defined at A.hs:4:1
+    , T parent:C defined at A.hs:4:23
+    , D parent:T defined at A.hs:5:35 ]
+
+If map these directly into avails, (via 'availFromGRE'), we get
+@[C{C;}, C{T;}, T{D;}]@, which eventually gets merged into @[C{C, T;}, T{D;}]@.
+That's not right, because @T{D;}@ violates the AvailTC invariant: @T@ is
+exported, but it isn't the first entry in the avail!
+
+We work around this issue by expanding GREs where the parent and child
+are both type constructors into two GRES.
+
+    T parent:C defined at A.hs:4:23
+
+      =>
+
+    [ T parent:C defined at A.hs:4:23
+    , T defined at A.hs:4:23 ]
+
+Then, we get  @[C{C;}, C{T;}, T{T;}, T{D;}]@, which eventually gets merged
+into @[C{C, T;}, T{T, D;}]@ (which satsifies the AvailTC invariant).
 -}
 
 data ExportAccum        -- The type of the accumulating parameter of
@@ -175,12 +210,12 @@ tcRnExports explicit_mod exports
         ; return new_tcg_env }
 
 exports_from_avail :: Maybe (Located [LIE GhcPs])
-                         -- Nothing => no explicit export list
+                         -- ^ 'Nothing' means no explicit export list
                    -> GlobalRdrEnv
                    -> ImportAvails
-                         -- Imported modules; this is used to test if a
-                         -- 'module Foo' export is valid (it's not valid
-                         -- if we didn't import Foo!)
+                         -- ^ Imported modules; this is used to test if a
+                         -- @module Foo@ export is valid (it's not valid
+                         -- if we didn't import @Foo@!)
                    -> Module
                    -> RnM (Maybe [(LIE GhcRn, Avails)], Avails)
                          -- (Nothing, _) <=> no explicit export list
@@ -230,6 +265,11 @@ exports_from_avail (Just (dL->L _ rdr_items)) rdr_env imports this_mod
     kids_env :: NameEnv [GlobalRdrElt]
     kids_env = mkChildEnv (globalRdrEnvElts rdr_env)
 
+    -- See Note [Avails of associated data families]
+    expand_tyty_gre :: GlobalRdrElt -> [GlobalRdrElt]
+    expand_tyty_gre (gre @ GRE { gre_name = me, gre_par = ParentIs p })
+      | isTyConName p, isTyConName me = [gre, gre{ gre_par = NoParent }]
+    expand_tyty_gre gre = [gre]
 
     imported_modules = [ imv_name imv
                        | xs <- moduleEnvElts $ imp_mods imports
@@ -248,7 +288,9 @@ exports_from_avail (Just (dL->L _ rdr_items)) rdr_env imports this_mod
         = 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
+                   ; new_exports = [ availFromGRE gre'
+                                   | (gre, _) <- gre_prs
+                                   , gre' <- expand_tyty_gre gre ]
                    ; all_gres    = foldr (\(gre1,gre2) gres -> gre1 : gre2 : gres) [] gre_prs
                    ; mods        = addOneToUniqSet earlier_mods mod
                    }