aboutsummaryrefslogtreecommitdiff
path: root/haddock-api
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs13
-rw-r--r--haddock-api/src/Haddock/Convert.hs16
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs25
-rw-r--r--haddock-api/src/Haddock/Types.hs2
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