diff options
Diffstat (limited to 'haddock-api/src/Haddock')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hoogle.hs | 13 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Convert.hs | 16 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Rename.hs | 25 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Types.hs | 2 |
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 |