diff options
Diffstat (limited to 'src/Haddock/Backends/Xhtml')
| -rw-r--r-- | src/Haddock/Backends/Xhtml/Decl.hs | 210 | ||||
| -rw-r--r-- | src/Haddock/Backends/Xhtml/DocMarkup.hs | 14 | ||||
| -rw-r--r-- | src/Haddock/Backends/Xhtml/Layout.hs | 9 | ||||
| -rw-r--r-- | src/Haddock/Backends/Xhtml/Names.hs | 38 | ||||
| -rw-r--r-- | src/Haddock/Backends/Xhtml/Utils.hs | 15 |
5 files changed, 128 insertions, 158 deletions
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 686e9a3e..59be34f7 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -26,7 +26,6 @@ import Haddock.Backends.Xhtml.Utils import Haddock.GhcUtils import Haddock.Types -import Control.Monad ( join ) import Data.List ( intersperse ) import qualified Data.Map as Map import Data.Maybe @@ -34,21 +33,16 @@ import Text.XHtml hiding ( name, title, p, quote ) import GHC import Name -import BasicTypes ( ipNameName ) --- TODO: use DeclInfo DocName or something ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> Bool -> Qualification -> Html ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode qual = case decl of TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d unicode qual - TyClD d@(TyData {}) - | Nothing <- tcdTyPats d -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual - | Just _ <- tcdTyPats d -> ppDataInst summ links loc mbDoc d - TyClD d@(TySynonym {}) - | Nothing <- tcdTyPats d -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual - | Just _ <- tcdTyPats d -> ppTyInst summ False links loc mbDoc d unicode qual + TyClD d@(TyDecl{ tcdTyDefn = defn }) + | isHsDataDefn defn -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual + | otherwise -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode qual SigD (TypeSig lnames (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) (map unLoc lnames) t unicode qual ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode qual @@ -73,14 +67,14 @@ ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName -> DocForDecl DocName -> (Html, Html, Html) -> Bool -> Qualification -> Html ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) unicode qual | summary = pref1 - | Map.null argDocs = topDeclElem links loc docnames pref1 +++ maybeDocSection qual doc + | Map.null argDocs = topDeclElem links loc docnames pref1 +++ docSection qual doc | otherwise = topDeclElem links loc docnames pref2 +++ - subArguments qual (do_args 0 sep typ) +++ maybeDocSection qual doc + subArguments qual (do_args 0 sep typ) +++ docSection qual doc where argDoc n = Map.lookup n argDocs do_largs n leader (L _ t) = do_args n leader t - do_args :: Int -> Html -> (HsType DocName) -> [SubDecl] + do_args :: Int -> Html -> HsType DocName -> [SubDecl] do_args n leader (HsForAllTy Explicit tvs lctxt ltype) = (leader <+> hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+> @@ -100,15 +94,15 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) = (leader <+> ppLFunLhType unicode qual lt, argDoc n, []) : do_largs (n+1) (arrow unicode) r do_args n leader t - = (leader <+> ppType unicode qual t, argDoc n, []) : [] + = [(leader <+> ppType unicode qual t, argDoc n, [])] -ppTyVars :: [LHsTyVarBndr DocName] -> [Html] +ppTyVars :: LHsTyVarBndrs DocName -> [Html] ppTyVars tvs = map ppTyName (tyvarNames tvs) -tyvarNames :: [LHsTyVarBndr DocName] -> [Name] -tyvarNames = map (getName . hsTyVarName . unLoc) +tyvarNames :: LHsTyVarBndrs DocName -> [Name] +tyvarNames = map getName . hsLTyVarNames ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName @@ -121,7 +115,9 @@ ppFor _ _ _ _ _ _ _ = error "ppFor" -- we skip type patterns for now ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> Qualification -> Html -ppTySyn summary links loc doc (TySynonym (L _ name) ltyvars _ ltype) unicode qual +ppTySyn summary links loc doc (TyDecl { tcdLName = L _ name, tcdTyVars = ltyvars + , tcdTyDefn = TySynonym { td_synRhs = ltype } }) + unicode qual = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc (full, hdr, spaceHtml +++ equals) unicode qual where @@ -163,17 +159,17 @@ ppTyFamHeader summary associated decl unicode qual = ppTyClBinderWithVars summary decl <+> - case tcdKind decl of + case tcdKindSig decl of Just kind -> dcolon unicode <+> ppLKind unicode qual kind - Nothing -> noHtml + Nothing -> noHtml -ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) -> +ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool -> Qualification -> Html -ppTyFam summary associated links loc mbDoc decl unicode qual +ppTyFam summary associated links loc doc decl unicode qual | summary = ppTyFamHeader True associated decl unicode qual - | otherwise = header_ +++ maybeDocSection qual mbDoc +++ instancesBit + | otherwise = header_ +++ docSection qual doc +++ instancesBit where docname = tcdName decl @@ -187,50 +183,6 @@ ppTyFam summary associated links loc mbDoc decl unicode qual -------------------------------------------------------------------------------- --- * Indexed data types --------------------------------------------------------------------------------- - - -ppDataInst :: a -ppDataInst = undefined - - --------------------------------------------------------------------------------- --- * Indexed newtypes --------------------------------------------------------------------------------- - --- TODO --- ppNewTyInst = undefined - - --------------------------------------------------------------------------------- --- * Indexed types --------------------------------------------------------------------------------- - - -ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) -> - TyClDecl DocName -> Bool -> Qualification -> Html -ppTyInst summary associated links loc mbDoc decl unicode qual - - | summary = ppTyInstHeader True associated decl unicode qual - | otherwise = header_ +++ maybeDocSection qual mbDoc - - where - docname = tcdName decl - - header_ = topDeclElem links loc [docname] - (ppTyInstHeader summary associated decl unicode qual) - - -ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Qualification -> Html -ppTyInstHeader _ _ decl unicode qual = - keyword "type instance" <+> - ppAppNameTypes (tcdName decl) typeArgs unicode qual - where - typeArgs = map unLoc . fromJust . tcdTyPats $ decl - - --------------------------------------------------------------------------------- -- * Associated Types -------------------------------------------------------------------------------- @@ -240,7 +192,6 @@ ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LTyClDecl DocName -> B ppAssocType summ links doc (L loc decl) unicode qual = case decl of TyFamily {} -> ppTyFam summ True links loc (fst doc) decl unicode qual - TySynonym {} -> ppTySyn summ links loc doc decl unicode qual _ -> error "declaration type not supported by ppAssocType" @@ -297,12 +248,12 @@ ppLContextNoArrow = ppContextNoArrow . unLoc ppContextNoArrow :: HsContext DocName -> Bool -> Qualification -> Html ppContextNoArrow [] _ _ = noHtml -ppContextNoArrow cxt unicode qual = pp_hs_context (map unLoc cxt) unicode qual +ppContextNoArrow cxt unicode qual = ppHsContext (map unLoc cxt) unicode qual ppContextNoLocs :: [HsType DocName] -> Bool -> Qualification -> Html ppContextNoLocs [] _ _ = noHtml -ppContextNoLocs cxt unicode qual = pp_hs_context cxt unicode qual +ppContextNoLocs cxt unicode qual = ppHsContext cxt unicode qual <+> darrow unicode @@ -310,10 +261,10 @@ ppContext :: HsContext DocName -> Bool -> Qualification -> Html ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual -pp_hs_context :: [HsType DocName] -> Bool -> Qualification-> Html -pp_hs_context [] _ _ = noHtml -pp_hs_context [p] unicode qual = ppType unicode qual p -pp_hs_context cxt unicode qual = parenList (map (ppType unicode qual) cxt) +ppHsContext :: [HsType DocName] -> Bool -> Qualification-> Html +ppHsContext [] _ _ = noHtml +ppHsContext [p] unicode qual = ppType unicode qual p +ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt) ------------------------------------------------------------------------------- @@ -322,13 +273,13 @@ pp_hs_context cxt unicode qual = parenList (map (ppType unicode qual) cxt) ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName - -> [Located (HsTyVarBndr DocName)] -> [Located ([DocName], [DocName])] + -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])] -> Bool -> Qualification -> Html ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class" <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml) - <+> ppAppDocNameNames summ n (tyvarNames $ tvs) - <+> ppFds fds unicode qual + <+> ppAppDocNameNames summ n (tyvarNames tvs) + <+> ppFds fds unicode qual ppFds :: [Located ([DocName], [DocName])] -> Bool -> Qualification -> Html @@ -343,7 +294,8 @@ ppFds fds unicode qual = ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, DocForDecl DocName)] -> Bool -> Qualification -> Html -ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _ _) loc +ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs + , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc subdocs unicode qual = if null sigs && null ats then (if summary then id else topDeclElem links loc [nm]) hdr @@ -353,6 +305,8 @@ ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _ _) lo [ ppAssocType summary links doc at unicode qual | at <- ats , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] ++ + -- ToDo: add associated type defaults + [ ppFunSig summary links loc doc names typ unicode qual | L _ (TypeSig lnames (L _ typ)) <- sigs , let doc = lookupAnySubdoc (head names) subdocs @@ -369,12 +323,13 @@ ppShortClassDecl _ _ _ _ _ _ _ = error "declaration type not supported by ppShor ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan - -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)] + -> Documentation DocName -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName -> Bool -> Qualification -> Html -ppClassDecl summary links instances loc mbDoc subdocs - decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _ _) unicode qual +ppClassDecl summary links instances loc d subdocs + decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars + , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats }) unicode qual | summary = ppShortClassDecl summary links decl loc subdocs unicode qual - | otherwise = classheader +++ maybeDocSection qual mbDoc + | otherwise = classheader +++ docSection qual d +++ atBit +++ methodBit +++ instancesBit where classheader @@ -385,6 +340,7 @@ ppClassDecl summary links instances loc mbDoc subdocs hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds + -- ToDo: add assocatied typ defaults atBit = subAssociatedTypes [ ppAssocType summary links doc at unicode qual | at <- ats , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] @@ -397,7 +353,7 @@ ppClassDecl summary links instances loc mbDoc subdocs -- there are different subdocs for different names in a single -- type signature? - instancesBit = ppInstances instances nm unicode qual + instancesBit = ppInstances instances nm unicode qual ppClassDecl _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" @@ -414,11 +370,8 @@ ppInstances instances baseName unicode qual <+> ppAppNameTypes n ts unicode qual -lookupAnySubdoc :: (Eq name1) => - name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2 -lookupAnySubdoc n subdocs = case lookup n subdocs of - Nothing -> noDocForDecl - Just docs -> docs +lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 +lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n ------------------------------------------------------------------------------- @@ -431,7 +384,7 @@ ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> TyClDecl DocName -> Bool -> Qualification -> Html ppShortDataDecl summary _links _loc dataDecl unicode qual - | [] <- cons = dataHeader + | [] <- cons = dataHeader | [lcon] <- cons, ResTyH98 <- resTy, (cHead,cBody,cFoot) <- ppShortConstrParts summary (unLoc lcon) unicode qual @@ -448,22 +401,22 @@ ppShortDataDecl summary _links _loc dataDecl unicode qual doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual - cons = tcdCons dataDecl + cons = td_cons (tcdTyDefn dataDecl) resTy = (con_res . unLoc . head) cons ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> - SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool -> + SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool -> Qualification -> Html -ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode qual +ppDataDecl summary links instances subdocs loc doc dataDecl unicode qual | summary = ppShortDataDecl summary links loc dataDecl unicode qual - | otherwise = header_ +++ maybeDocSection qual mbDoc +++ constrBit +++ instancesBit + | otherwise = header_ +++ docSection qual doc +++ constrBit +++ instancesBit where docname = unLoc . tcdLName $ dataDecl - cons = tcdCons dataDecl + cons = td_cons (tcdTyDefn dataDecl) resTy = (con_res . unLoc . head) cons header_ = topDeclElem links loc [docname] (ppDataHeader summary dataDecl unicode qual @@ -514,7 +467,7 @@ ppShortConstrParts summary con unicode qual = 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 qual <+> char '{', + ppForAll forall_ ltvs lcontext unicode qual <+> char '{', doRecordFields fields, char '}' <+> arrow unicode <+> ppLType unicode qual resTy) InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml) @@ -522,29 +475,29 @@ ppShortConstrParts summary con unicode qual = case con_res con of where doRecordFields fields = shortSubDecls (map (ppShortField summary unicode qual) fields) doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [ - ppForAll forall ltvs lcontext unicode qual, + ppForAll forall_ ltvs lcontext unicode qual, ppLType unicode qual (foldr mkFunTy resTy args) ] - header_ = ppConstrHdr forall tyVars context + header_ = ppConstrHdr forall_ tyVars context occ = nameOccName . getName . unLoc . con_name $ con ltvs = con_qvars con tyVars = tyvarNames ltvs lcontext = con_cxt con context = unLoc (con_cxt con) - forall = con_explicit con + forall_ = con_explicit con mkFunTy a b = noLoc (HsFunTy a b) -- ppConstrHdr is for (non-GADT) existentials constructors' syntax ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> Qualification -> Html -ppConstrHdr forall tvs ctxt unicode qual +ppConstrHdr forall_ tvs ctxt unicode qual = (if null tvs then noHtml else ppForall) +++ (if null ctxt then noHtml else ppContextNoArrow ctxt unicode qual <+> darrow unicode +++ toHtml " ") where - ppForall = case forall of + ppForall = case forall_ of Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> toHtml ". " Implicit -> noHtml @@ -582,19 +535,18 @@ ppSideBySideConstr subdocs unicode qual (L _ con) = (decl, mbDoc, fieldPart) doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html doGADTCon args resTy = ppBinder False occ <+> dcolon unicode - <+> hsep [ppForAll forall ltvs (con_cxt con) unicode qual, + <+> hsep [ppForAll forall_ ltvs (con_cxt con) unicode qual, ppLType unicode qual (foldr mkFunTy resTy args) ] - header_ = ppConstrHdr forall tyVars context + header_ = ppConstrHdr forall_ tyVars context occ = nameOccName . getName . unLoc . con_name $ con ltvs = con_qvars con tyVars = tyvarNames (con_qvars con) context = unLoc (con_cxt con) - forall = con_explicit con + forall_ = con_explicit con -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. - -- 'join' is in Maybe. - mbDoc = join $ fmap fst $ lookup (unLoc $ con_name con) subdocs + mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst mkFunTy a b = noLoc (HsFunTy a b) @@ -606,7 +558,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) = []) where -- don't use cd_fld_doc for same reason we don't use con_doc above - mbDoc = join $ fmap fst $ lookup name subdocs + mbDoc = lookup name subdocs >>= combineDocumentation . fst ppShortField :: Bool -> Bool -> Qualification -> ConDeclField DocName -> Html @@ -618,15 +570,15 @@ ppShortField summary unicode qual (ConDeclField (L _ name) ltype _) -- | Print the LHS of a data\/newtype declaration. -- Currently doesn't handle 'data instance' decls or kind signatures ppDataHeader :: Bool -> TyClDecl DocName -> Bool -> Qualification -> Html -ppDataHeader summary decl unicode qual - | not (isDataDecl decl) = error "ppDataHeader: illegal argument" - | otherwise = - -- newtype or data - (if tcdND decl == NewType then keyword "newtype" else keyword "data") <+> +ppDataHeader summary decl@(TyDecl { tcdTyDefn = TyData { td_ND = nd, td_ctxt = ctxt } }) + unicode qual + = -- newtype or data + (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+> -- context - ppLContext (tcdCtxt decl) unicode qual <+> + ppLContext ctxt unicode qual <+> -- T a b c ..., or a :+: b ppTyClBinderWithVars summary decl +ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument" -------------------------------------------------------------------------------- @@ -652,13 +604,13 @@ tupleParens _ = parenList pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int -pREC_TOP = (0 :: Int) -- type in ParseIface.y in GHC -pREC_FUN = (1 :: Int) -- btype in ParseIface.y in GHC - -- Used for LH arg of (->) -pREC_OP = (2 :: Int) -- Used for arg of any infix operator - -- (we don't keep their fixities around) -pREC_CON = (3 :: Int) -- Used for arg of type applicn: - -- always parenthesise unless atomic +pREC_TOP = 0 :: Int -- type in ParseIface.y in GHC +pREC_FUN = 1 :: Int -- btype in ParseIface.y in GHC + -- Used for LH arg of (->) +pREC_OP = 2 :: Int -- Used for arg of any infix operator + -- (we don't keep their fixities around) +pREC_CON = 3 :: Int -- Used for arg of type applicn: + -- always parenthesise unless atomic maybeParen :: Int -- Precedence of context -> Int -- Precedence of top-level operator @@ -688,19 +640,19 @@ ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell -ppForAll :: HsExplicitFlag -> [Located (HsTyVarBndr DocName)] +ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName -> Located (HsContext DocName) -> Bool -> Qualification -> Html ppForAll expl tvs cxt unicode qual | show_forall = forall_part <+> ppLContext cxt unicode qual | otherwise = ppLContext cxt unicode qual where - show_forall = not (null tvs) && is_explicit + show_forall = not (null (hsQTvBndrs 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 -> Qualification -> Html -ppr_mono_lty ctxt_prec ty unicode qual = ppr_mono_ty ctxt_prec (unLoc ty) unicode qual +ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) ppr_mono_ty :: Int -> HsType DocName -> Bool -> Qualification -> Html @@ -716,13 +668,9 @@ ppr_mono_ty _ (HsKindSig ty kind) u q = parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppLKind u q 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 _ (HsIParamTy n ty) u q = brackets (ppDocName q (ipNameName n) <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q) +ppr_mono_ty _ (HsIParamTy n ty) u q = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q) ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy" -#if __GLASGOW_HASKELL__ == 612 -ppr_mono_ty _ (HsSpliceTyOut {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy" -#else ppr_mono_ty _ (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy" -#endif ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy" ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty _ (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys @@ -741,8 +689,8 @@ ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode qual = maybeParen ctxt_prec pREC_FUN $ ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual where - ppr_op = if not (isSymOcc occName) then quote (ppLDocName qual op) else ppLDocName qual op - occName = nameOccName . getName . unLoc $ op + ppr_op = if not (isSymOcc occ) then quote (ppLDocName qual op) else ppLDocName qual op + occ = nameOccName . getName . unLoc $ op ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual -- = parens (ppr_mono_lty pREC_TOP ty) @@ -751,6 +699,12 @@ ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual = ppr_mono_lty ctxt_prec ty unicode qual +ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n + +ppr_tylit :: HsTyLit -> Html +ppr_tylit (HsNumTy n) = toHtml (show n) +ppr_tylit (HsStrTy s) = toHtml (show s) + ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> Qualification -> Html ppr_fun_ty ctxt_prec ty1 ty2 unicode qual diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs index f506d2b8..e75cfaba 100644 --- a/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -15,7 +15,7 @@ module Haddock.Backends.Xhtml.DocMarkup ( rdrDocToHtml, origDocToHtml, - docElement, docSection, maybeDocSection, + docElement, docSection, docSection_, ) where @@ -25,6 +25,7 @@ import Haddock.Types import Haddock.Utils import Text.XHtml hiding ( name, title, p, quote ) +import Data.Maybe (fromMaybe) import GHC @@ -39,13 +40,14 @@ parHtmlMarkup qual ppId = Markup { markupIdentifierUnchecked = thecode . ppUncheckedLink qual, markupModule = \m -> let (mdl,ref) = break (=='#') m in ppModuleRef (mkModuleName mdl) ref, + markupWarning = thediv ! [theclass "warning"], markupEmphasis = emphasize, markupMonospaced = thecode, markupUnorderedList = unordList, markupOrderedList = ordList, markupDefList = defList, markupCodeBlock = pre, - markupURL = \url -> anchor ! [href url] << url, + markupHyperlink = \(Hyperlink url mLabel) -> anchor ! [href url] << fromMaybe url mLabel, markupAName = \aname -> namedAnchor aname << "", markupPic = \path -> image ! [src path], markupExample = examplesToHtml @@ -84,12 +86,12 @@ docElement el content_ = else el ! [theclass "doc"] << content_ -docSection :: Qualification -> Doc DocName -> Html -docSection qual = (docElement thediv <<) . docToHtml qual +docSection :: Qualification -> Documentation DocName -> Html +docSection qual = maybe noHtml (docSection_ qual) . combineDocumentation -maybeDocSection :: Qualification -> Maybe (Doc DocName) -> Html -maybeDocSection qual = maybe noHtml (docSection qual) +docSection_ :: Qualification -> Doc DocName -> Html +docSection_ qual = (docElement thediv <<) . docToHtml qual cleanup :: Doc a -> Doc a diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs index bdd5ac78..3ddbd28b 100644 --- a/src/Haddock/Backends/Xhtml/Layout.hs +++ b/src/Haddock/Backends/Xhtml/Layout.hs @@ -18,6 +18,7 @@ module Haddock.Backends.Xhtml.Layout ( divIndex, divAlphabet, divModuleList, sectionName, + nonEmptySectionName, shortDeclList, shortSubDecls, @@ -66,6 +67,14 @@ sectionName :: Html -> Html sectionName = paragraph ! [theclass "caption"] +-- | Make an element that always has at least something (a non-breaking space). +-- If it would have otherwise been empty, then give it the class ".empty". +nonEmptySectionName :: Html -> Html +nonEmptySectionName c + | isNoHtml c = paragraph ! [theclass "caption empty"] $ spaceHtml + | otherwise = paragraph ! [theclass "caption"] $ c + + divPackageHeader, divContent, divModuleHeader, divFooter, divTableOfContents, divDescription, divSynposis, divInterface, divIndex, divAlphabet, divModuleList diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs index 7c2375cf..2f2b82ed 100644 --- a/src/Haddock/Backends/Xhtml/Names.hs +++ b/src/Haddock/Backends/Xhtml/Names.hs @@ -14,6 +14,7 @@ module Haddock.Backends.Xhtml.Names ( ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink, ppBinder, ppBinder', ppModule, ppModuleRef, + ppIPName, linkId ) where @@ -24,11 +25,13 @@ import Haddock.Types import Haddock.Utils import Text.XHtml hiding ( name, title, p, quote ) +import qualified Data.Map as M import qualified Data.List as List import GHC import Name import RdrName +import FastString (unpackFS) ppOccName :: OccName -> Html @@ -38,6 +41,9 @@ ppOccName = toHtml . occNameString ppRdrName :: RdrName -> Html ppRdrName = ppOccName . rdrNameOcc +ppIPName :: HsIPName -> Html +ppIPName = toHtml . unpackFS . hsIPNameFS + ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TODO: apply ppQualifyName @@ -52,7 +58,10 @@ ppDocName qual docName = case docName of Documented name mdl -> linkIdOcc mdl (Just (nameOccName name)) << ppQualifyName qual name mdl - Undocumented name -> ppQualifyName qual name (nameModule name) + Undocumented name + | isExternalName name || isWiredInName name -> + ppQualifyName qual name (nameModule name) + | otherwise -> ppName name -- | Render a name depending on the selected qualification mode @@ -61,28 +70,33 @@ ppQualifyName qual name mdl = case qual of NoQual -> ppName name FullQual -> ppFullQualName mdl name - -- this is just in case, it should never happen - LocalQual Nothing -> ppQualifyName FullQual name mdl - LocalQual (Just localmdl) - | moduleString mdl == moduleString localmdl -> ppName name - | otherwise -> ppFullQualName mdl name - -- again, this never happens - RelativeQual Nothing -> ppQualifyName FullQual name mdl - RelativeQual (Just localmdl) -> + LocalQual localmdl -> + if moduleString mdl == moduleString localmdl + then ppName name + else ppFullQualName mdl name + RelativeQual localmdl -> case List.stripPrefix (moduleString localmdl) (moduleString mdl) of -- local, A.x -> x - Just [] -> ppQualifyName NoQual name mdl + Just [] -> ppName name -- sub-module, A.B.x -> B.x Just ('.':m) -> toHtml $ m ++ '.' : getOccString name -- some module with same prefix, ABC.x -> ABC.x - Just _ -> ppQualifyName FullQual name mdl + Just _ -> ppFullQualName mdl name -- some other module, D.x -> D.x - Nothing -> ppQualifyName FullQual name mdl + Nothing -> ppFullQualName mdl name + AliasedQual aliases localmdl -> + case (moduleString mdl == moduleString localmdl, + M.lookup mdl aliases) of + (False, Just alias) -> ppQualName alias name + _ -> ppName name ppFullQualName :: Module -> Name -> Html ppFullQualName mdl name = toHtml $ moduleString mdl ++ '.' : getOccString name +ppQualName :: ModuleName -> Name -> Html +ppQualName mdlName name = + toHtml $ moduleNameString mdlName ++ '.' : getOccString name ppName :: Name -> Html ppName name = toHtml (getOccString name) diff --git a/src/Haddock/Backends/Xhtml/Utils.hs b/src/Haddock/Backends/Xhtml/Utils.hs index 7ba6d5f4..be1fcb9b 100644 --- a/src/Haddock/Backends/Xhtml/Utils.hs +++ b/src/Haddock/Backends/Xhtml/Utils.hs @@ -17,7 +17,7 @@ module Haddock.Backends.Xhtml.Utils ( spliceURL, groupId, - (<+>), char, nonEmpty, + (<+>), char, keyword, punctuate, braces, brackets, pabrackets, parens, parenList, ubxParenList, @@ -44,7 +44,7 @@ import Name ( getOccString, nameOccName, isValOcc ) spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name -> Maybe SrcSpan -> String -> String -spliceURL maybe_file maybe_mod maybe_name maybe_loc url = run url +spliceURL maybe_file maybe_mod maybe_name maybe_loc = run where file = fromMaybe "" maybe_file mdl = case maybe_mod of @@ -72,7 +72,7 @@ spliceURL maybe_file maybe_mod maybe_name maybe_loc url = run url run ('%':'N':rest) = name ++ run rest run ('%':'K':rest) = kind ++ run rest run ('%':'L':rest) = line ++ run rest - run ('%':'%':rest) = "%" ++ run rest + run ('%':'%':rest) = '%' : run rest run ('%':'{':'M':'O':'D':'U':'L':'E':'}':rest) = mdl ++ run rest run ('%':'{':'F':'I':'L':'E':'}':rest) = file ++ run rest @@ -119,15 +119,6 @@ char :: Char -> Html char c = toHtml [c] --- | Make an element that always has at least something (a non-breaking space) --- If it would have otherwise been empty, then give it the class ".empty" -nonEmpty :: (Html -> Html) -> Html -> Html -nonEmpty el content_ = - if isNoHtml content_ - then el ! [theclass "empty"] << spaceHtml - else el << content_ - - quote :: Html -> Html quote h = char '`' +++ h +++ '`' |