aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/HaddockHH.hs7
-rw-r--r--src/HaddockHH2.hs33
-rw-r--r--src/HaddockHtml.hs185
-rw-r--r--src/Main.hs17
4 files changed, 157 insertions, 85 deletions
diff --git a/src/HaddockHH.hs b/src/HaddockHH.hs
index 77d97bca..26269919 100644
--- a/src/HaddockHH.hs
+++ b/src/HaddockHH.hs
@@ -18,10 +18,9 @@ contentsHHFile, indexHHFile :: String
contentsHHFile = "index.hhc"
indexHHFile = "index.hhk"
-ppHHContents :: FilePath -> [(Module,Interface)] -> IO ()
-ppHHContents odir ifaces = do
- let tree = mkModuleTree (map (\(mod,_) -> (mod,Nothing)) ifaces) --TODO: packages
- html =
+ppHHContents :: FilePath -> [ModuleTree] -> IO ()
+ppHHContents odir tree = do
+ let html =
text "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">" $$
text "<HTML>" $$
text "<HEAD>" $$
diff --git a/src/HaddockHH2.hs b/src/HaddockHH2.hs
index 2fb673b9..df739384 100644
--- a/src/HaddockHH2.hs
+++ b/src/HaddockHH2.hs
@@ -12,16 +12,16 @@ import Data.List
import Data.Char
#endif
+import Maybe ( fromMaybe )
import HaddockModuleTree
import HaddockUtil
import HaddockTypes
-ppHH2Contents :: FilePath -> String -> [(Module,Interface)] -> IO ()
-ppHH2Contents odir package ifaces = do
+ppHH2Contents :: FilePath -> Maybe String -> [ModuleTree] -> IO ()
+ppHH2Contents odir maybe_package tree = do
let
contentsHH2File = package++".HxT"
- tree = mkModuleTree (map (\(mod,_) -> (mod,Nothing)) ifaces) --TODO: packages
doc =
text "<?xml version=\"1.0\"?>" $$
text "<!DOCTYPE HelpTOC SYSTEM \"ms-help://hx/resources/HelpTOC.DTD\">" $$
@@ -30,6 +30,8 @@ ppHH2Contents odir package ifaces = do
text "</HelpTOC>"
writeFile (odir ++ pathSeparator:contentsHH2File) (render doc)
where
+ package = fromMaybe "pkg" maybe_package
+
ppModuleTree :: [String] -> [ModuleTree] -> Doc
ppModuleTree ss [x] = ppNode ss x
ppModuleTree ss (x:xs) = ppNode ss x $$ ppModuleTree ss xs
@@ -59,8 +61,8 @@ ppHH2Contents odir package ifaces = do
-----------------------------------------------------------------------------------
-ppHH2Index :: FilePath -> String -> [(Module,Interface)] -> IO ()
-ppHH2Index odir package ifaces = do
+ppHH2Index :: FilePath -> Maybe String -> [(Module,Interface)] -> IO ()
+ppHH2Index odir maybe_package ifaces = do
let
indexKHH2File = package++"K.HxK"
indexNHH2File = package++"N.HxK"
@@ -80,7 +82,9 @@ ppHH2Index odir package ifaces = do
text "</HelpIndex>"
writeFile (odir ++ pathSeparator:indexKHH2File) (render docK)
writeFile (odir ++ pathSeparator:indexNHH2File) (render docN)
- where
+ where
+ package = fromMaybe "pkg" maybe_package
+
index :: [(HsName, [Module])]
index = fmToList (foldr getIfaceIndex emptyFM ifaces)
@@ -103,8 +107,8 @@ ppHH2Index odir package ifaces = do
-----------------------------------------------------------------------------------
-ppHH2Files :: FilePath -> String -> [(Module,Interface)] -> IO ()
-ppHH2Files odir package ifaces = do
+ppHH2Files :: FilePath -> Maybe String -> [(Module,Interface)] -> IO ()
+ppHH2Files odir maybe_package ifaces = do
let filesHH2File = package++".HxF"
doc =
text "<?xml version=\"1.0\"?>" $$
@@ -114,14 +118,16 @@ ppHH2Files odir package ifaces = do
text "<File Url=\""<>text contentsHtmlFile<>text "\"/>" $$
text "<File Url=\""<>text indexHtmlFile<>text "\"/>" $$
ppIndexFiles chars $$
- text "<File Url=\""<>text cssFile <>text "\"/>") $$
+ text "<File Url=\""<>text cssFile <>text "\"/>" $$
text "<File Url=\""<>text iconFile <>text "\"/>" $$
text "<File Url=\""<>text jsFile <>text "\"/>" $$
text "<File Url=\""<>text plusFile <>text "\"/>" $$
- text "<File Url=\""<>text minusFile<>text "\"/>" $$
+ text "<File Url=\""<>text minusFile<>text "\"/>") $$
text "</HelpFileList>"
writeFile (odir ++ pathSeparator:filesHH2File) (render doc)
where
+ package = fromMaybe "pkg" maybe_package
+
ppMods [] = empty
ppMods ((Module mdl,_):ifaces) =
text "<File Url=\"" <> text (moduleHtmlFile "" mdl) <> text "\"/>" $$
@@ -140,15 +146,16 @@ ppHH2Files odir package ifaces = do
-----------------------------------------------------------------------------------
-ppHH2Collection :: FilePath -> String -> [(Module,Interface)] -> IO ()
-ppHH2Collection odir package ifaces = do
+ppHH2Collection :: FilePath -> String -> Maybe String -> IO ()
+ppHH2Collection odir doctitle maybe_package = do
let
+ package = fromMaybe "pkg" maybe_package
collectionHH2File = package++".HxC"
doc =
text "<?xml version=\"1.0\"?>" $$
text "<!DOCTYPE HelpCollection SYSTEM \"ms-help://hx/resources/HelpCollection.DTD\">" $$
- text "<HelpCollection DTDVersion=\"1.0\" LangId=\"1033\" Title=\"" <> text package <> text "\">" $$
+ text "<HelpCollection DTDVersion=\"1.0\" LangId=\"1033\" Title=\"" <> text doctitle <> text "\">" $$
nest 4 (text "<CompilerOptions CreateFullTextIndex=\"Yes\">" $$
nest 4 (text "<IncludeFile File=\"" <> text package <> text ".HxF\"/>") $$
text "</CompilerOptions>" $$
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 523f65b5..3233c408 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -6,7 +6,8 @@
module HaddockHtml (
ppHtml, copyHtmlBits,
- ppHtmlIndex, ppHtmlContents
+ ppHtmlIndex, ppHtmlContents,
+ ppHtmlHelpFiles
) where
import Prelude hiding (div)
@@ -18,12 +19,15 @@ import HaddockHH
import HaddockHH2
import HsSyn
-import IO
-import Maybe ( fromJust, isJust, fromMaybe )
+import Maybe ( fromJust, isJust )
import List ( sortBy )
import Char ( isUpper, toUpper )
import Monad ( when, unless )
+import Foreign
+import Control.Exception ( handle, bracket )
+import System.IO
+
#if __GLASGOW_HASKELL__ < 503
import FiniteMap
#else
@@ -47,38 +51,61 @@ ppHtml :: String
-> Maybe String -- the index URL (--use-index)
-> IO ()
-ppHtml doctitle package source_url ifaces odir prologue maybe_html_help_format
+ppHtml doctitle maybe_package source_url ifaces odir prologue maybe_html_help_format
maybe_contents_url maybe_index_url = do
let
visible_ifaces = filter visible ifaces
visible (_, i) = OptHide `notElem` iface_options i
when (not (isJust maybe_contents_url)) $
- ppHtmlContents odir doctitle maybe_index_url
+ ppHtmlContents odir doctitle maybe_package maybe_html_help_format maybe_index_url
[ (m,iface{iface_package=Nothing}) | (m,iface) <- visible_ifaces ]
-- we don't want to display the packages in a single-package contents
prologue
when (not (isJust maybe_index_url)) $
- ppHtmlIndex odir doctitle maybe_contents_url visible_ifaces
+ 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
+
+ mapM_ (ppHtmlModule odir doctitle source_url
+ maybe_contents_url maybe_index_url) visible_ifaces
+
+ppHtmlHelpFiles
+ :: String -- doctitle
+ -> Maybe String -- package
+ -> [(Module, Interface)]
+ -> FilePath -- destination directory
+ -> Maybe String -- the Html Help format (--html-help)
+ -> IO ()
+ppHtmlHelpFiles doctitle maybe_package ifaces odir maybe_html_help_format = 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
- Nothing -> return ()
- Just "mshelp" -> do
- ppHHContents odir visible_ifaces
- ppHHIndex odir visible_ifaces
Just "mshelp2" -> do
- let pkg_name = fromMaybe "pkg" package
- ppHH2Contents odir pkg_name visible_ifaces
- ppHH2Index odir pkg_name visible_ifaces
- ppHH2Files odir pkg_name visible_ifaces
- ppHH2Collection odir pkg_name visible_ifaces
- Just format -> do
- fail ("The "++format++" format is not implemented")
-
- mapM_ (ppHtmlModule odir doctitle source_url
- maybe_contents_url maybe_index_url) visible_ifaces
+ ppHH2Files odir maybe_package visible_ifaces
+ ppHH2Collection odir doctitle maybe_package
+ _ -> return ()
+
+
+copyFile :: FilePath -> FilePath -> IO ()
+copyFile fromFPath toFPath =
+ (bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
+ bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo ->
+ allocaBytes bufferSize $ \buffer ->
+ copyContents hFrom hTo buffer)
+ where
+ bufferSize = 1024
+
+ copyContents hFrom hTo buffer = do
+ count <- hGetBuf hFrom buffer bufferSize
+ when (count > 0) $ do
+ hPutBuf hTo buffer count
+ copyContents hFrom hTo buffer
copyHtmlBits :: FilePath -> FilePath -> Maybe FilePath -> IO ()
@@ -88,14 +115,11 @@ copyHtmlBits odir libdir maybe_css = do
Nothing -> libdir ++ pathSeparator:cssFile
Just f -> f
css_destination = odir ++ pathSeparator:cssFile
-
- copyFile f = do
- s <- readFile (libdir ++ pathSeparator:f)
- writeFile (odir ++ pathSeparator:f) s
-
- css_contents <- readFile css_file
- writeFile css_destination css_contents
- mapM_ copyFile [ iconFile, plusFile, minusFile, jsFile ]
+ copyLibFile f = do
+ copyFile (libdir ++ pathSeparator:f) (odir ++ pathSeparator:f)
+
+ copyFile css_file css_destination
+ mapM_ copyLibFile [ iconFile, plusFile, minusFile, jsFile ]
footer :: HtmlTable
footer =
@@ -179,17 +203,21 @@ moduleInfo iface =
-- Generate the module contents
ppHtmlContents
- :: FilePath -> String
+ :: FilePath
+ -> String
+ -> Maybe String
+ -> Maybe String
-> Maybe String
-> [(Module,Interface)] -> Maybe Doc
-> IO ()
-ppHtmlContents odir doctitle maybe_index_url
+ppHtmlContents odir doctitle maybe_package maybe_html_help_format maybe_index_url
mdls prologue = do
let tree = mkModuleTree [(mod,iface_package iface) | (mod,iface) <- mdls]
html =
- header (thetitle (toHtml doctitle) +++
- thelink ! [href cssFile,
- rel "stylesheet", thetype "text/css"]) +++
+ header
+ ((thetitle (toHtml doctitle)) +++
+ (thelink ! [href cssFile, rel "stylesheet", thetype "text/css"]) +++
+ (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++
body << vanillaTable << (
simpleHeader doctitle Nothing maybe_index_url </>
ppPrologue doctitle prologue </>
@@ -198,6 +226,13 @@ ppHtmlContents odir doctitle maybe_index_url
footer
)
writeFile (odir ++ pathSeparator:contentsHtmlFile) (renderHtml html False)
+
+ -- Generate contents page for Html Help if requested
+ case maybe_html_help_format of
+ Nothing -> return ()
+ Just "mshelp" -> ppHHContents odir tree
+ Just "mshelp2" -> ppHH2Contents odir maybe_package tree
+ Just format -> fail ("The "++format++" format is not implemented")
ppPrologue :: String -> Maybe Doc -> HtmlTable
ppPrologue title Nothing = Html.emptyTable
@@ -208,41 +243,61 @@ ppPrologue title (Just doc) =
ppModuleTree :: String -> [ModuleTree] -> HtmlTable
ppModuleTree _ ts =
tda [theclass "section1"] << toHtml "Modules" </>
- td << table ! [cellpadding 0, cellspacing 2] <<
- (aboves (map (mkNode 0 []) ts) <-> mkPackages ts)
-
-mkNode :: Int -> [String] -> ModuleTree -> HtmlTable
-mkNode n ss (Node s leaf pkg []) =
- mkLeaf n s ss leaf
-mkNode n ss (Node s leaf pkg ts) =
- mkLeaf n s ss leaf
- </>
- aboves (map (mkNode (n+1) (s:ss)) ts)
-
-mkLeaf :: Int -> String -> [String] -> Bool -> HtmlTable
-mkLeaf n s _ False = pad_td n << toHtml s
-mkLeaf n s ss True = pad_td n << ppHsModule mdl
- where mdl = foldr (++) "" (s' : map ('.':) ss')
- (s':ss') = reverse (s:ss)
- -- reconstruct the module name
+ td << table ! [cellpadding 0, cellspacing 2] << htmlTable
+ where
+ genTable htmlTable id [] = (htmlTable,id)
+ genTable htmlTable id (x:xs) = genTable (htmlTable </> u) id' xs
+ where
+ (u,id') = mkNode [] x id
-pad_td 0 = td
-pad_td n = tda [thestyle ("padding-left:" ++ show (n*20) ++ "px")]
+ (htmlTable,_) = genTable emptyTable 0 ts
-mkPackages :: [ModuleTree] -> HtmlTable
-mkPackages ts = aboves (map go ts)
- where go (Node s leaf pkg ts) = tda [theclass "pkg"] << mkPkg pkg </> aboves (map go ts)
+mkNode :: [String] -> ModuleTree -> Int -> (HtmlTable,Int)
+mkNode ss (Node s leaf pkg ts) id = htmlNode
+ where
+ htmlNode = case ts of
+ [] -> ( pad_td 15 << htmlModule <-> htmlPkg,id)
+ _ -> ((pad_td 0 << (collapsebutton id_s +++ htmlModule) <-> htmlPkg) </>
+ (pad_td 20 << sub_tree), id')
+
+ htmlModule
+ | leaf = ppHsModule mdl
+ | otherwise = toHtml s
-mkPkg :: Maybe String -> Html
-mkPkg Nothing = empty
-mkPkg (Just p) = toHtml p
+ htmlPkg = case pkg of
+ Nothing -> td << empty
+ Just p -> td << toHtml p
+
+ mdl = foldr (++) "" (s' : map ('.':) ss')
+ (s':ss') = reverse (s:ss)
+ -- reconstruct the module name
+
+ id_s = show id
+
+ (sub_tree,id') = genSubTree emptyTable (id+1) ts
+
+ genSubTree :: HtmlTable -> Int -> [ModuleTree] -> (Html,Int)
+ genSubTree htmlTable id [] = (sub_tree,id)
+ where
+ sub_tree = table ! [identifier id_s, thestyle "display:none;", cellpadding 0, cellspacing 0, width "100%"] << htmlTable
+ genSubTree htmlTable id (x:xs) = genSubTree (htmlTable </> u) id' xs
+ where
+ (u,id') = mkNode (s:ss) x id
+
+ pad_td 0 = tda [width "100%"]
+ pad_td n = tda [thestyle ("padding-left:" ++ show n ++ "px"), width "100%"]
-- ---------------------------------------------------------------------------
-- Generate the index
-ppHtmlIndex :: FilePath -> String -> Maybe String
- -> [(Module,Interface)] -> IO ()
-ppHtmlIndex odir doctitle maybe_contents_url ifaces = do
+ppHtmlIndex :: FilePath
+ -> String
+ -> Maybe String
+ -> Maybe String
+ -> Maybe String
+ -> [(Module,Interface)]
+ -> IO ()
+ppHtmlIndex odir doctitle maybe_package maybe_html_help_format maybe_contents_url ifaces = do
let html =
header (thetitle (toHtml (doctitle ++ " (Index)")) +++
thelink ! [href cssFile,
@@ -256,7 +311,13 @@ ppHtmlIndex odir doctitle maybe_contents_url ifaces = do
mapM_ (do_sub_index index) initialChars
writeFile (odir ++ pathSeparator:indexHtmlFile) (renderHtml html False)
-
+
+ -- Generate index and contents page for Html Help if requested
+ case maybe_html_help_format of
+ Nothing -> return ()
+ Just "mshelp" -> ppHHIndex odir ifaces
+ Just "mshelp2" -> ppHH2Index odir maybe_package ifaces
+ Just format -> fail ("The "++format++" format is not implemented")
where
split_indices = length index > 50
diff --git a/src/Main.hs b/src/Main.hs
index 1070538b..11ce079d 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -195,6 +195,11 @@ run flags files = do
[] -> Nothing
us -> Just (last us)
+ maybe_html_help_format =
+ case [hhformat | Flag_HtmlHelp hhformat <- flags] of
+ [] -> Nothing
+ formats -> Just (last formats)
+
prologue <- getPrologue flags
read_ifaces_s <- mapM readIface (map snd ifaces_to_read)
@@ -213,12 +218,15 @@ run flags files = do
die ("-h cannot be used with --gen-index or --gen-contents")
when (Flag_GenContents `elem` flags) $ do
- ppHtmlContents odir title maybe_index_url visible_read_ifaces prologue
+ ppHtmlContents odir title package maybe_html_help_format maybe_index_url visible_read_ifaces prologue
copyHtmlBits odir libdir css_file
when (Flag_GenIndex `elem` flags) $ do
- ppHtmlIndex odir title maybe_contents_url visible_read_ifaces
+ ppHtmlIndex odir title package maybe_html_help_format maybe_contents_url visible_read_ifaces
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
parsed_mods <- mapM parse_file files
@@ -255,11 +263,8 @@ run flags files = do
| (mdl, i) <- these_mod_ifaces ])
when (Flag_Html `elem` flags) $ do
- let hhformat = case [hhformat | Flag_HtmlHelp hhformat <- flags] of
- [] -> Nothing
- formats -> Just (last formats)
ppHtml title package source_url these_mod_ifaces odir
- prologue hhformat
+ prologue maybe_html_help_format
maybe_contents_url maybe_index_url
copyHtmlBits odir libdir css_file
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 08:45:48 +0000