diff options
Diffstat (limited to 'src/Haddock/Backends/Xhtml')
| -rw-r--r-- | src/Haddock/Backends/Xhtml/Decl.hs | 411 | ||||
| -rw-r--r-- | src/Haddock/Backends/Xhtml/DocMarkup.hs | 14 | ||||
| -rw-r--r-- | src/Haddock/Backends/Xhtml/Layout.hs | 34 | ||||
| -rw-r--r-- | src/Haddock/Backends/Xhtml/Names.hs | 17 |
4 files changed, 253 insertions, 223 deletions
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 7031a9ae..747e8f38 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -39,38 +39,40 @@ import Outputable ( ppr, showSDoc, Outputable ) -- TODO: use DeclInfo DocName or something ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> - DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> Bool -> Html -ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode = case decl of - TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d unicode + DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> + Bool -> Qualification -> Html +ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode quali = case decl of + TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d unicode quali TyClD d@(TyData {}) - | Nothing <- tcdTyPats d -> ppDataDecl summ links instances subdocs loc mbDoc d unicode + | Nothing <- tcdTyPats d -> ppDataDecl summ links instances subdocs loc mbDoc d unicode quali | Just _ <- tcdTyPats d -> ppDataInst summ links loc mbDoc d TyClD d@(TySynonym {}) - | Nothing <- tcdTyPats d -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode - | Just _ <- tcdTyPats d -> ppTyInst summ False links loc mbDoc d unicode - TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode - SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) n t unicode - ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode + | Nothing <- tcdTyPats d -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode quali + | Just _ <- tcdTyPats d -> ppTyInst summ False links loc mbDoc d unicode quali + TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode quali + SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) n t unicode quali + ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode quali InstD _ -> noHtml _ -> error "declaration not supported by ppDecl" ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - DocName -> HsType DocName -> Bool -> Html -ppFunSig summary links loc doc docname typ unicode = + DocName -> HsType DocName -> Bool -> Qualification -> Html +ppFunSig summary links loc doc docname typ unicode quali = ppTypeOrFunSig summary links loc docname typ doc - (ppTypeSig summary occname typ unicode, ppBinder False occname, dcolon unicode) unicode + (ppTypeSig summary occname typ unicode quali, ppBinder False occname, dcolon unicode) + unicode quali where occname = docNameOcc docname ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> DocName -> HsType DocName -> - DocForDecl DocName -> (Html, Html, Html) -> Bool -> Html -ppTypeOrFunSig summary links loc docname typ (doc, argDocs) (pref1, pref2, sep) unicode + DocForDecl DocName -> (Html, Html, Html) -> Bool -> Qualification-> Html +ppTypeOrFunSig summary links loc docname typ (doc, argDocs) (pref1, pref2, sep) unicode quali | summary = pref1 - | Map.null argDocs = topDeclElem links loc docname pref1 +++ maybeDocSection doc + | Map.null argDocs = topDeclElem links loc docname pref1 +++ maybeDocSection quali doc | otherwise = topDeclElem links loc docname pref2 +++ - subArguments (do_args 0 sep typ) +++ maybeDocSection doc + subArguments quali (do_args 0 sep typ) +++ maybeDocSection quali doc where argDoc n = Map.lookup n argDocs @@ -79,12 +81,12 @@ ppTypeOrFunSig summary links loc docname typ (doc, argDocs) (pref1, pref2, sep) do_args n leader (HsForAllTy Explicit tvs lctxt ltype) = (leader <+> hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+> - ppLContextNoArrow lctxt unicode, + ppLContextNoArrow lctxt unicode quali, Nothing, []) : do_largs n (darrow unicode) ltype do_args n leader (HsForAllTy Implicit _ lctxt ltype) | not (null (unLoc lctxt)) - = (leader <+> ppLContextNoArrow lctxt unicode, + = (leader <+> ppLContextNoArrow lctxt unicode quali, Nothing, []) : do_largs n (darrow unicode) ltype -- if we're not showing any 'forall' or class constraints or @@ -92,10 +94,10 @@ ppTypeOrFunSig summary links loc docname typ (doc, argDocs) (pref1, pref2, sep) | otherwise = do_largs n leader ltype do_args n leader (HsFunTy lt r) - = (leader <+> ppLFunLhType unicode lt, argDoc n, []) + = (leader <+> ppLFunLhType unicode quali lt, argDoc n, []) : do_largs (n+1) (arrow unicode) r do_args n leader t - = (leader <+> ppType unicode t, argDoc n, []) : [] + = (leader <+> ppType unicode quali t, argDoc n, []) : [] ppTyVars :: [LHsTyVarBndr DocName] -> [Html] @@ -106,26 +108,29 @@ tyvarNames :: [LHsTyVarBndr DocName] -> [Name] tyvarNames = map (getName . hsTyVarName . unLoc) -ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> Html -ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _) unicode - = ppFunSig summary links loc doc name typ unicode -ppFor _ _ _ _ _ _ = error "ppFor" +ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool + -> Qualification -> Html +ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _) unicode quali + = ppFunSig summary links loc doc name typ unicode quali +ppFor _ _ _ _ _ _ _ = error "ppFor" -- we skip type patterns for now -ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> Html -ppTySyn summary links loc doc (TySynonym (L _ name) ltyvars _ ltype) unicode +ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool + -> Qualification -> Html +ppTySyn summary links loc doc (TySynonym (L _ name) ltyvars _ ltype) unicode quali = ppTypeOrFunSig summary links loc name (unLoc ltype) doc - (full, hdr, spaceHtml +++ equals) unicode + (full, hdr, spaceHtml +++ equals) unicode quali where hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars) - full = hdr <+> equals <+> ppLType unicode ltype + full = hdr <+> equals <+> ppLType unicode quali ltype occ = docNameOcc name -ppTySyn _ _ _ _ _ _ = error "declaration not supported by ppTySyn" +ppTySyn _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn" -ppTypeSig :: Bool -> OccName -> HsType DocName -> Bool -> Html -ppTypeSig summary nm ty unicode = ppBinder summary nm <+> dcolon unicode <+> ppType unicode ty +ppTypeSig :: Bool -> OccName -> HsType DocName -> Bool -> Qualification -> Html +ppTypeSig summary nm ty unicode quali = + ppBinder summary nm <+> dcolon unicode <+> ppType unicode quali ty ppTyName :: Name -> Html @@ -159,18 +164,18 @@ ppTyFamHeader summary associated decl unicode = ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) -> - TyClDecl DocName -> Bool -> Html -ppTyFam summary associated links loc mbDoc decl unicode + TyClDecl DocName -> Bool -> Qualification -> Html +ppTyFam summary associated links loc mbDoc decl unicode quali | summary = ppTyFamHeader True associated decl unicode - | otherwise = header_ +++ maybeDocSection mbDoc +++ instancesBit + | otherwise = header_ +++ maybeDocSection quali mbDoc +++ instancesBit where docname = tcdName decl header_ = topDeclElem links loc docname (ppTyFamHeader summary associated decl unicode) - instancesBit = ppInstances instances docname unicode + instancesBit = ppInstances instances docname unicode quali -- TODO: get the instances instances = [] @@ -199,22 +204,23 @@ ppDataInst = undefined ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) -> - TyClDecl DocName -> Bool -> Html -ppTyInst summary associated links loc mbDoc decl unicode + TyClDecl DocName -> Bool -> Qualification -> Html +ppTyInst summary associated links loc mbDoc decl unicode quali - | summary = ppTyInstHeader True associated decl unicode - | otherwise = header_ +++ maybeDocSection mbDoc + | summary = ppTyInstHeader True associated decl unicode quali + | otherwise = header_ +++ maybeDocSection quali mbDoc where docname = tcdName decl - header_ = topDeclElem links loc docname (ppTyInstHeader summary associated decl unicode) + header_ = topDeclElem links loc docname + (ppTyInstHeader summary associated decl unicode quali) -ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Html -ppTyInstHeader _ _ decl unicode = +ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Qualification -> Html +ppTyInstHeader _ _ decl unicode quali = keyword "type instance" <+> - ppAppNameTypes (tcdName decl) typeArgs unicode + ppAppNameTypes (tcdName decl) typeArgs unicode quali where typeArgs = map unLoc . fromJust . tcdTyPats $ decl @@ -224,11 +230,12 @@ ppTyInstHeader _ _ decl unicode = -------------------------------------------------------------------------------- -ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LTyClDecl DocName -> Bool -> Html -ppAssocType summ links doc (L loc decl) unicode = +ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LTyClDecl DocName -> Bool + -> Qualification -> Html +ppAssocType summ links doc (L loc decl) unicode quali = case decl of - TyFamily {} -> ppTyFam summ True links loc (fst doc) decl unicode - TySynonym {} -> ppTySyn summ links loc doc decl unicode + TyFamily {} -> ppTyFam summ True links loc (fst doc) decl unicode quali + TySynonym {} -> ppTySyn summ links loc doc decl unicode quali _ -> error "declaration type not supported by ppAssocType" @@ -249,8 +256,9 @@ ppTyClBinderWithVars summ decl = -- | Print an application of a DocName and a list of HsTypes -ppAppNameTypes :: DocName -> [HsType DocName] -> Bool -> Html -ppAppNameTypes n ts unicode = ppTypeApp n ts ppDocName (ppParendType unicode) +ppAppNameTypes :: DocName -> [HsType DocName] -> Bool -> Qualification -> Html +ppAppNameTypes n ts unicode quali = + ppTypeApp n ts (ppDocName quali) (ppParendType unicode quali) -- | Print an application of a DocName and a list of Names @@ -276,36 +284,39 @@ ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts) ------------------------------------------------------------------------------- -ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> Html +ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool + -> Qualification -> Html ppLContext = ppContext . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc -ppContextNoArrow :: HsContext DocName -> Bool -> Html -ppContextNoArrow [] _ = noHtml -ppContextNoArrow cxt unicode = pp_hs_context (map unLoc cxt) unicode +ppContextNoArrow :: HsContext DocName -> Bool -> Qualification -> Html +ppContextNoArrow [] _ _ = noHtml +ppContextNoArrow cxt unicode quali = pp_hs_context (map unLoc cxt) unicode quali -ppContextNoLocs :: [HsPred DocName] -> Bool -> Html -ppContextNoLocs [] _ = noHtml -ppContextNoLocs cxt unicode = pp_hs_context cxt unicode <+> darrow unicode +ppContextNoLocs :: [HsPred DocName] -> Bool -> Qualification -> Html +ppContextNoLocs [] _ _ = noHtml +ppContextNoLocs cxt unicode quali = pp_hs_context cxt unicode quali + <+> darrow unicode -ppContext :: HsContext DocName -> Bool -> Html -ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode +ppContext :: HsContext DocName -> Bool -> Qualification -> Html +ppContext cxt unicode quali = ppContextNoLocs (map unLoc cxt) unicode quali -pp_hs_context :: [HsPred DocName] -> Bool -> Html -pp_hs_context [] _ = noHtml -pp_hs_context [p] unicode = ppPred unicode p -pp_hs_context cxt unicode = parenList (map (ppPred unicode) cxt) +pp_hs_context :: [HsPred DocName] -> Bool -> Qualification-> Html +pp_hs_context [] _ _ = noHtml +pp_hs_context [p] unicode quali = ppPred unicode quali p +pp_hs_context cxt unicode quali = parenList (map (ppPred unicode quali) cxt) -ppPred :: Bool -> HsPred DocName -> Html -ppPred unicode (HsClassP n ts) = ppAppNameTypes n (map unLoc ts) unicode -ppPred unicode (HsEqualP t1 t2) = ppLType unicode t1 <+> toHtml "~" <+> ppLType unicode t2 -ppPred unicode (HsIParam (IPName n) t) - = toHtml "?" +++ ppDocName n <+> dcolon unicode <+> ppLType unicode t +ppPred :: Bool -> Qualification -> HsPred DocName -> Html +ppPred unicode quali (HsClassP n ts) = ppAppNameTypes n (map unLoc ts) unicode quali +ppPred unicode quali (HsEqualP t1 t2) = ppLType unicode quali t1 <+> toHtml "~" + <+> ppLType unicode quali t2 +ppPred unicode quali (HsIParam (IPName n) t) + = toHtml "?" +++ ppDocName quali n <+> dcolon unicode <+> ppLType unicode quali t ------------------------------------------------------------------------------- @@ -315,83 +326,87 @@ ppPred unicode (HsIParam (IPName n) t) ppClassHdr :: Bool -> Located [LHsPred DocName] -> DocName -> [Located (HsTyVarBndr DocName)] -> [Located ([DocName], [DocName])] - -> Bool -> Html -ppClassHdr summ lctxt n tvs fds unicode = + -> Bool -> Qualification -> Html +ppClassHdr summ lctxt n tvs fds unicode quali = keyword "class" - <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else noHtml) + <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode quali else noHtml) <+> ppAppDocNameNames summ n (tyvarNames $ tvs) - <+> ppFds fds unicode + <+> ppFds fds unicode quali -ppFds :: [Located ([DocName], [DocName])] -> Bool -> Html -ppFds fds unicode = +ppFds :: [Located ([DocName], [DocName])] -> Bool -> Qualification -> Html +ppFds fds unicode quali = if null fds then noHtml else char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) where - fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> arrow unicode <+> - hsep (map ppDocName vars2) + fundep (vars1,vars2) = hsep (map (ppDocName quali) vars1) <+> arrow unicode <+> + hsep (map (ppDocName quali) vars2) -ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, DocForDecl DocName)] -> Bool -> Html -ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc subdocs unicode = +ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan + -> [(DocName, DocForDecl DocName)] -> Bool -> Qualification + -> Html +ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc + subdocs unicode quali = if null sigs && null ats then (if summary then id else topDeclElem links loc nm) hdr else (if summary then id else topDeclElem links loc nm) (hdr <+> keyword "where") +++ shortSubDecls ( - [ ppAssocType summary links doc at unicode | at <- ats + [ ppAssocType summary links doc at unicode quali | at <- ats , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] ++ - [ ppFunSig summary links loc doc n typ unicode + [ ppFunSig summary links loc doc n typ unicode quali | L _ (TypeSig (L _ n) (L _ typ)) <- sigs , let doc = lookupAnySubdoc n subdocs ] ) where - hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode + hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode quali nm = unLoc lname -ppShortClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" +ppShortClassDecl _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)] - -> TyClDecl DocName -> Bool -> Html + -> TyClDecl DocName -> Bool -> Qualification -> Html ppClassDecl summary links instances loc mbDoc subdocs - decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode - | summary = ppShortClassDecl summary links decl loc subdocs unicode - | otherwise = classheader +++ maybeDocSection mbDoc + decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode quali + | summary = ppShortClassDecl summary links decl loc subdocs unicode quali + | otherwise = classheader +++ maybeDocSection quali mbDoc +++ atBit +++ methodBit +++ instancesBit where classheader - | null lsigs = topDeclElem links loc nm (hdr unicode) - | otherwise = topDeclElem links loc nm (hdr unicode <+> keyword "where") + | null lsigs = topDeclElem links loc nm (hdr unicode quali) + | otherwise = topDeclElem links loc nm (hdr unicode quali <+> keyword "where") nm = unLoc $ tcdLName decl hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds - atBit = subAssociatedTypes [ ppAssocType summary links doc at unicode + atBit = subAssociatedTypes [ ppAssocType summary links doc at unicode quali | at <- ats , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] - methodBit = subMethods [ ppFunSig summary links loc doc n typ unicode + methodBit = subMethods [ ppFunSig summary links loc doc n typ unicode quali | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs , let doc = lookupAnySubdoc n subdocs ] - instancesBit = ppInstances instances nm unicode + instancesBit = ppInstances instances nm unicode quali -ppClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" +ppClassDecl _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" -ppInstances :: [DocInstance DocName] -> DocName -> Bool -> Html -ppInstances instances baseName unicode - = subInstances instName (map instDecl instances) +ppInstances :: [DocInstance DocName] -> DocName -> Bool -> Qualification -> Html +ppInstances instances baseName unicode quali + = subInstances quali instName (map instDecl instances) where instName = getOccString $ getName baseName instDecl :: DocInstance DocName -> SubDecl instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, []) - instHead ([], n, ts) = ppAppNameTypes n ts unicode - instHead (ctxt, n, ts) = ppContextNoLocs ctxt unicode <+> ppAppNameTypes n ts unicode + instHead ([], n, ts) = ppAppNameTypes n ts unicode quali + instHead (ctxt, n, ts) = ppContextNoLocs ctxt unicode quali + <+> ppAppNameTypes n ts unicode quali lookupAnySubdoc :: (Eq name1) => @@ -407,13 +422,14 @@ lookupAnySubdoc n subdocs = case lookup n subdocs of -- TODO: print contexts -ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> TyClDecl DocName -> Bool -> Html -ppShortDataDecl summary _links _loc dataDecl unicode +ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> TyClDecl DocName -> Bool + -> Qualification -> Html +ppShortDataDecl summary _links _loc dataDecl unicode quali - | [] <- cons = dataHeader + | [] <- cons = dataHeader | [lcon] <- cons, ResTyH98 <- resTy, - (cHead,cBody,cFoot) <- ppShortConstrParts summary (unLoc lcon) unicode + (cHead,cBody,cFoot) <- ppShortConstrParts summary (unLoc lcon) unicode quali = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot | ResTyH98 <- resTy = dataHeader @@ -423,9 +439,9 @@ ppShortDataDecl summary _links _loc dataDecl unicode +++ shortSubDecls (map doGADTConstr cons) where - dataHeader = ppDataHeader summary dataDecl unicode - doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode - doGADTConstr con = ppShortConstr summary (unLoc con) unicode + dataHeader = ppDataHeader summary dataDecl unicode quali + doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode quali + doGADTConstr con = ppShortConstr summary (unLoc con) unicode quali cons = tcdCons dataDecl resTy = (con_res . unLoc . head) cons @@ -433,18 +449,19 @@ ppShortDataDecl summary _links _loc dataDecl unicode ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> - SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool -> Html -ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode + SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool -> + Qualification -> Html +ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode quali - | summary = ppShortDataDecl summary links loc dataDecl unicode - | otherwise = header_ +++ maybeDocSection mbDoc +++ constrBit +++ instancesBit + | summary = ppShortDataDecl summary links loc dataDecl unicode quali + | otherwise = header_ +++ maybeDocSection quali mbDoc +++ constrBit +++ instancesBit where docname = unLoc . tcdLName $ dataDecl cons = tcdCons dataDecl resTy = (con_res . unLoc . head) cons - header_ = topDeclElem links loc docname (ppDataHeader summary dataDecl unicode + header_ = topDeclElem links loc docname (ppDataHeader summary dataDecl unicode quali <+> whereBit) whereBit @@ -453,33 +470,34 @@ ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode ResTyGADT _ -> keyword "where" _ -> noHtml - constrBit = subConstructors - (map (ppSideBySideConstr subdocs unicode) cons) + constrBit = subConstructors quali + (map (ppSideBySideConstr subdocs unicode quali) cons) - instancesBit = ppInstances instances docname unicode + instancesBit = ppInstances instances docname unicode quali -ppShortConstr :: Bool -> ConDecl DocName -> Bool -> Html -ppShortConstr summary con unicode = cHead <+> cBody <+> cFoot +ppShortConstr :: Bool -> ConDecl DocName -> Bool -> Qualification -> Html +ppShortConstr summary con unicode quali = cHead <+> cBody <+> cFoot where - (cHead,cBody,cFoot) = ppShortConstrParts summary con unicode + (cHead,cBody,cFoot) = ppShortConstrParts summary con unicode quali -- returns three pieces: header, body, footer so that header & footer can be -- incorporated into the declaration -ppShortConstrParts :: Bool -> ConDecl DocName -> Bool -> (Html, Html, Html) -ppShortConstrParts summary con unicode = case con_res con of +ppShortConstrParts :: Bool -> ConDecl DocName -> Bool -> Qualification -> (Html, Html, Html) +ppShortConstrParts summary con unicode quali = case con_res con of ResTyH98 -> case con_details con of PrefixCon args -> - (header_ unicode +++ hsep (ppBinder summary occ : map (ppLParendType unicode) args), - noHtml, noHtml) + (header_ unicode quali +++ hsep (ppBinder summary occ + : map (ppLParendType unicode quali) args), noHtml, noHtml) RecCon fields -> - (header_ unicode +++ ppBinder summary occ <+> char '{', + (header_ unicode quali +++ ppBinder summary occ <+> char '{', doRecordFields fields, char '}') InfixCon arg1 arg2 -> - (header_ unicode +++ hsep [ppLParendType unicode arg1, ppBinder summary occ, ppLParendType unicode arg2], + (header_ unicode quali +++ hsep [ppLParendType unicode quali arg1, + ppBinder summary occ, ppLParendType unicode quali arg2], noHtml, noHtml) ResTyGADT resTy -> case con_details con of @@ -491,16 +509,16 @@ ppShortConstrParts summary con unicode = case con_res con of -- (except each field gets its own line in docs, to match -- non-GADT records) RecCon fields -> (ppBinder summary occ <+> dcolon unicode <+> - ppForAll forall ltvs lcontext unicode <+> char '{', + ppForAll forall ltvs lcontext unicode quali <+> char '{', doRecordFields fields, - char '}' <+> arrow unicode <+> ppLType unicode resTy) + char '}' <+> arrow unicode <+> ppLType unicode quali resTy) InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml) where - doRecordFields fields = shortSubDecls (map (ppShortField summary unicode) fields) + doRecordFields fields = shortSubDecls (map (ppShortField summary unicode quali) fields) doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [ - ppForAll forall ltvs lcontext unicode, - ppLType unicode (foldr mkFunTy resTy args) ] + ppForAll forall ltvs lcontext unicode quali, + ppLType unicode quali (foldr mkFunTy resTy args) ] header_ = ppConstrHdr forall tyVars context occ = docNameOcc . unLoc . con_name $ con @@ -514,35 +532,39 @@ ppShortConstrParts summary con unicode = case con_res con of -- ppConstrHdr is for (non-GADT) existentials constructors' syntax #if __GLASGOW_HASKELL__ == 612 -ppConstrHdr :: HsExplicitForAll -> [Name] -> HsContext DocName -> Bool -> Html +ppConstrHdr :: HsExplicitForAll -> [Name] -> HsContext DocName -> Bool + -> Qualification -> Html #else -ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> Html +ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool + -> Qualification -> Html #endif -ppConstrHdr forall tvs ctxt unicode +ppConstrHdr forall tvs ctxt unicode quali = (if null tvs then noHtml else ppForall) +++ - (if null ctxt then noHtml else ppContextNoArrow ctxt unicode <+> darrow unicode +++ toHtml " ") + (if null ctxt then noHtml else ppContextNoArrow ctxt unicode quali + <+> darrow unicode +++ toHtml " ") where ppForall = case forall of Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> toHtml ". " Implicit -> noHtml -ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LConDecl DocName -> SubDecl -ppSideBySideConstr subdocs unicode (L _ con) = (decl, mbDoc, fieldPart) +ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> Qualification + -> LConDecl DocName -> SubDecl +ppSideBySideConstr subdocs unicode quali (L _ con) = (decl, mbDoc, fieldPart) where decl = case con_res con of ResTyH98 -> case con_details con of PrefixCon args -> - hsep ((header_ unicode +++ ppBinder False occ) - : map (ppLParendType unicode) args) + hsep ((header_ unicode quali +++ ppBinder False occ) + : map (ppLParendType unicode quali) args) - RecCon _ -> header_ unicode +++ ppBinder False occ + RecCon _ -> header_ unicode quali +++ ppBinder False occ InfixCon arg1 arg2 -> - hsep [header_ unicode+++ppLParendType unicode arg1, + hsep [header_ unicode quali +++ ppLParendType unicode quali arg1, ppBinder False occ, - ppLParendType unicode arg2] + ppLParendType unicode quali arg2] ResTyGADT resTy -> case con_details con of -- prefix & infix could also use hsConDeclArgTys if it seemed to @@ -555,13 +577,13 @@ ppSideBySideConstr subdocs unicode (L _ con) = (decl, mbDoc, fieldPart) RecCon fields -> [doRecordFields fields] _ -> [] - doRecordFields fields = subFields - (map (ppSideBySideField subdocs unicode) fields) + doRecordFields fields = subFields quali + (map (ppSideBySideField subdocs unicode quali) fields) doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html doGADTCon args resTy = ppBinder False occ <+> dcolon unicode - <+> hsep [ppForAll forall ltvs (con_cxt con) unicode, - ppLType unicode (foldr mkFunTy resTy args) ] + <+> hsep [ppForAll forall ltvs (con_cxt con) unicode quali, + ppLType unicode quali (foldr mkFunTy resTy args) ] header_ = ppConstrHdr forall tyVars context occ = docNameOcc . unLoc . con_name $ con @@ -576,9 +598,10 @@ ppSideBySideConstr subdocs unicode (L _ con) = (decl, mbDoc, fieldPart) mkFunTy a b = noLoc (HsFunTy a b) -ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> SubDecl -ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) = - (ppBinder False (docNameOcc name) <+> dcolon unicode <+> ppLType unicode ltype, +ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> Qualification + -> ConDeclField DocName -> SubDecl +ppSideBySideField subdocs unicode quali (ConDeclField (L _ name) ltype _) = + (ppBinder False (docNameOcc name) <+> dcolon unicode <+> ppLType unicode quali ltype, mbDoc, []) where @@ -586,22 +609,22 @@ ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) = mbDoc = join $ fmap fst $ lookup name subdocs -ppShortField :: Bool -> Bool -> ConDeclField DocName -> Html -ppShortField summary unicode (ConDeclField (L _ name) ltype _) +ppShortField :: Bool -> Bool -> Qualification -> ConDeclField DocName -> Html +ppShortField summary unicode quali (ConDeclField (L _ name) ltype _) = ppBinder summary (docNameOcc name) - <+> dcolon unicode <+> ppLType unicode ltype + <+> dcolon unicode <+> ppLType unicode quali ltype -- | Print the LHS of a data\/newtype declaration. -- Currently doesn't handle 'data instance' decls or kind signatures -ppDataHeader :: Bool -> TyClDecl DocName -> Bool -> Html -ppDataHeader summary decl unicode +ppDataHeader :: Bool -> TyClDecl DocName -> Bool -> Qualification -> Html +ppDataHeader summary decl unicode quali | not (isDataDecl decl) = error "ppDataHeader: illegal argument" | otherwise = -- newtype or data (if tcdND decl == NewType then keyword "newtype" else keyword "data") <+> -- context - ppLContext (tcdCtxt decl) unicode <+> + ppLContext (tcdCtxt decl) unicode quali <+> -- T a b c ..., or a :+: b ppTyClBinderWithVars summary decl @@ -648,16 +671,17 @@ maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p | otherwise = p -ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocName) -> Html -ppLType unicode y = ppType unicode (unLoc y) -ppLParendType unicode y = ppParendType unicode (unLoc y) -ppLFunLhType unicode y = ppFunLhType unicode (unLoc y) +ppLType, ppLParendType, ppLFunLhType :: Bool -> Qualification + -> Located (HsType DocName) -> Html +ppLType unicode quali y = ppType unicode quali (unLoc y) +ppLParendType unicode quali y = ppParendType unicode quali (unLoc y) +ppLFunLhType unicode quali y = ppFunLhType unicode quali (unLoc y) -ppType, ppParendType, ppFunLhType :: Bool -> HsType DocName -> Html -ppType unicode ty = ppr_mono_ty pREC_TOP ty unicode -ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode -ppFunLhType unicode ty = ppr_mono_ty pREC_FUN ty unicode +ppType, ppParendType, ppFunLhType :: Bool -> Qualification-> HsType DocName -> Html +ppType unicode quali ty = ppr_mono_ty pREC_TOP ty unicode quali +ppParendType unicode quali ty = ppr_mono_ty pREC_CON ty unicode quali +ppFunLhType unicode quali ty = ppr_mono_ty pREC_FUN ty unicode quali -- Drop top-level for-all type variables in user style @@ -668,65 +692,66 @@ ppForAll :: HsExplicitForAll -> [Located (HsTyVarBndr DocName)] #else ppForAll :: HsExplicitFlag -> [Located (HsTyVarBndr DocName)] #endif - -> Located (HsContext DocName) -> Bool -> Html -ppForAll expl tvs cxt unicode - | show_forall = forall_part <+> ppLContext cxt unicode - | otherwise = ppLContext cxt unicode + -> Located (HsContext DocName) -> Bool -> Qualification -> Html +ppForAll expl tvs cxt unicode quali + | show_forall = forall_part <+> ppLContext cxt unicode quali + | otherwise = ppLContext cxt unicode quali where show_forall = not (null tvs) && is_explicit is_explicit = case expl of {Explicit -> True; Implicit -> False} forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot -ppr_mono_lty :: Int -> LHsType DocName -> Bool -> Html -ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode +ppr_mono_lty :: Int -> LHsType DocName -> Bool -> Qualification -> Html +ppr_mono_lty ctxt_prec ty unicode quali = ppr_mono_ty ctxt_prec (unLoc ty) unicode quali -ppr_mono_ty :: Int -> HsType DocName -> Bool -> Html -ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode +ppr_mono_ty :: Int -> HsType DocName -> Bool -> Qualification -> Html +ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode quali = maybeParen ctxt_prec pREC_FUN $ - hsep [ppForAll expl tvs ctxt unicode, ppr_mono_lty pREC_TOP ty unicode] - -ppr_mono_ty _ (HsBangTy b ty) u = ppBang b +++ ppLParendType u ty -ppr_mono_ty _ (HsTyVar name) _ = ppDocName name -ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u -ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys) -ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppKind kind) -ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u) -ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u) -ppr_mono_ty _ (HsPredTy p) u = parens (ppPred u p) -ppr_mono_ty _ (HsNumTy n) _ = toHtml (show n) -- generics only -ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" + hsep [ppForAll expl tvs ctxt unicode quali, ppr_mono_lty pREC_TOP ty unicode quali] + +ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty +ppr_mono_ty _ (HsTyVar name) _ q = ppDocName q name +ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q +ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys) +ppr_mono_ty _ (HsKindSig ty kind) u q = + parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppKind kind) +ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP ty u q) +ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q) +ppr_mono_ty _ (HsPredTy p) u q = parens (ppPred u q p) +ppr_mono_ty _ (HsNumTy n) _ _ = toHtml (show n) -- generics only +ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy" #if __GLASGOW_HASKELL__ == 612 -ppr_mono_ty _ (HsSpliceTyOut {}) _ = error "ppr_mono_ty HsQuasiQuoteTy" +ppr_mono_ty _ (HsSpliceTyOut {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy" #else -ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy" +ppr_mono_ty _ (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy" #endif -ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy" +ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy" -ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode +ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode quali = maybeParen ctxt_prec pREC_CON $ - hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode] + hsep [ppr_mono_lty pREC_FUN fun_ty unicode quali, ppr_mono_lty pREC_CON arg_ty unicode quali] -ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode +ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode quali = maybeParen ctxt_prec pREC_FUN $ - ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode + ppr_mono_lty pREC_OP ty1 unicode quali <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode quali where - ppr_op = if not (isSymOcc occName) then quote (ppLDocName op) else ppLDocName op + ppr_op = if not (isSymOcc occName) then quote (ppLDocName quali op) else ppLDocName quali op occName = docNameOcc . unLoc $ op -ppr_mono_ty ctxt_prec (HsParTy ty) unicode +ppr_mono_ty ctxt_prec (HsParTy ty) unicode quali -- = parens (ppr_mono_lty pREC_TOP ty) - = ppr_mono_lty ctxt_prec ty unicode + = ppr_mono_lty ctxt_prec ty unicode quali -ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode - = ppr_mono_lty ctxt_prec ty unicode +ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode quali + = ppr_mono_lty ctxt_prec ty unicode quali -ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> Html -ppr_fun_ty ctxt_prec ty1 ty2 unicode - = let p1 = ppr_mono_lty pREC_FUN ty1 unicode - p2 = ppr_mono_lty pREC_TOP ty2 unicode +ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> Qualification -> Html +ppr_fun_ty ctxt_prec ty1 ty2 unicode quali + = let p1 = ppr_mono_lty pREC_FUN ty1 unicode quali + p2 = ppr_mono_lty pREC_TOP ty2 unicode quali in maybeParen ctxt_prec pREC_FUN $ hsep [p1, arrow unicode <+> p2] diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs index be9ae876..fb03b123 100644 --- a/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -75,9 +75,9 @@ parHtmlMarkup ppId isTyCon = Markup { -- If the doc is a single paragraph, don't surround it with <P> (this causes -- ugly extra whitespace with some browsers). FIXME: Does this still apply? -docToHtml :: Doc DocName -> Html -docToHtml = markup fmt . cleanup - where fmt = parHtmlMarkup ppDocName (isTyConName . getName) +docToHtml :: Qualification -> Doc DocName -> Html +docToHtml quali = markup fmt . cleanup + where fmt = parHtmlMarkup (ppDocName quali) (isTyConName . getName) origDocToHtml :: Doc Name -> Html @@ -97,12 +97,12 @@ docElement el content_ = else el ! [theclass "doc"] << content_ -docSection :: Doc DocName -> Html -docSection = (docElement thediv <<) . docToHtml +docSection :: Qualification -> Doc DocName -> Html +docSection quali = (docElement thediv <<) . (docToHtml quali) -maybeDocSection :: Maybe (Doc DocName) -> Html -maybeDocSection = maybe noHtml docSection +maybeDocSection :: Qualification -> Maybe (Doc DocName) -> Html +maybeDocSection quali = maybe noHtml (docSection quali) cleanup :: Doc a -> Doc a diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs index 295af305..7277a683 100644 --- a/src/Haddock/Backends/Xhtml/Layout.hs +++ b/src/Haddock/Backends/Xhtml/Layout.hs @@ -112,25 +112,25 @@ divSubDecls cssClass captionName = maybe noHtml wrap subCaption = paragraph ! [theclass "caption"] << captionName -subDlist :: [SubDecl] -> Maybe Html -subDlist [] = Nothing -subDlist decls = Just $ dlist << map subEntry decls +++ clearDiv +subDlist :: Qualification -> [SubDecl] -> Maybe Html +subDlist _ [] = Nothing +subDlist quali decls = Just $ dlist << map subEntry decls +++ clearDiv where subEntry (decl, mdoc, subs) = dterm ! [theclass "src"] << decl +++ - docElement ddef << (fmap docToHtml mdoc +++ subs) + docElement ddef << (fmap docToHtml mdoc +++ subs) clearDiv = thediv ! [ theclass "clear" ] << noHtml -subTable :: [SubDecl] -> Maybe Html -subTable [] = Nothing -subTable decls = Just $ table << aboves (concatMap subRow decls) +subTable :: Qualification -> [SubDecl] -> Maybe Html +subTable _ [] = Nothing +subTable quali decls = Just $ table << aboves (concatMap subRow decls) where subRow (decl, mdoc, subs) = (td ! [theclass "src"] << decl <-> - docElement td << fmap docToHtml mdoc) + docElement td << fmap (docToHtml quali) mdoc) : map (cell . (td <<)) subs @@ -139,27 +139,27 @@ subBlock [] = Nothing subBlock hs = Just $ toHtml hs -subArguments :: [SubDecl] -> Html -subArguments = divSubDecls "arguments" "Arguments" . subTable +subArguments :: Qualification -> [SubDecl] -> Html +subArguments quali = divSubDecls "arguments" "Arguments" . (subTable quali) subAssociatedTypes :: [Html] -> Html subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBlock -subConstructors :: [SubDecl] -> Html -subConstructors = divSubDecls "constructors" "Constructors" . subTable +subConstructors :: Qualification -> [SubDecl] -> Html +subConstructors quali = divSubDecls "constructors" "Constructors" . (subTable quali) -subFields :: [SubDecl] -> Html -subFields = divSubDecls "fields" "Fields" . subDlist +subFields :: Qualification -> [SubDecl] -> Html +subFields quali = divSubDecls "fields" "Fields" . (subDlist quali) -subInstances :: String -> [SubDecl] -> Html -subInstances nm = maybe noHtml wrap . instTable +subInstances :: Qualification -> String -> [SubDecl] -> Html +subInstances quali nm = maybe noHtml wrap . instTable where wrap = (subSection <<) . (subCaption +++) - instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTable + instTable = fmap (thediv ! collapseSection id_ True [] <<) . (subTable quali) subSection = thediv ! [theclass $ "subs instances"] subCaption = paragraph ! collapseControl id_ True "caption" << "Instances" id_ = makeAnchorId $ "i:" ++ nm diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs index 068fc0f7..6df32fc4 100644 --- a/src/Haddock/Backends/Xhtml/Names.hs +++ b/src/Haddock/Backends/Xhtml/Names.hs @@ -38,16 +38,21 @@ ppRdrName :: RdrName -> Html ppRdrName = ppOccName . rdrNameOcc -ppLDocName :: Located DocName -> Html -ppLDocName (L _ d) = ppDocName d +ppLDocName :: Qualification -> Located DocName -> Html +ppLDocName quali (L _ d) = ppDocName quali d -ppDocName :: DocName -> Html -ppDocName (Documented name mdl) = - linkIdOcc mdl (Just occName) << ppOccName occName +ppDocName :: Qualification -> DocName -> Html +ppDocName quali (Documented name mdl) = + linkIdOcc mdl (Just occName) << theName where occName = nameOccName name -ppDocName (Undocumented name) = toHtml (getOccString name) + theName = case quali of + NoQuali -> ppName name + FullQuali -> ppQualName mdl name +ppDocName _ (Undocumented name) = ppName name +ppQualName :: Module -> Name -> Html +ppQualName mdl name = toHtml $ moduleString mdl ++ '.' : getOccString name ppName :: Name -> Html ppName name = toHtml (getOccString name) |