From 43bb89fa9667162f3f4a0e024a3f926696c173b9 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Sat, 21 Jan 2006 17:15:27 +0000 Subject: Teach haddock about line pragmas and add accurate source code links Teach haddock about C and Haskell style line pragmas. Extend the lexer/parser's source location tracking to include the file name as well as line/column. This way each AST item that is tagged with a SrcLoc gets the original file name too. Use this original file name to add source links to each exported item, in the same visual style as the wiki links. Note that the per-export source links are to the defining module rather than whichever module haddock pretends it is exported from. This is what we want for source code links. The source code link URL can also contain the name of the export so one could implement jumping to the actual location of the function in the file if it were linked to an html version of the source rather than just plain text. The name can be selected with the %N wild card. So for linking to the raw source code one might use: --source=http://darcs/haskell.org/foo/%F Or for linking to html syntax highlighted code: --source=http://darcs/haskell.org/foo/%M.html#%N --- src/HaddockHtml.hs | 147 ++++++++++++++++++++++++++++++----------------------- 1 file changed, 83 insertions(+), 64 deletions(-) (limited to 'src/HaddockHtml.hs') diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs index 420eab26..b04ee3c2 100644 --- a/src/HaddockHtml.hs +++ b/src/HaddockHtml.hs @@ -148,7 +148,8 @@ spliceSrcURL :: Interface -> String -> String spliceSrcURL iface url = run url where run "" = "" run ('%':'M':rest) = modl_str ++ run rest - run ('%':'F':rest) = iface_filename iface ++ run rest + run ('%':'N':rest) = run rest + run ('%':'F':rest) = iface_orig_filename iface ++ run rest run (c:rest) = c : run rest modl_str = case iface_module iface of { Module m -> @@ -492,13 +493,13 @@ ppHtmlModule odir doctitle pageHeader mdl iface doctitle maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url s15 - ifaceToHtml mdl maybe_wiki_url iface s15 + ifaceToHtml maybe_source_url maybe_wiki_url iface s15 footer ) writeFile (pathJoin [odir, moduleHtmlFile mdl]) (renderHtml html) -ifaceToHtml :: String -> Maybe String -> Interface -> HtmlTable -ifaceToHtml _ maybe_wiki_url iface +ifaceToHtml :: Maybe String -> Maybe String -> Interface -> HtmlTable +ifaceToHtml maybe_source_url maybe_wiki_url iface = abovesSep s15 (contents: description: synopsis: maybe_doc_hdr: bdy) where exports = numberSectionHeadings (iface_exports iface) @@ -526,7 +527,7 @@ ifaceToHtml _ maybe_wiki_url iface = (tda [theclass "section1"] << toHtml "Synopsis") s15 (tda [theclass "body"] << vanillaTable << - abovesSep s8 (map (processExport True Nothing) + abovesSep s8 (map (processExport True linksInfo) (filter forSummary exports)) ) @@ -538,10 +539,8 @@ ifaceToHtml _ maybe_wiki_url iface ExportGroup _ _ _ : _ -> Html.emptyTable _ -> tda [ theclass "section1" ] << toHtml "Documentation" - bdy = map (processExport False wiki_info) exports - wiki_info = case maybe_wiki_url of - Nothing -> Nothing - Just wiki_url -> Just (wiki_url, iface_module iface) + bdy = map (processExport False linksInfo) exports + linksInfo = (maybe_source_url, maybe_wiki_url, iface) ppModuleContents :: [ExportItem] -> HtmlTable ppModuleContents exports @@ -577,14 +576,14 @@ numberSectionHeadings exports = go 1 exports go n (other:es) = other : go n es --- The base URL for wiki links, and the current module -type WikiInfo = Maybe (String, Module) +-- The URL for source and wiki links, and the current module +type LinksInfo = (Maybe String, Maybe String, Interface) -processExport :: Bool -> WikiInfo -> ExportItem -> HtmlTable +processExport :: Bool -> LinksInfo -> ExportItem -> HtmlTable processExport _ _ (ExportGroup lev id0 doc) = ppDocGroup lev (namedAnchor id0 << docToHtml doc) -processExport summary wiki (ExportDecl x decl insts) - = doDecl summary wiki x decl insts +processExport summary links (ExportDecl x decl insts) + = doDecl summary links x decl insts processExport summmary _ (ExportNoDecl _ y []) = declBox (ppHsQName y) processExport summmary _ (ExportNoDecl _ y subs) @@ -609,36 +608,36 @@ ppDocGroup lev doc -- ----------------------------------------------------------------------------- -- Converting declarations to HTML -declWithDoc :: Bool -> WikiInfo -> HsName -> Maybe Doc -> Html -> HtmlTable -declWithDoc True _ _ _ html_decl = declBox html_decl -declWithDoc False wiki nm Nothing html_decl = topDeclBox wiki nm html_decl -declWithDoc False wiki nm (Just doc) html_decl = - topDeclBox wiki nm html_decl docBox (docToHtml doc) +declWithDoc :: Bool -> LinksInfo -> SrcLoc -> HsName -> Maybe Doc -> Html -> HtmlTable +declWithDoc True _ _ _ _ html_decl = declBox html_decl +declWithDoc False links loc nm Nothing html_decl = topDeclBox links loc nm html_decl +declWithDoc False links loc nm (Just doc) html_decl = + topDeclBox links loc nm html_decl docBox (docToHtml doc) -doDecl :: Bool -> WikiInfo -> HsQName -> HsDecl -> [InstHead] -> HtmlTable -doDecl summary wiki x d instances = do_decl d +doDecl :: Bool -> LinksInfo -> HsQName -> HsDecl -> [InstHead] -> HtmlTable +doDecl summary links x d instances = do_decl d where - do_decl (HsTypeSig _ [nm] ty doc) - = ppFunSig summary wiki nm ty doc + do_decl (HsTypeSig loc [nm] ty doc) + = ppFunSig summary links loc nm ty doc - do_decl (HsForeignImport _ _ _ _ n ty doc) - = ppFunSig summary wiki n ty doc + do_decl (HsForeignImport loc _ _ _ n ty doc) + = ppFunSig summary links loc n ty doc - do_decl (HsTypeDecl _ nm args ty doc) - = declWithDoc summary wiki nm doc ( + do_decl (HsTypeDecl loc nm args ty doc) + = declWithDoc summary links loc nm doc ( hsep ([keyword "type", ppHsBinder summary nm] ++ map ppHsName args) <+> equals <+> ppHsType ty) do_decl (HsNewTypeDecl loc ctx nm args con drv doc) - = ppHsDataDecl summary wiki instances True{-is newtype-} x + = ppHsDataDecl summary links instances True{-is newtype-} x (HsDataDecl loc ctx nm args [con] drv doc) -- print it as a single-constructor datatype do_decl d0@(HsDataDecl{}) - = ppHsDataDecl summary wiki instances False{-not newtype-} x d0 + = ppHsDataDecl summary links instances False{-not newtype-} x d0 do_decl d0@(HsClassDecl{}) - = ppHsClassDecl summary wiki instances x d0 + = ppHsClassDecl summary links instances x d0 do_decl (HsDocGroup _ lev str) = if summary then Html.emptyTable @@ -653,7 +652,7 @@ ppTypeSig summary nm ty = ppHsBinder summary nm <+> dcolon <+> ppHsType ty -- ----------------------------------------------------------------------------- -- Data & newtype declarations -ppShortDataDecl :: Bool -> WikiInfo -> Bool -> HsDecl -> Html +ppShortDataDecl :: Bool -> LinksInfo -> Bool -> HsDecl -> Html ppShortDataDecl summary _ is_newty (HsDataDecl _ _ nm args [con] _ _doc) = ppHsDataHeader summary is_newty nm args @@ -661,10 +660,10 @@ ppShortDataDecl summary _ is_newty ppShortDataDecl summary _ is_newty (HsDataDecl _ _ nm args [] _ _doc) = ppHsDataHeader summary is_newty nm args -ppShortDataDecl summary wiki is_newty - (HsDataDecl _ _ nm args cons _ _doc) = +ppShortDataDecl summary links is_newty + (HsDataDecl loc _ nm args cons _ _doc) = vanillaTable << ( - (if summary then declBox else topDeclBox wiki nm) + (if summary then declBox else topDeclBox links loc nm) (ppHsDataHeader summary is_newty nm args) tda [theclass "body"] << vanillaTable << ( aboves (zipWith do_constr ('=':repeat '|') cons) @@ -675,10 +674,10 @@ ppShortDataDecl _ _ _ d = error $ "HaddockHtml.ppShortDataDecl: unexpected decl " ++ show d -- The rest of the cases: -ppHsDataDecl :: Ord key => Bool -> WikiInfo -> [InstHead] -> Bool -> key -> HsDecl -> HtmlTable -ppHsDataDecl summary wiki instances is_newty - x decl@(HsDataDecl _ _ nm args cons _ doc) - | summary = declWithDoc summary wiki nm doc (ppShortDataDecl summary wiki is_newty decl) +ppHsDataDecl :: Ord key => Bool -> LinksInfo -> [InstHead] -> Bool -> key -> HsDecl -> HtmlTable +ppHsDataDecl summary links instances is_newty + x decl@(HsDataDecl loc _ nm args cons _ doc) + | summary = declWithDoc summary links loc nm doc (ppShortDataDecl summary links is_newty decl) | otherwise = dataheader @@ -688,7 +687,7 @@ ppHsDataDecl summary wiki instances is_newty instances_bit ) where - dataheader = topDeclBox wiki nm (ppHsDataHeader False is_newty nm args) + dataheader = topDeclBox links loc nm (ppHsDataHeader False is_newty nm args) constr_table | any isRecDecl cons = spacedTable5 @@ -835,15 +834,15 @@ ppFds fds = fundep (vars1,vars2) = hsep (map ppHsName vars1) <+> toHtml "->" <+> hsep (map ppHsName vars2) -ppShortClassDecl :: Bool -> WikiInfo -> HsDecl -> HtmlTable -ppShortClassDecl summary wiki (HsClassDecl _ ctxt nm tvs fds decls _) = +ppShortClassDecl :: Bool -> LinksInfo -> HsDecl -> HtmlTable +ppShortClassDecl summary links (HsClassDecl loc ctxt nm tvs fds decls _) = if null decls - then (if summary then declBox else topDeclBox wiki nm) hdr - else (if summary then declBox else topDeclBox wiki nm) (hdr <+> keyword "where") + then (if summary then declBox else topDeclBox links loc nm) hdr + else (if summary then declBox else topDeclBox links loc nm) (hdr <+> keyword "where") (tda [theclass "body"] << vanillaTable << - aboves [ ppFunSig summary wiki n ty doc + aboves [ ppFunSig summary links loc n ty doc | HsTypeSig _ [n] ty doc <- decls ] ) @@ -853,10 +852,10 @@ ppShortClassDecl summary wiki (HsClassDecl _ ctxt nm tvs fds decls _) = ppShortClassDecl _ _ d = error $ "HaddockHtml.ppShortClassDecl: unexpected decl: " ++ show d -ppHsClassDecl :: Ord key => Bool -> WikiInfo -> [InstHead] -> key -> HsDecl -> HtmlTable -ppHsClassDecl summary wiki instances orig_c - decl@(HsClassDecl _ ctxt nm tvs fds decls doc) - | summary = ppShortClassDecl summary wiki decl +ppHsClassDecl :: Ord key => Bool -> LinksInfo -> [InstHead] -> key -> HsDecl -> HtmlTable +ppHsClassDecl summary links instances orig_c + decl@(HsClassDecl loc ctxt nm tvs fds decls doc) + | summary = ppShortClassDecl summary links decl | otherwise = classheader @@ -866,8 +865,8 @@ ppHsClassDecl summary wiki instances orig_c where classheader - | null decls = topDeclBox wiki nm hdr - | otherwise = topDeclBox wiki nm (hdr <+> keyword "where") + | null decls = topDeclBox links loc nm hdr + | otherwise = topDeclBox links loc nm (hdr <+> keyword "where") hdr = ppClassHdr summary ctxt nm tvs fds @@ -880,7 +879,7 @@ ppHsClassDecl summary wiki instances orig_c | otherwise = s8 meth_hdr tda [theclass "body"] << vanillaTable << ( - abovesSep s8 [ ppFunSig summary wiki n ty doc0 + abovesSep s8 [ ppFunSig summary links loc n ty doc0 | HsTypeSig _ [n] ty doc0 <- decls ] ) @@ -907,13 +906,13 @@ ppInstHead (ctxt,asst) = ppHsContext ctxt <+> darrow <+> ppHsAsst asst -- ---------------------------------------------------------------------------- -- Type signatures -ppFunSig :: Bool -> WikiInfo -> HsName -> HsType -> Maybe Doc -> HtmlTable -ppFunSig summary wiki nm ty0 doc +ppFunSig :: Bool -> LinksInfo -> SrcLoc -> HsName -> HsType -> Maybe Doc -> HtmlTable +ppFunSig summary links loc nm ty0 doc | summary || no_arg_docs ty0 = - declWithDoc summary wiki nm doc (ppTypeSig summary nm ty0) + declWithDoc summary links loc nm doc (ppTypeSig summary nm ty0) | otherwise = - topDeclBox wiki nm (ppHsBinder False nm) + topDeclBox links loc nm (ppHsBinder False nm) (tda [theclass "body"] << vanillaTable << ( do_args dcolon ty0 (if (isJust doc) @@ -1157,18 +1156,38 @@ declBox :: Html -> HtmlTable declBox html = tda [theclass "decl"] << html -- a box for top level documented names --- it adds a wiki link at the right hand side of the box -topDeclBox :: Maybe (String, Module) -> HsName -> Html -> HtmlTable -topDeclBox Nothing name html = declBox html -topDeclBox (Just (base_url, Module mod)) name html = +-- it adds a source and wiki link at the right hand side of the box +topDeclBox :: LinksInfo -> SrcLoc -> HsName -> Html -> HtmlTable +topDeclBox (Nothing, Nothing, _) srcloc name html = declBox html +topDeclBox (maybe_src_url, maybe_wiki_url, iface) (SrcLoc _ _ fname) name html = tda [theclass "topdecl"] << ( table ! [theclass "declbar"] << - ((tda [theclass "declname"] << html) <-> - (tda [theclass "declbut"] << link)) + ((tda [theclass "declname"] << html) + <-> srcLink + <-> wikiLink) ) - where link = anchor ! [href url] << toHtml "Comments" - url = pathJoin [base_url, mod] ++ nameAnchor - nameAnchor = '#' : escapeStr (hsNameStr name) + where srcLink = + case maybe_src_url of + Nothing -> Html.emptyTable + Just url -> tda [theclass "declbut"] << + (anchor ! [href (spliceURL url)] + << toHtml "Source") + wikiLink = + case maybe_wiki_url of + Nothing -> Html.emptyTable + Just url -> tda [theclass "declbut"] << + (anchor ! [href (spliceURL url)] + << toHtml "Comments") + + spliceURL url = run url + where run "" = "" + run ('%':'M':rest) = mod ++ run rest + run ('%':'N':rest) = escapeStr (hsNameStr name) ++ run rest + run ('%':'F':rest) = fname ++ run rest + run (c:rest) = c : run rest + + Module mod = iface_module iface + mod' = map (\x -> if x == '.' then '/' else x) mod -- a box for displaying an 'argument' (some code which has text to the -- right of it). Wrapping is not allowed in these boxes, whereas it is -- cgit v1.2.3