Changes for #16110/#16356

4 files changed, 19 insertions, 37 deletions

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 6aac2f08..45318498 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -18,7 +18,7 @@ module Haddock.Backends.Hoogle (
   ) where
 
 import BasicTypes ( OverlapFlag(..), OverlapMode(..), SourceText(..)
-                  , PromotionFlag(..) )
+                  , PromotionFlag(..), TopLevelFlag(..) )
 import InstEnv (ClsInst(..))
 import Documentation.Haddock.Markup
 import Haddock.GhcUtils
@@ -174,7 +174,7 @@ ppClass dflags decl subdocs =
             | null $ tcdATs decl = ""
             | otherwise = (" " ++) . showSDocUnqual dflags . whereWrapper $ concat
                 [ map pprTyFam (tcdATs decl)
-                , map (ppr . tyFamEqnToSyn . unLoc) (tcdATDefs decl)
+                , map (pprTyFamInstDecl NotTopLevel . unLoc) (tcdATDefs decl)
                 ]
 
         pprTyFam :: LFamilyDecl GhcRn -> SDoc
@@ -187,15 +187,6 @@ ppClass dflags decl subdocs =
             , rbrace
             ]
 
-        tyFamEqnToSyn :: TyFamDefltEqn GhcRn -> TyClDecl GhcRn
-        tyFamEqnToSyn tfe = SynDecl
-            { tcdLName  = feqn_tycon tfe
-            , tcdTyVars = feqn_pats tfe
-            , tcdFixity = feqn_fixity tfe
-            , tcdRhs    = feqn_rhs tfe
-            , tcdSExt   = emptyNameSet
-            }
-
 ppFam :: DynFlags -> FamilyDecl GhcRn -> [String]
 ppFam dflags decl@(FamilyDecl { fdInfo = info })
   = [out dflags decl']
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 4af0f79d..8e6b0a4c 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -85,19 +85,21 @@ tyThingToLHsDecl prr t = case t of
            extractFamilyDecl _           =
              Left "tyThingToLHsDecl: impossible associated tycon"
 
-           extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltEqn GhcRn
-           extractFamDefDecl fd rhs = FamEqn
+           extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltDecl GhcRn
+           extractFamDefDecl fd rhs =
+             TyFamInstDecl $ HsIB { hsib_ext = hsq_ext (fdTyVars fd)
+                                  , hsib_body = FamEqn
              { feqn_ext = noExt
              , feqn_tycon = fdLName fd
-             , feqn_bndrs  = Nothing
-                 -- TODO: this must change eventually
-             , feqn_pats = fdTyVars fd
+             , feqn_bndrs = Nothing
+             , feqn_pats = map (HsValArg . hsLTyVarBndrToType) $
+                           hsq_explicit $ fdTyVars fd
              , feqn_fixity = fdFixity fd
-             , feqn_rhs = synifyType WithinType [] rhs }
+             , feqn_rhs = synifyType WithinType [] rhs }}
 
            extractAtItem
              :: ClassATItem
-             -> Either ErrMsg (LFamilyDecl GhcRn, Maybe (LTyFamDefltEqn GhcRn))
+             -> Either ErrMsg (LFamilyDecl GhcRn, Maybe (LTyFamDefltDecl GhcRn))
            extractAtItem (ATI at_tc def) = do
              tyDecl <- synifyTyCon prr Nothing at_tc
              famDecl <- extractFamilyDecl tyDecl
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 5ba5d454..70a608ee 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -400,7 +400,7 @@ renameTyClD d = case d of
     lfundeps' <- mapM renameLFunDep lfundeps
     lsigs'    <- mapM renameLSig lsigs
     ats'      <- mapM (renameLThing renameFamilyDecl) ats
-    at_defs'  <- mapM renameLTyFamDefltEqn at_defs
+    at_defs'  <- mapM (mapM renameTyFamDefltD) at_defs
     -- we don't need the default methods or the already collected doc entities
     return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars'
                       , tcdFixity = fixity
@@ -606,8 +606,8 @@ renameTyFamInstEqn eqn
   = renameImplicit rename_ty_fam_eqn eqn
   where
     rename_ty_fam_eqn
-      :: FamEqn GhcRn (HsTyPats GhcRn) (LHsType GhcRn)
-      -> RnM (FamEqn DocNameI (HsTyPats DocNameI) (LHsType DocNameI))
+      :: FamEqn GhcRn (LHsType GhcRn)
+      -> RnM (FamEqn DocNameI (LHsType DocNameI))
     rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs
                               , feqn_pats = pats, feqn_fixity = fixity
                               , feqn_rhs = rhs })
@@ -623,19 +623,8 @@ renameTyFamInstEqn eqn
                             , feqn_rhs    = rhs' }) }
     rename_ty_fam_eqn (XFamEqn _) = panic "haddock:renameTyFamInstEqn"
 
-renameLTyFamDefltEqn :: LTyFamDefltEqn GhcRn -> RnM (LTyFamDefltEqn DocNameI)
-renameLTyFamDefltEqn (L loc (FamEqn { feqn_tycon = tc, feqn_pats = tvs
-                                    , feqn_fixity = fixity, feqn_rhs = rhs }))
-  = do { tc'  <- renameL tc
-       ; tvs' <- renameLHsQTyVars tvs
-       ; rhs' <- renameLType rhs
-       ; return (L loc (FamEqn { feqn_ext    = noExt
-                               , feqn_tycon  = tc'
-                               , feqn_bndrs  = Nothing  -- this is always Nothing
-                               , feqn_pats   = tvs'
-                               , feqn_fixity = fixity
-                               , feqn_rhs    = rhs' })) }
-renameLTyFamDefltEqn (L _ (XFamEqn _)) = panic "haddock:renameLTyFamDefltEqn"
+renameTyFamDefltD :: TyFamDefltDecl GhcRn -> RnM (TyFamDefltDecl DocNameI)
+renameTyFamDefltD = renameTyFamInstD
 
 renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI)
 renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })
@@ -643,8 +632,8 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })
        ; return (DataFamInstDecl { dfid_eqn = eqn' }) }
   where
     rename_data_fam_eqn
-      :: FamEqn GhcRn (HsTyPats GhcRn) (HsDataDefn GhcRn)
-      -> RnM (FamEqn DocNameI (HsTyPats DocNameI) (HsDataDefn DocNameI))
+      :: FamEqn GhcRn (HsDataDefn GhcRn)
+      -> RnM (FamEqn DocNameI (HsDataDefn DocNameI))
     rename_data_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs
                                 , feqn_pats = pats, feqn_fixity = fixity
                                 , feqn_rhs = defn })
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index a4ef5f82..4fbb308d 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -721,7 +721,7 @@ type instance XNoSig      DocNameI = NoExt
 type instance XCKindSig   DocNameI = NoExt
 type instance XTyVarSig   DocNameI = NoExt
 
-type instance XCFamEqn       DocNameI _ _ = NoExt
+type instance XCFamEqn       DocNameI _ = NoExt
 
 type instance XCClsInstDecl DocNameI = NoExt
 type instance XCDerivDecl   DocNameI = NoExt