From 0a09c293d3d2294363a86f41bc74c3f5df123a08 Mon Sep 17 00:00:00 2001 From: simonmar Date: Thu, 6 Nov 2003 12:39:47 +0000 Subject: [haddock @ 2003-11-06 12:39:46 by simonmar] - Add definition lists, marked up like this: -- | This is a definition list: -- -- [@foo@] The description of @foo@. -- -- [@bar@] The description of @bar@. Cunningly, the [] characters are not treated specially unless a [ is found at the beginning of a paragraph, in which case the ] becomes special in the following text. - Add --use-contents and --gen-contents, along the lines of --use-index and --gen-index added yesterday. Now we can generate a combined index and contents for the whole of the hierarchical libraries, and in theory the index/contents on the system could be updated as new packages are added. --- src/HaddockHtml.hs | 81 ++++++++++++++++++++++++++++++++++------------------ src/HaddockLex.x | 25 ++++++++++++---- src/HaddockParse.y | 10 +++++-- src/HaddockRename.hs | 3 ++ src/HsSyn.lhs | 12 +++++++- src/Main.hs | 30 +++++++++++++------ 6 files changed, 116 insertions(+), 45 deletions(-) (limited to 'src') diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs index e1604fad..03a837c3 100644 --- a/src/HaddockHtml.hs +++ b/src/HaddockHtml.hs @@ -1,10 +1,13 @@ -- -- Haddock - A Haskell Documentation Tool -- --- (c) Simon Marlow 2002 +-- (c) Simon Marlow 2002-2003 -- -module HaddockHtml ( ppHtml, copyHtmlBits, ppHtmlIndex ) where +module HaddockHtml ( + ppHtml, copyHtmlBits, + ppHtmlIndex, ppHtmlContents + ) where import Prelude hiding (div) import HaddockVersion @@ -47,23 +50,30 @@ ppHtml :: String -> FilePath -- destination directory -> Maybe Doc -- prologue text, maybe -> Bool -- do MS Help stuff + -> Maybe String -- the contents URL (--use-contents) -> Maybe String -- the index URL (--use-index) -> IO () -ppHtml doctitle source_url ifaces odir prologue do_ms_help maybe_index_url = do +ppHtml doctitle source_url ifaces odir prologue do_ms_help + maybe_contents_url maybe_index_url = do let visible_ifaces = filter visible ifaces visible (_, i) = OptHide `notElem` iface_options i - ppHtmlContents odir doctitle maybe_index_url (map fst visible_ifaces) prologue - ppHtmlIndex odir doctitle visible_ifaces + when (not (isJust maybe_contents_url)) $ + ppHtmlContents odir doctitle maybe_index_url + (map fst visible_ifaces) prologue + + when (not (isJust maybe_index_url)) $ + ppHtmlIndex odir doctitle maybe_contents_url visible_ifaces -- Generate index and contents page for MS help if requested when do_ms_help $ do ppHHContents odir (map fst visible_ifaces) ppHHIndex odir visible_ifaces - mapM_ (ppHtmlModule odir doctitle source_url maybe_index_url) visible_ifaces + mapM_ (ppHtmlModule odir doctitle source_url + maybe_contents_url maybe_index_url) visible_ifaces copyHtmlBits :: FilePath -> FilePath -> Maybe FilePath -> IO () @@ -119,30 +129,34 @@ parent_button mdl = _ -> Html.emptyTable -contentsButton :: HtmlTable -contentsButton = topButBox (anchor ! [href contentsHtmlFile] << - toHtml "Contents") +contentsButton :: Maybe String -> HtmlTable +contentsButton maybe_contents_url + = topButBox (anchor ! [href url] << toHtml "Contents") + where url = case maybe_contents_url of + Nothing -> contentsHtmlFile + Just url -> url indexButton :: Maybe String -> HtmlTable indexButton maybe_index_url - = topButBox (anchor ! [href url] << toHtml "Index") + = topButBox (anchor ! [href url] << toHtml "Index") where url = case maybe_index_url of Nothing -> indexHtmlFile Just url -> url -simpleHeader :: String -> Maybe String -> HtmlTable -simpleHeader doctitle maybe_index_url = +simpleHeader :: String -> Maybe String -> Maybe String -> HtmlTable +simpleHeader doctitle maybe_contents_url maybe_index_url = (tda [theclass "topbar"] << vanillaTable << ( (td << image ! [src "haskell_icon.gif", width "16", height 16, alt " " ] ) <-> (tda [theclass "title"] << toHtml doctitle) <-> - contentsButton <-> indexButton maybe_index_url + contentsButton maybe_contents_url <-> indexButton maybe_index_url )) -pageHeader :: String -> Interface -> String -> Maybe String -> Maybe String -> HtmlTable -pageHeader mdl iface doctitle source_url maybe_index_url = +pageHeader :: String -> Interface -> String + -> Maybe String -> Maybe String -> Maybe String -> HtmlTable +pageHeader mdl iface doctitle source_url maybe_contents_url maybe_index_url = (tda [theclass "topbar"] << vanillaTable << ( (td << @@ -151,7 +165,7 @@ pageHeader mdl iface doctitle source_url maybe_index_url = (tda [theclass "title"] << toHtml doctitle) <-> src_button source_url mdl (iface_filename iface) <-> parent_button mdl <-> - contentsButton <-> + contentsButton maybe_contents_url <-> indexButton maybe_index_url ) ) @@ -179,16 +193,20 @@ moduleInfo iface = -- --------------------------------------------------------------------------- -- Generate the module contents -ppHtmlContents :: FilePath -> String -> Maybe String -> [Module] -> Maybe Doc +ppHtmlContents + :: FilePath -> String + -> Maybe String + -> [Module] -> Maybe Doc -> IO () -ppHtmlContents odir doctitle maybe_index_url mdls prologue = do +ppHtmlContents odir doctitle maybe_index_url + mdls prologue = do let tree = mkModuleTree mdls html = header (thetitle (toHtml doctitle) +++ thelink ! [href cssFile, rel "stylesheet", thetype "text/css"]) +++ body << vanillaTable << ( - simpleHeader doctitle maybe_index_url + simpleHeader doctitle Nothing maybe_index_url ppPrologue prologue ppModuleTree doctitle tree s15 @@ -218,7 +236,7 @@ mkNode ss (Node s leaf ts) = mkLeaf :: String -> [String] -> Bool -> Html mkLeaf s _ False = toHtml s -mkLeaf s ss True = anchor ! [href (moduleHtmlFile "" mdl)] << toHtml s +mkLeaf s ss True = ppHsModule mdl where mdl = foldr (++) "" (s' : map ('.':) ss') (s':ss') = reverse (s:ss) -- reconstruct the module name @@ -226,14 +244,15 @@ mkLeaf s ss True = anchor ! [href (moduleHtmlFile "" mdl)] << toHtml s -- --------------------------------------------------------------------------- -- Generate the index -ppHtmlIndex :: FilePath -> String -> [(Module,Interface)] -> IO () -ppHtmlIndex odir doctitle ifaces = do +ppHtmlIndex :: FilePath -> String -> Maybe String + -> [(Module,Interface)] -> IO () +ppHtmlIndex odir doctitle maybe_contents_url ifaces = do let html = header (thetitle (toHtml (doctitle ++ " (Index)")) +++ thelink ! [href cssFile, rel "stylesheet", thetype "text/css"]) +++ body << vanillaTable << ( - simpleHeader doctitle Nothing + simpleHeader doctitle maybe_contents_url Nothing index_html ) @@ -270,7 +289,7 @@ ppHtmlIndex odir doctitle ifaces = do thelink ! [href cssFile, rel "stylesheet", thetype "text/css"]) +++ body << vanillaTable << ( - simpleHeader doctitle Nothing + simpleHeader doctitle maybe_contents_url Nothing indexInitialLetterLinks tda [theclass "section1"] << toHtml ("Index (" ++ c:")") @@ -337,15 +356,18 @@ ppHtmlIndex odir doctitle ifaces = do -- --------------------------------------------------------------------------- -- Generate the HTML page for a module -ppHtmlModule :: FilePath -> String -> Maybe String -> Maybe String -> - (Module,Interface) -> IO () -ppHtmlModule odir doctitle source_url maybe_index_url (Module mdl,iface) = do +ppHtmlModule + :: FilePath -> String -> Maybe String -> Maybe String -> Maybe String + -> (Module,Interface) -> IO () +ppHtmlModule odir doctitle source_url + maybe_contents_url maybe_index_url (Module mdl,iface) = do let html = header (thetitle (toHtml mdl) +++ thelink ! [href cssFile, rel "stylesheet", thetype "text/css"]) +++ body << vanillaTable << ( - pageHeader mdl iface doctitle source_url maybe_index_url s15 + pageHeader mdl iface doctitle source_url + maybe_contents_url maybe_index_url s15 ifaceToHtml mdl iface s15 footer ) @@ -917,11 +939,14 @@ htmlMarkup = Markup { markupMonospaced = tt . toHtml, markupUnorderedList = ulist . concatHtml . map (li <<), markupOrderedList = olist . concatHtml . map (li <<), + markupDefList = dlist . concatHtml . map markupDef, markupCodeBlock = pre, markupURL = \url -> anchor ! [href url] << toHtml url, markupAName = \aname -> namedAnchor aname << toHtml "" } +markupDef (a,b) = dterm << a +++ ddef << b + -- If the doc is a single paragraph, don't surround it with

(this causes -- ugly extra whitespace with some browsers). docToHtml :: Doc -> Html diff --git a/src/HaddockLex.x b/src/HaddockLex.x index feac18ab..b4030700 100644 --- a/src/HaddockLex.x +++ b/src/HaddockLex.x @@ -14,7 +14,7 @@ import Char import HsSyn import HsLexer hiding (Token) import HsParseMonad -import Debug.Trace +--import Debug.Trace } $ws = $white # \n @@ -29,8 +29,9 @@ $ident = [$alphanum \_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~] <0,para> { $ws* \n ; $ws* \> { begin birdtrack } - $ws* [\*\-] { token TokBullet } - $ws* \( $digit+ \) { token TokNumber } + $ws* [\*\-] { token TokBullet `andBegin` string } + $ws* \[ { token TokDefStart `andBegin` def } + $ws* \( $digit+ \) { token TokNumber `andBegin` string } $ws* { begin string } } @@ -43,7 +44,7 @@ $ident = [$alphanum \_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~] .* \n? { strtoken TokBirdTrack `andBegin` line } - { + { $special { strtoken $ \s -> TokSpecial (head s) } \<.*\> { strtoken $ \s -> TokURL (init (tail s)) } \#.*\# { strtoken $ \s -> TokAName (init (tail s)) } @@ -52,8 +53,18 @@ $ident = [$alphanum \_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~] -- allow special characters through if they don't fit one of the previous -- patterns. [\'\`\<\#\\] { strtoken TokString } - [^ $special \< \# \n \'\` \\]* \n { strtoken TokString `andBegin` line } - [^ $special \< \# \n \'\` \\]+ { strtoken TokString } + [^ $special \< \# \n \'\` \\ \]]* \n { strtoken TokString `andBegin` line } + [^ $special \< \# \n \'\` \\ \]]+ { strtoken TokString } +} + + { + \] { token TokDefEnd `andBegin` string } +} + +-- ']' doesn't have any special meaning outside of the [...] at the beginning +-- of a definition paragraph. + { + \] { strtoken TokString } } { @@ -61,6 +72,8 @@ data Token = TokPara | TokNumber | TokBullet + | TokDefStart + | TokDefEnd | TokSpecial Char | TokIdent [HsQName] | TokString String diff --git a/src/HaddockParse.y b/src/HaddockParse.y index 29b3b70a..dbc97446 100644 --- a/src/HaddockParse.y +++ b/src/HaddockParse.y @@ -9,10 +9,12 @@ import HsSyn %token '/' { TokSpecial '/' } '@' { TokSpecial '@' } + '[' { TokDefStart } + ']' { TokDefEnd } DQUO { TokSpecial '\"' } URL { TokURL $$ } ANAME { TokAName $$ } - '*' { TokBullet } + '-' { TokBullet } '(n)' { TokNumber } '>..' { TokBirdTrack $$ } IDENT { TokIdent $$ } @@ -35,14 +37,18 @@ doc :: { Doc } apara :: { Doc } : ulpara { DocUnorderedList [$1] } | olpara { DocOrderedList [$1] } + | defpara { DocDefList [$1] } | para { $1 } ulpara :: { Doc } - : '*' para { $2 } + : '-' para { $2 } olpara :: { Doc } : '(n)' para { $2 } +defpara :: { (Doc,Doc) } + : '[' seq ']' seq { ($2, $4) } + para :: { Doc } : seq { docParagraph $1 } | codepara { DocCodeBlock $1 } diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs index ef32ae80..ad90c1a2 100644 --- a/src/HaddockRename.hs +++ b/src/HaddockRename.hs @@ -213,11 +213,14 @@ markupRename = Markup { markupMonospaced = liftM DocMonospaced, markupUnorderedList = liftM DocUnorderedList . sequence, markupOrderedList = liftM DocOrderedList . sequence, + markupDefList = liftM DocDefList . mapM markupDef, markupCodeBlock = liftM DocCodeBlock, markupURL = return . DocURL, markupAName = return . DocAName } +markupDef (ma,mb) = do a <- ma; b <- mb; return (a,b) + renameDoc :: Doc -> RnM Doc renameDoc = markup markupRename diff --git a/src/HsSyn.lhs b/src/HsSyn.lhs index 139ef327..e43826a0 100644 --- a/src/HsSyn.lhs +++ b/src/HsSyn.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: HsSyn.lhs,v 1.18 2003/10/20 17:19:23 sof Exp $ +% $Id: HsSyn.lhs,v 1.19 2003/11/06 12:39:47 simonmar Exp $ % % (c) The GHC Team, 1997-2002 % @@ -400,6 +400,7 @@ data GenDoc id | DocMonospaced (GenDoc id) | DocUnorderedList [GenDoc id] | DocOrderedList [GenDoc id] + | DocDefList [(GenDoc id, GenDoc id)] | DocCodeBlock (GenDoc id) | DocURL String | DocAName String @@ -422,6 +423,7 @@ data DocMarkup id a = Markup { markupMonospaced :: a -> a, markupUnorderedList :: [a] -> a, markupOrderedList :: [a] -> a, + markupDefList :: [(a,a)] -> a, markupCodeBlock :: a -> a, markupURL :: String -> a, markupAName :: String -> a @@ -438,10 +440,13 @@ markup m (DocEmphasis d) = markupEmphasis m (markup m d) markup m (DocMonospaced d) = markupMonospaced m (markup m d) markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) +markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) markup m (DocURL url) = markupURL m url markup m (DocAName ref) = markupAName m ref +markupPair m (a,b) = (markup m a, markup m b) + -- | The identity markup idMarkup :: DocMarkup a (GenDoc a) idMarkup = Markup { @@ -455,6 +460,7 @@ idMarkup = Markup { markupMonospaced = DocMonospaced, markupUnorderedList = DocUnorderedList, markupOrderedList = DocOrderedList, + markupDefList = DocDefList, markupCodeBlock = DocCodeBlock, markupURL = DocURL, markupAName = DocAName @@ -479,6 +485,10 @@ docAppend (DocOrderedList ds1) (DocOrderedList ds2) = DocOrderedList (ds1++ds2) docAppend (DocOrderedList ds1) (DocAppend (DocOrderedList ds2) d) = DocAppend (DocOrderedList (ds1++ds2)) d +docAppend (DocDefList ds1) (DocDefList ds2) + = DocDefList (ds1++ds2) +docAppend (DocDefList ds1) (DocAppend (DocDefList ds2) d) + = DocAppend (DocDefList (ds1++ds2)) d docAppend DocEmpty d = d docAppend d DocEmpty = d docAppend d1 d2 diff --git a/src/Main.hs b/src/Main.hs index 25d6cc16..3d5f97b4 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -80,6 +80,8 @@ data Flag | Flag_Help | Flag_Verbose | Flag_Version + | Flag_UseContents String + | Flag_GenContents | Flag_UseIndex String | Flag_GenIndex deriving (Eq) @@ -119,6 +121,10 @@ options = "output version information and exit", Option ['v'] ["verbose"] (NoArg Flag_Verbose) "increase verbosity", + Option [] ["use-contents"] (ReqArg Flag_UseContents "URL") + "use a separately-generated HTML contents page", + Option [] ["gen-contents"] (NoArg Flag_GenContents) + "generate an HTML contents from specified interfaces", Option [] ["use-index"] (ReqArg Flag_UseIndex "URL") "use a separately-generated HTML index", Option [] ["gen-index"] (NoArg Flag_GenIndex) @@ -167,6 +173,11 @@ run flags files = do no_implicit_prelude = Flag_NoImplicitPrelude `elem` flags verbose = Flag_Verbose `elem` flags + maybe_contents_url = + case [url | Flag_UseContents url <- flags] of + [] -> Nothing + us -> Just (last us) + maybe_index_url = case [url | Flag_UseIndex url <- flags] of [] -> Nothing @@ -178,15 +189,17 @@ run flags files = do updateHTMLXRefs (map fst ifaces_to_read) read_ifaces_s - if Flag_GenIndex `elem` flags - then do - when (not (null files)) $ - die ("--gen-index: expected no additional file arguments") - ppHtmlIndex odir title (concat read_ifaces_s) + writeIORef saved_flags flags + + when (Flag_GenContents `elem` flags) $ do + ppHtmlContents odir title maybe_index_url + (map fst (concat read_ifaces_s)) prologue + copyHtmlBits odir libdir css_file + + when (Flag_GenIndex `elem` flags) $ do + ppHtmlIndex odir title maybe_contents_url (concat read_ifaces_s) copyHtmlBits odir libdir css_file - else do - writeIORef saved_flags flags parsed_mods <- mapM parse_file files let read_ifaces = concat read_ifaces_s @@ -225,7 +238,8 @@ run flags files = do when (Flag_Html `elem` flags) $ do ppHtml title source_url these_mod_ifaces odir - prologue (Flag_MSHtmlHelp `elem` flags) maybe_index_url + prologue (Flag_MSHtmlHelp `elem` flags) + maybe_contents_url maybe_index_url copyHtmlBits odir libdir css_file -- dump an interface if requested -- cgit v1.2.3