From fd7cc6bc85c5d3b016b3554d03957d14dce3c6d2 Mon Sep 17 00:00:00 2001 From: krasimir Date: Sun, 1 Aug 2004 19:52:08 +0000 Subject: [haddock @ 2004-08-01 19:52:06 by krasimir] fix some bugs. Now I have got the entire libraries documentation in HtmlHelp 2.0 format. --- src/HaddockDevHelp.hs | 4 ++-- src/HaddockHH.hs | 29 +++++++++++++++++++---------- src/HaddockHH2.hs | 35 ++++++++++++++++++++--------------- src/HaddockHtml.hs | 25 +++++++++++-------------- src/HaddockUtil.hs | 14 ++++++++------ src/Main.hs | 10 +++------- 6 files changed, 63 insertions(+), 54 deletions(-) (limited to 'src') diff --git a/src/HaddockDevHelp.hs b/src/HaddockDevHelp.hs index 95987230..3ebfc1c3 100644 --- a/src/HaddockDevHelp.hs +++ b/src/HaddockDevHelp.hs @@ -50,7 +50,7 @@ ppDevHelpFile odir doctitle maybe_package ifaces = do nest 4 (ppModuleTree (s:ss) ts) $+$ text "" where - ppLink | leaf = text (moduleHtmlFile "" mdl) + ppLink | leaf = text (moduleHtmlFile mdl) | otherwise = empty ppAttribs = text "name="<>doubleQuotes (text s)<+>text "link="<>doubleQuotes ppLink @@ -72,5 +72,5 @@ ppDevHelpFile odir doctitle maybe_package ifaces = do ppReference name [] = empty ppReference name (Module mdl:refs) = - text "text (escapeStr (show name))<>text"\" link=\""<>text (nameHtmlRef "" mdl name)<>text"\"/>" $$ + text "text (escapeStr (show name))<>text"\" link=\""<>text (nameHtmlRef mdl name)<>text"\"/>" $$ ppReference name refs diff --git a/src/HaddockHH.hs b/src/HaddockHH.hs index 98dac72a..6a41f738 100644 --- a/src/HaddockHH.hs +++ b/src/HaddockHH.hs @@ -61,7 +61,7 @@ ppHHContents odir maybe_package tree = do text "
  • " <> nest 4 (text "" $$ text " text s <> text "\">" $$ - (if isleaf then text " text (moduleHtmlFile "" mdl) <> text "\">" else empty) $$ + (if isleaf then text " text (moduleHtmlFile mdl) <> text "\">" else empty) $$ text "") $+$ text "
    • " where @@ -107,12 +107,12 @@ ppHHIndex odir maybe_package ifaces = do ppReference name [] = empty ppReference name (Module mdl:refs) = - text " text (nameHtmlRef "" mdl name) <> text "\">" $$ + text " text (nameHtmlRef mdl name) <> text "\">" $$ ppReference name refs -ppHHProject :: FilePath -> String -> Maybe String -> [(Module,Interface)] -> IO () -ppHHProject odir doctitle maybe_package ifaces = do +ppHHProject :: FilePath -> String -> Maybe String -> [(Module,Interface)] -> [FilePath] -> IO () +ppHHProject odir doctitle maybe_package ifaces pkg_paths = do let projectHHFile = package++".hhp" doc = text "[OPTIONS]" $$ @@ -129,24 +129,33 @@ ppHHProject odir doctitle maybe_package ifaces = do text contentsHtmlFile $$ text indexHtmlFile $$ ppIndexFiles chars $$ - text cssFile $$ - text iconFile $$ - text jsFile $$ - text plusFile $$ - text minusFile + ppLibFiles ("":pkg_paths) writeFile (odir ++ pathSeparator:projectHHFile) (render doc) where package = fromMaybe "pkg" maybe_package ppMods [] = empty ppMods ((Module mdl,_):ifaces) = - text (moduleHtmlFile "" mdl) $$ + text (moduleHtmlFile mdl) $$ ppMods ifaces ppIndexFiles [] = empty ppIndexFiles (c:cs) = text (subIndexHtmlFile c) $$ ppIndexFiles cs + + ppLibFiles [] = empty + ppLibFiles (path:paths) = + ppLibFile cssFile $$ + ppLibFile iconFile $$ + ppLibFile jsFile $$ + ppLibFile plusFile $$ + ppLibFile minusFile $$ + ppLibFiles paths + where + toPath fname | null path = fname + | otherwise = path++pathSeparator:fname + ppLibFile fname = text (toPath fname) chars :: [Char] chars = keysFM (foldr getIfaceIndex emptyFM ifaces) diff --git a/src/HaddockHH2.hs b/src/HaddockHH2.hs index cea0f2e0..ce4d488e 100644 --- a/src/HaddockHH2.hs +++ b/src/HaddockHH2.hs @@ -56,7 +56,7 @@ ppHH2Contents odir maybe_package tree = do ppTitle = text "Title=" <> doubleQuotes (text (head ss)) - ppUrl | isleaf = text " Url=" <> doubleQuotes (text (moduleHtmlFile "" mdl)) + ppUrl | isleaf = text " Url=" <> doubleQuotes (text (moduleHtmlFile mdl)) | otherwise = empty ----------------------------------------------------------------------------------- @@ -98,17 +98,13 @@ ppHH2Index odir maybe_package ifaces = do text "" $$ ppList vs - ppJump name (Module mdl) = text " text (nameHtmlRef fp mdl name) <> text "\"/>" - where - fp = case lookupFM html_xrefs (Module mdl) of - Nothing -> "" - Just fp0 -> fp0 + ppJump name (Module mdl) = text " text (nameHtmlRef mdl name) <> text "\"/>" ----------------------------------------------------------------------------------- -ppHH2Files :: FilePath -> Maybe String -> [(Module,Interface)] -> IO () -ppHH2Files odir maybe_package ifaces = do +ppHH2Files :: FilePath -> Maybe String -> [(Module,Interface)] -> [FilePath] -> IO () +ppHH2Files odir maybe_package ifaces pkg_paths = do let filesHH2File = package++".HxF" doc = text "" $$ @@ -118,11 +114,7 @@ ppHH2Files odir maybe_package ifaces = do text "text contentsHtmlFile<>text "\"/>" $$ text "text indexHtmlFile<>text "\"/>" $$ ppIndexFiles chars $$ - text "text cssFile <>text "\"/>" $$ - text "text iconFile <>text "\"/>" $$ - text "text jsFile <>text "\"/>" $$ - text "text plusFile <>text "\"/>" $$ - text "text minusFile<>text "\"/>") $$ + ppLibFiles ("":pkg_paths)) $$ text "" writeFile (odir ++ pathSeparator:filesHH2File) (render doc) where @@ -130,14 +122,27 @@ ppHH2Files odir maybe_package ifaces = do ppMods [] = empty ppMods ((Module mdl,_):ifaces) = - text " text (moduleHtmlFile "" mdl) <> text "\"/>" $$ + text " text (moduleHtmlFile mdl) <> text "\"/>" $$ ppMods ifaces ppIndexFiles [] = empty ppIndexFiles (c:cs) = text "text (subIndexHtmlFile c)<>text "\"/>" $$ ppIndexFiles cs - + + ppLibFiles [] = empty + ppLibFiles (path:paths) = + ppLibFile cssFile $$ + ppLibFile iconFile $$ + ppLibFile jsFile $$ + ppLibFile plusFile $$ + ppLibFile minusFile $$ + ppLibFiles paths + where + toPath fname | null path = fname + | otherwise = path++pathSeparator:fname + ppLibFile fname = text "text (toPath fname)<>text "\"/>" + chars :: [Char] chars = keysFM (foldr getIfaceIndex emptyFM ifaces) diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs index 2c6fedb9..466fd413 100644 --- a/src/HaddockHtml.hs +++ b/src/HaddockHtml.hs @@ -68,7 +68,7 @@ ppHtml doctitle maybe_package source_url ifaces odir prologue maybe_html_help_fo ppHtmlIndex odir doctitle maybe_package maybe_html_help_format maybe_contents_url visible_ifaces when (not (isJust maybe_contents_url && isJust maybe_index_url)) $ - ppHtmlHelpFiles doctitle maybe_package ifaces odir maybe_html_help_format + ppHtmlHelpFiles doctitle maybe_package ifaces odir maybe_html_help_format [] mapM_ (ppHtmlModule odir doctitle source_url maybe_contents_url maybe_index_url) visible_ifaces @@ -79,17 +79,19 @@ ppHtmlHelpFiles -> [(Module, Interface)] -> FilePath -- destination directory -> Maybe String -- the Html Help format (--html-help) + -> [FilePath] -- external packages paths -> IO () -ppHtmlHelpFiles doctitle maybe_package ifaces odir maybe_html_help_format = do +ppHtmlHelpFiles doctitle maybe_package ifaces odir maybe_html_help_format pkg_paths = do let visible_ifaces = filter visible ifaces visible (_, i) = OptHide `notElem` iface_options i -- Generate index and contents page for Html Help if requested case maybe_html_help_format of - Just "mshelp" -> ppHHProject odir doctitle maybe_package visible_ifaces + Nothing -> return () + Just "mshelp" -> ppHHProject odir doctitle maybe_package visible_ifaces pkg_paths Just "mshelp2" -> do - ppHH2Files odir maybe_package visible_ifaces + ppHH2Files odir maybe_package visible_ifaces pkg_paths ppHH2Collection odir doctitle maybe_package Just "devhelp" -> ppDevHelpFile odir doctitle maybe_package visible_ifaces Just format -> fail ("The "++format++" format is not implemented") @@ -433,7 +435,7 @@ ppHtmlModule odir doctitle source_url ifaceToHtml mdl iface s15 footer ) - writeFile (moduleHtmlFile odir mdl) (renderHtml html False) + writeFile (odir++moduleHtmlFile mdl) (renderHtml html False) ifaceToHtml :: String -> Interface -> HtmlTable ifaceToHtml _ iface @@ -974,17 +976,12 @@ ppHsBindIdent (HsSpecial str) = toHtml str linkId :: Module -> Maybe HsName -> Html -> Html linkId (Module mdl) mbName = anchor ! [href hr] where hr = case mbName of - Nothing -> moduleHtmlFile fp mdl - Just name -> nameHtmlRef fp mdl name - fp = case lookupFM html_xrefs (Module mdl) of - Nothing -> "" - Just fp0 -> fp0 + Nothing -> moduleHtmlFile mdl + Just name -> nameHtmlRef mdl name ppHsModule :: String -> Html -ppHsModule mdl = anchor ! [href ((moduleHtmlFile fp modname) ++ ref)] << toHtml mdl - where fp = case lookupFM html_xrefs (Module modname) of - Just fp0 -> fp0 - Nothing -> "" +ppHsModule mdl = anchor ! [href ((moduleHtmlFile modname) ++ ref)] << toHtml mdl + where (modname,ref) = break (== '#') mdl -- ----------------------------------------------------------------------------- diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs index 03796532..f7dab157 100644 --- a/src/HaddockUtil.hs +++ b/src/HaddockUtil.hs @@ -23,7 +23,7 @@ module HaddockUtil ( getProgramName, bye, die, dieMsg, mapSnd, mapMaybeM, escapeStr, -- * HTML cross reference mapping - html_xrefs_ref, html_xrefs, + html_xrefs_ref, ) where import HsSyn @@ -272,12 +272,14 @@ isPathSeparator ch = ch == '/' #endif -moduleHtmlFile :: FilePath -> String -> FilePath -moduleHtmlFile "" mod0 = mod0 ++ ".html" -- ToDo: Z-encode filename? -moduleHtmlFile dir mod0 = dir ++ pathSeparator : mod0 ++ ".html" +moduleHtmlFile :: String -> FilePath +moduleHtmlFile mdl = + case lookupFM html_xrefs (Module mdl) of + Nothing -> mdl ++ ".html" + Just fp0 -> fp0 ++ pathSeparator : mdl ++ ".html" -nameHtmlRef :: FilePath -> String -> HsName -> String -nameHtmlRef fp mdl str = moduleHtmlFile fp mdl ++ '#':escapeStr (hsAnchorNameStr str) +nameHtmlRef :: String -> HsName -> String +nameHtmlRef mdl str = moduleHtmlFile mdl ++ '#':escapeStr (hsAnchorNameStr str) contentsHtmlFile, indexHtmlFile :: String contentsHtmlFile = "index.html" diff --git a/src/Main.hs b/src/Main.hs index 797d8325..a0126fa3 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -139,9 +139,6 @@ options = "generate an HTML index from specified interfaces" ] -saved_flags :: IORef [Flag] -saved_flags = unsafePerformIO (newIORef (error "no flags yet")) - run :: [Flag] -> [FilePath] -> IO () run flags files = do when (Flag_Help `elem` flags) $ do @@ -211,10 +208,9 @@ run flags files = do visible_read_ifaces = filter ((OptHide `notElem`) . iface_options . snd) read_ifaces external_mods = map fst read_ifaces + pkg_paths = map fst ifaces_to_read - updateHTMLXRefs (map fst ifaces_to_read) read_ifaces_s - - writeIORef saved_flags flags + updateHTMLXRefs pkg_paths read_ifaces_s when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) && Flag_Html `elem` flags) $ @@ -229,7 +225,7 @@ run flags files = do copyHtmlBits odir libdir css_file when (Flag_GenContents `elem` flags && Flag_GenIndex `elem` flags) $ do - ppHtmlHelpFiles title package visible_read_ifaces odir maybe_html_help_format + ppHtmlHelpFiles title package visible_read_ifaces odir maybe_html_help_format pkg_paths parsed_mods <- mapM parse_file files -- cgit v1.2.3