[haddock @ 2004-07-27 22:58:23 by krasimir]

Add basic support for Microsoft HTML Help 2.0
author: krasimir <unknown> 2004-07-27 22:59:35 +0000
committer: krasimir <unknown> 2004-07-27 22:59:35 +0000
commit: f183618bf9c523800ae84d0cb72c65b7ef22aa0b (patch)
tree: 6e2403e95c9517005e8d59ee4ad5be4cec24b7bf /src
parent: 1d7bc432f61f221c16ecf96903a56a7e5724a587 (diff)
6 files changed, 258 insertions, 85 deletions
diff --git a/src/HaddockHH.hs b/src/HaddockHH.hs
index f10c970e..77d97bca 100644
--- a/src/HaddockHH.hs
+++ b/src/HaddockHH.hs
@@ -18,9 +18,9 @@ contentsHHFile, indexHHFile :: String
 contentsHHFile = "index.hhc"
 indexHHFile = "index.hhk"
 
-ppHHContents :: FilePath -> [Module] -> IO ()
-ppHHContents odir mods = do
-  let tree = mkModuleTree (zip mods (repeat Nothing)) --TODO: packages
+ppHHContents :: FilePath -> [(Module,Interface)] -> IO ()
+ppHHContents odir ifaces = do
+  let tree = mkModuleTree (map (\(mod,_) -> (mod,Nothing)) ifaces) --TODO: packages
       html =
       	text "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">" $$
 	text "<HTML>" $$
@@ -83,21 +83,18 @@ ppHHIndex odir ifaces = do
 	text "</BODY><HTML>"
   writeFile (odir ++ pathSeparator:indexHHFile) (render html)
   where	
-	index :: [(HsName, Module)]
-	index = fmToList full_index
+	index :: [(HsName, [Module])]
+	index = fmToList (foldr getIfaceIndex emptyFM ifaces)
 
-	iface_indices = map getIfaceIndex ifaces
-	full_index = foldr1 plusFM iface_indices
-
-	getIfaceIndex (mdl,iface) = listToFM
-	    [ (name, mdl) | (name, Qual mdl' _) <- fmToList (iface_env iface), mdl == mdl']
+	getIfaceIndex (mdl,iface) fm =
+		addListToFM_C (++) fm [(name, [mdl]) | (name, Qual mdl' _) <- fmToList (iface_env iface), mdl == mdl']
 	
 	ppList [] = empty
-	ppList ((name,Module mdl):mdls)  =
+	ppList ((name,(Module mdl:_)):mdls)  =
 		text "<LI>" <> nest 4
 				(text "<OBJECT type=\"text/sitemap\">" $$
 				 text "<PARAM name=\"Name\" value=\"" <> text (show name) <> text "\">" $$
-				 text "<PARAM name=\"Local\" value=\"" <> text (moduleHtmlFile "" mdl) <> char '#' <> text (show name) <> text "\">" $$
+				 text "<PARAM name=\"Local\" value=\"" <> text (nameHtmlRef "" mdl name) <> text "\">" $$
 				 text "</OBJECT>") $+$
 		text "</LI>" $$
 		ppList mdls
diff --git a/src/HaddockHH2.hs b/src/HaddockHH2.hs
new file mode 100644
index 00000000..bb291bd7
--- /dev/null
+++ b/src/HaddockHH2.hs
@@ -0,0 +1,162 @@
+module HaddockHH2(ppHH2Contents, ppHH2Index, ppHH2Files, ppHH2Collection) where
+
+import HsSyn hiding(Doc)
+
+#if __GLASGOW_HASKELL__ < 503
+import Pretty
+import FiniteMap
+#else
+import Text.PrettyPrint
+import Data.FiniteMap
+import Data.List
+import Data.Char
+#endif
+
+import HaddockModuleTree
+import HaddockUtil
+import HaddockTypes
+
+ppHH2Contents :: FilePath -> String -> [(Module,Interface)] -> IO ()
+ppHH2Contents odir package ifaces = 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\">" $$
+		text "<HelpTOC DTDVersion=\"1.0\">" $$
+		nest 4 (ppModuleTree [] tree) $$
+		text "</HelpTOC>"
+  writeFile (odir ++ pathSeparator:contentsHH2File) (render doc)
+  where
+	ppModuleTree :: [String] -> [ModuleTree] -> Doc
+	ppModuleTree ss [x]    = ppNode ss x
+	ppModuleTree ss (x:xs) = ppNode ss x $$ ppModuleTree ss xs
+	ppModuleTree _  []     = error "HaddockHH2.ppHH2Contents.ppModuleTree: no module trees given"
+
+	ppNode :: [String] -> ModuleTree -> Doc
+	ppNode ss (Node s leaf _pkg []) =
+	  text "<HelpTOCNode"  <+> ppAttributes leaf (s:ss) <> text "/>"
+	ppNode ss (Node s leaf _pkg ts) =
+	  text "<HelpTOCNode" <+> ppAttributes leaf (s:ss) <> text ">" $$
+	  nest 4 (ppModuleTree (s:ss) ts) $+$
+	  text "</HelpTOCNode>"
+			
+	ppAttributes :: Bool -> [String] -> Doc
+	ppAttributes isleaf ss = hsep [ppId,ppTitle,ppUrl]
+	  where
+	    mdl = foldr (++) "" (s' : map ('.':) ss')
+	    (s':ss') = reverse ss
+	                -- reconstruct the module name
+	    
+	    ppId = text "Id=" <> doubleQuotes (text mdl)
+	    
+	    ppTitle = text "Title=" <> doubleQuotes (text (head ss))
+	    
+	    ppUrl | isleaf    = text " Url=" <> doubleQuotes (text (moduleHtmlFile "" mdl))
+	          | otherwise = empty
+
+-----------------------------------------------------------------------------------
+
+ppHH2Index :: FilePath -> String -> [(Module,Interface)] -> IO ()
+ppHH2Index odir package ifaces = do
+  let 
+	indexKHH2File     = package++"K.HxK"
+	indexNHH2File     = package++"N.HxK"
+	docK = 
+		text "<?xml version=\"1.0\"?>" $$
+		text "<!DOCTYPE HelpIndex SYSTEM \"ms-help://hx/resources/HelpIndex.DTD\">" $$
+		text "<HelpIndex DTDVersion=\"1.0\" Name=\"K\">" $$
+		nest 4 (ppList index) $+$
+		text "</HelpIndex>"  
+	docN = 
+		text "<?xml version=\"1.0\"?>" $$
+		text "<!DOCTYPE HelpIndex SYSTEM \"ms-help://hx/resources/HelpIndex.DTD\">" $$
+		text "<HelpIndex DTDVersion=\"1.0\" Name=\"NamedURLIndex\">" $$
+		text "<Keyword Term=\"HomePage\">" $$
+		nest 4 (text "<Jump Url=\"index.html\"/>") $$
+		text "</Keyword>" $$
+		text "</HelpIndex>"
+  writeFile (odir ++ pathSeparator:indexKHH2File) (render docK)
+  writeFile (odir ++ pathSeparator:indexNHH2File) (render docN)
+  where	
+	index :: [(HsName, [Module])]
+	index = fmToList (foldr getIfaceIndex emptyFM ifaces)
+
+	getIfaceIndex (mdl,iface) fm =
+	    addListToFM_C (++) fm [(name, [mdl]) | (name, Qual mdl' _) <- fmToList (iface_env iface), mdl == mdl']
+	
+	ppList [] = empty
+	ppList ((name,mdls):vs)  =
+		text "<Keyword Term=\"" <> text (show name) <> text "\">" $$
+		nest 4 (vcat (map (ppJump name) mdls)) $$
+		text "</Keyword>" $$
+		ppList vs
+
+	ppJump name (Module mdl) = text "<Jump Url=\"" <> text (nameHtmlRef fp mdl name) <> text "\"/>"
+	  where
+	    fp = case lookupFM html_xrefs (Module mdl) of
+	      Nothing  -> ""
+	      Just fp0 -> fp0
+
+
+-----------------------------------------------------------------------------------
+
+ppHH2Files :: FilePath -> String -> [(Module,Interface)] -> IO ()
+ppHH2Files odir package ifaces = do
+  let filesHH2File = package++".HxF"
+      doc =
+        text "<?xml version=\"1.0\"?>" $$
+        text "<!DOCTYPE HelpFileList SYSTEM \"ms-help://hx/resources/HelpFileList.DTD\">" $$
+        text "<HelpFileList DTDVersion=\"1.0\">" $$
+        nest 4 (ppMods ifaces $$
+                text "<File Url=\"index.html\"/>" $$
+                text "<File Url=\"doc-index.html\"/>" $$
+                ppIndexFiles chars $$
+                text "<File Url=\""<>text iconFile<>text "\"/>" $$
+                text "<File Url=\""<>text cssFile<>text "\"/>") $$
+        text "</HelpFileList>"
+  writeFile (odir ++ pathSeparator:filesHH2File) (render doc)
+  where
+    ppMods [] = empty
+    ppMods ((Module mdl,_):ifaces) =
+		text "<File Url=\"" <> text (moduleHtmlFile "" mdl) <> text "\"/>" $$
+		ppMods ifaces
+		
+    ppIndexFiles []     = empty
+    ppIndexFiles (c:cs) =
+        text "<File Url=\"doc-index-" <> char c <> text ".html\"/>" $$
+        ppIndexFiles cs
+	
+    chars :: [Char]
+    chars = keysFM (foldr getIfaceIndex emptyFM ifaces)
+
+    getIfaceIndex (mdl,iface) fm =
+        addListToFM fm [(toUpper (head (show name)),()) | (name, Qual mdl' _) <- fmToList (iface_env iface), mdl == mdl']
+
+-----------------------------------------------------------------------------------
+
+ppHH2Collection :: FilePath -> String -> [(Module,Interface)] -> IO ()
+ppHH2Collection odir package ifaces = do
+  let 
+	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 "\">" $$
+		nest 4 (text "<CompilerOptions CreateFullTextIndex=\"Yes\">" $$
+		        nest 4 (text "<IncludeFile File=\"" <> text package <> text ".HxF\"/>") $$
+		        text "</CompilerOptions>" $$
+		        text "<TOCDef File=\"" <> text package <> text ".HxT\"/>" $$
+		        text "<KeywordIndexDef File=\"" <> text package <> text "K.HxK\"/>" $$
+		        text "<KeywordIndexDef File=\"" <> text package <> text "N.HxK\"/>" $$
+		        text "<ItemMoniker Name=\"!DefaultToc\" ProgId=\"HxDs.HxHierarchy\" InitData=\"\"/>" $$
+		        text "<ItemMoniker Name=\"!DefaultFullTextSearch\" ProgId=\"HxDs.HxFullTextSearch\" InitData=\"\"/>" $$
+		        text "<ItemMoniker Name=\"!DefaultAssociativeIndex\" ProgId=\"HxDs.HxIndex\" InitData=\"A\"/>" $$
+		        text "<ItemMoniker Name=\"!DefaultKeywordIndex\" ProgId=\"HxDs.HxIndex\" InitData=\"K\"/>" $$
+		        text "<ItemMoniker Name=\"!DefaultNamedUrlIndex\" ProgId=\"HxDs.HxIndex\" InitData=\"NamedURLIndex\"/>" $$
+		        text "<ItemMoniker Name=\"!SampleInfo\" ProgId=\"HxDs.HxSampleCollection\" InitData=\"\"/>") $$
+		text "</HelpCollection>"
+  writeFile (odir ++ pathSeparator:collectionHH2File) (render doc)
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 1909805a..0f700f24 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -6,7 +6,7 @@
 
 module HaddockHtml ( 
 	ppHtml, copyHtmlBits, 
-	ppHtmlIndex, ppHtmlContents, foo
+	ppHtmlIndex, ppHtmlContents
   ) where
 
 import Prelude hiding (div)
@@ -15,51 +15,39 @@ import HaddockTypes
 import HaddockUtil
 import HaddockModuleTree
 import HaddockHH
+import HaddockHH2
 import HsSyn
 
 import IO
-import Maybe	( fromJust, isJust )
+import Maybe	( fromJust, isJust, fromMaybe )
 import List 	( sortBy )
 import Char	( isUpper, toUpper, isAlpha, ord )
 import Monad	( when, unless )
 
 #if __GLASGOW_HASKELL__ < 503
 import FiniteMap
-import URI	( escapeString, unreserved )
 #else
 import Data.FiniteMap
-import Network.URI ( escapeString, unreserved )
 #endif
 
 import Html
 import qualified Html
 
-foo = 42
-
--- -----------------------------------------------------------------------------
--- Files we need to copy from our $libdir
-
-cssFile, jsFile, iconFile :: String
-cssFile  = "haddock.css"
-jsFile   = "haddock.js"
-iconFile = "haskell_icon.gif"
-plusFile = "plus.jpg"
-minusFile = "minus.jpg"
-
 -- -----------------------------------------------------------------------------
 -- Generating HTML documentation
 
 ppHtml	:: String
+	-> Maybe String				-- package
 	-> Maybe String
 	-> [(Module, Interface)]
 	-> FilePath			-- destination directory
 	-> Maybe Doc			-- prologue text, maybe
-	-> Bool				-- do MS Help stuff
+	-> Maybe String		-- the Html Help format (--html-help)
 	-> 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 
+ppHtml doctitle package source_url ifaces odir prologue maybe_html_help_format
 	maybe_contents_url maybe_index_url =  do
   let
 	visible_ifaces = filter visible ifaces
@@ -74,10 +62,20 @@ ppHtml doctitle source_url ifaces odir prologue do_ms_help
   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
+  -- 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
@@ -348,7 +346,7 @@ ppHtmlIndex odir doctitle maybe_contents_url ifaces = do
   ppAnnot (HsVarName n)
        | isUpper c || c == ':'  = toHtml "Data Constructor"
        | otherwise		= toHtml "Function"
-      where c = head (ppHsIdentifier n)
+      where c = head (hsIdentifierStr n)
 
   indexLinks nm entries = 
      tda [ theclass "indexlinks" ] << 
@@ -418,7 +416,7 @@ ifaceToHtml _ iface
 	-- if the documentation doesn't begin with a section header, then
 	-- add one ("Documentation").
 	maybe_doc_hdr
-	    = case exports of
+	    = case exports of		   
 		   [] -> Html.emptyTable
 		   ExportGroup _ _ _ : _ -> Html.emptyTable
 		   _ -> tda [ theclass "section1" ] << toHtml "Documentation"
@@ -439,7 +437,7 @@ ppModuleContents exports
     | lev <= n  = ( [], items )
     | otherwise = ( html:secs, rest2 )
     where
-	html = (dterm << linkedAnchor "" id0 << docToHtml doc)
+	html = (dterm << linkedAnchor id0 << docToHtml doc)
 		 +++ mk_subsections ssecs
 	(ssecs, rest1) = process lev rest
 	(secs,  rest2) = process n   rest1
@@ -595,6 +593,7 @@ ppHsDataDecl summary instances is_newty
 			   aboves (map (declBox.ppInstHead) instances)
 		        )
  		   )
+
 ppHsDataDecl _ _ _ _ d =
     error $ "HaddockHtml.ppHsDataDecl: unexpected decl " ++ show d
 
@@ -763,7 +762,7 @@ ppHsClassDecl summary instances orig_c
 			)
 
 	inst_id = collapseId nm
-	instances_bit
+ 	instances_bit
 	   | null instances = Html.emptyTable
 	   | otherwise 
 	   =  s8 </> inst_hdr inst_id </>
@@ -771,7 +770,7 @@ ppHsClassDecl summary instances orig_c
 		   collapsed inst_id (
 		      spacedTable1 << (
 			aboves (map (declBox.ppInstHead) instances)
-		   ))
+		  ))
 
 ppHsClassDecl _ _ _ d =
     error $ "HaddockHtml.ppHsClassDecl: unexpected decl: " ++ show d
@@ -902,23 +901,10 @@ isSpecial _                                      = False
 ppHsName :: HsName -> Html
 ppHsName nm = toHtml (hsNameStr nm)
 
-hsAnchorNameStr :: HsName -> String
-hsAnchorNameStr (HsTyClsName id0) = "t:" ++ ppHsIdentifier id0
-hsAnchorNameStr (HsVarName id0)   = "v:" ++ ppHsIdentifier id0
-
-hsNameStr :: HsName -> String
-hsNameStr (HsTyClsName id0) = ppHsIdentifier id0
-hsNameStr (HsVarName id0)   = ppHsIdentifier id0
-
-ppHsIdentifier :: HsIdentifier -> String
-ppHsIdentifier (HsIdent str)   =  str
-ppHsIdentifier (HsSymbol str)  =  str
-ppHsIdentifier (HsSpecial str) =  str
-
 ppHsBinder :: Bool -> HsName -> Html
 -- The Bool indicates whether we are generating the summary, in which case
 -- the binder will be a link to the full definition.
-ppHsBinder True nm = linkedAnchor "" (hsAnchorNameStr nm) << ppHsBinder' nm
+ppHsBinder True nm = linkedAnchor (hsAnchorNameStr nm) << ppHsBinder' nm
 ppHsBinder False nm = linkTarget nm +++ bold << ppHsBinder' nm
 
 ppHsBinder' :: HsName -> Html
@@ -931,11 +917,11 @@ ppHsBindIdent (HsSymbol str)  =  parens (toHtml str)
 ppHsBindIdent (HsSpecial str) =  toHtml str
 
 linkId :: Module -> Maybe HsName -> Html -> Html
-linkId (Module mdl) mbStr = linkedAnchor (moduleHtmlFile fp mdl) frag
-  where frag = case mbStr of
-                  Nothing  -> ""
-                  Just str -> hsAnchorNameStr str
-        fp   = case lookupFM html_xrefs (Module mdl) of
+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
 
@@ -1108,14 +1094,6 @@ s15 = tda [ theclass "s15" ] << noHtml
 namedAnchor :: String -> Html -> Html
 namedAnchor n = anchor ! [name (escapeStr n)]
 
-linkedAnchor :: String -> String -> Html -> Html
-linkedAnchor ref frag = anchor ! [href hr]
-   where hr | null frag = ref
-            | otherwise = ref ++ '#': escapeStr frag
-
-escapeStr :: String -> String
-escapeStr = flip escapeString unreserved
-
 --
 -- A section of HTML which is collapsible via a +/- button.
 --
@@ -1130,4 +1108,10 @@ collapsed id html =
 -- A quote is a valid part of a Haskell identifier, but it would interfere with
 -- the ECMA script string delimiter used in collapsebutton above.
 collapseId :: HsName -> String
-collapseId nm = "i:" ++ escapeString (hsNameStr nm) (/= '\'')
+collapseId nm = "i:" ++ escapeStr (hsNameStr nm)
+
+linkedAnchor :: String -> Html -> Html
+linkedAnchor frag = anchor ! [href hr]
+   where hr | null frag = ""
+            | otherwise = '#': escapeStr frag
+
diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs
index ce22ee24..5ce61011 100644
--- a/src/HaddockUtil.hs
+++ b/src/HaddockUtil.hs
@@ -15,10 +15,11 @@ module HaddockUtil (
   -- * Filename utilities
   basename, dirname, splitFilename3, 
   isPathSeparator, pathSeparator,
-  moduleHtmlFile,
+  moduleHtmlFile, nameHtmlRef,
+  cssFile, iconFile, jsFile, plusFile, minusFile,
 
   -- * Miscellaneous utilities
-  getProgramName, bye, die, dieMsg, mapSnd, mapMaybeM,
+  getProgramName, bye, die, dieMsg, mapSnd, mapMaybeM, escapeStr,
 
   -- * HTML cross reference mapping
   html_xrefs_ref, html_xrefs,
@@ -37,11 +38,13 @@ import Monad
 import RegexString
 import FiniteMap
 import IOExts
+import URI	( escapeString, unreserved )
 #else
 import Text.Regex
 import Data.FiniteMap
 import Data.IORef
 import System.IO.Unsafe	 ( unsafePerformIO )
+import Network.URI ( escapeString, unreserved )
 #endif
 
 -- -----------------------------------------------------------------------------
@@ -271,6 +274,19 @@ moduleHtmlFile :: FilePath -> String -> FilePath
 moduleHtmlFile "" mod0  = mod0 ++ ".html" -- ToDo: Z-encode filename?
 moduleHtmlFile dir mod0 = dir ++ pathSeparator : mod0 ++ ".html"
 
+nameHtmlRef :: FilePath -> String -> HsName -> String	
+nameHtmlRef fp mdl str = moduleHtmlFile fp mdl ++ '#':escapeStr (hsAnchorNameStr str)
+
+-- -----------------------------------------------------------------------------
+-- Files we need to copy from our $libdir
+
+cssFile, iconFile, jsFile, plusFile,minusFile :: String
+cssFile   = "haddock.css"
+iconFile  = "haskell_icon.gif"
+jsFile    = "haddock.js"
+plusFile  = "plus.jpg"
+minusFile = "minus.jpg"
+
 -----------------------------------------------------------------------------
 -- misc.
 
@@ -297,6 +313,9 @@ mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b)
 mapMaybeM _ Nothing = return Nothing
 mapMaybeM f (Just a) = f a >>= return . Just
 
+escapeStr :: String -> String
+escapeStr str = escapeString str unreserved
+
 -----------------------------------------------------------------------------
 -- HTML cross references
 
diff --git a/src/HsSyn.lhs b/src/HsSyn.lhs
index e43826a0..1599365c 100644
--- a/src/HsSyn.lhs
+++ b/src/HsSyn.lhs
@@ -1,5 +1,5 @@
 % -----------------------------------------------------------------------------
-% $Id: HsSyn.lhs,v 1.19 2003/11/06 12:39:47 simonmar Exp $
+% $Id: HsSyn.lhs,v 1.20 2004/07/27 22:58:24 krasimir Exp $
 %
 % (c) The GHC Team, 1997-2002
 %
@@ -30,6 +30,8 @@ module HsSyn (
     unit_tycon_qname, fun_tycon_qname, list_tycon_qname, tuple_tycon_qname,
     unit_tycon, fun_tycon, list_tycon, tuple_tycon,
 
+    hsIdentifierStr, hsAnchorNameStr, hsNameStr, 
+	
     GenDoc(..), Doc, DocMarkup(..),
     markup, mapIdent, idMarkup,
     docAppend, docParagraph,
@@ -386,6 +388,19 @@ list_tycon	      = HsTyCon list_tycon_qname
 tuple_tycon :: Int -> HsType
 tuple_tycon i	      = HsTyCon (tuple_tycon_qname i)
 
+hsIdentifierStr :: HsIdentifier -> String
+hsIdentifierStr (HsIdent str)   =  str
+hsIdentifierStr (HsSymbol str)  =  str
+hsIdentifierStr (HsSpecial str) =  str
+
+hsAnchorNameStr :: HsName -> String
+hsAnchorNameStr (HsTyClsName id0) = "t:" ++ hsIdentifierStr id0
+hsAnchorNameStr (HsVarName id0)   = "v:" ++ hsIdentifierStr id0
+
+hsNameStr :: HsName -> String
+hsNameStr (HsTyClsName id0) = hsIdentifierStr id0
+hsNameStr (HsVarName id0)   = hsIdentifierStr id0
+
 -- -----------------------------------------------------------------------------
 -- Doc strings and formatting
 
diff --git a/src/Main.hs b/src/Main.hs
index 96b76f2e..1070538b 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -51,12 +51,6 @@ import Regex
 import PackedString
 #endif
 
-#if defined(mingw32_HOST_OS)
-import Foreign.Marshal.Array
-import Foreign
-import Foreign.C
-#endif
-
 -----------------------------------------------------------------------------
 -- Top-level stuff
 main :: IO ()
@@ -79,8 +73,8 @@ data Flag
   | Flag_Heading String
   | Flag_Package String
   | Flag_Html
+  | Flag_HtmlHelp String
   | Flag_Lib String
-  | Flag_MSHtmlHelp
   | Flag_NoImplicitPrelude
   | Flag_OutputDir FilePath
   | Flag_Prologue FilePath
@@ -110,8 +104,8 @@ options =
 --	"output in docbook (SGML)",
     Option ['h']  ["html"]     (NoArg Flag_Html)
 	"output in HTML",
-    Option ['m']  ["ms-help"]    (NoArg Flag_MSHtmlHelp)
-	"produce Microsoft HTML Help files (with -h)",
+    Option []  ["html-help"]    (ReqArg Flag_HtmlHelp "format")
+	"produce index and table of contents in mshelp, mshelp2 or devhelp format (with -h)",
     Option ['s']  ["source"]   (ReqArg Flag_SourceURL "URL") 
 	"base URL for links to source code",
     Option ['c']  ["css"]         (ReqArg Flag_CSS "FILE") 
@@ -261,8 +255,11 @@ run flags files = do
 			     | (mdl, i) <-  these_mod_ifaces ])
 
   when (Flag_Html `elem` flags) $ do
-    ppHtml title source_url these_mod_ifaces odir
-	prologue (Flag_MSHtmlHelp `elem` flags) 
+    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
 		maybe_contents_url maybe_index_url
     copyHtmlBits odir libdir css_file
 
@@ -439,7 +436,6 @@ mkInterface no_implicit_prelude verbose mod_map filename package
   -- make the "export items", which will be converted into docs later
   orig_export_list <- mkExportItems mod_map mdl exported_names decl_map sub_map
 			 		final_decls opts orig_exports
-					
 
   let
      -- prune the export list to just those declarations that have
@@ -529,8 +525,8 @@ derivedInstances mdl decl = case decl of
      isVar (HsTyVar _) = True
      isVar _ = False
      extra_constraint
-	| null complex_tvars = []
-	| otherwise = [(unknownConstraint,complex_tvars)]
+ 	| null complex_tvars = []
+ 	| otherwise = [(unknownConstraint,complex_tvars)]
      lhs
 	| n == tuple_tycon_name (length tvs - 1) =
 	   HsTyTuple True (map HsTyVar tvs)
@@ -843,7 +839,7 @@ getReExports :: Module
    -> FiniteMap HsQName HsQName
    -> FiniteMap HsName HsQName
 getReExports mdl exported exported_visible import_env
-  = listToFM (concat invisible_names)
+  = listToFM (concat invisible_names)  
   where
    invisible_names = [ get_name n | n <- exported, 
 				       n `notElem` exported_visible ]
author	krasimir <unknown>	2004-07-27 22:59:35 +0000
committer	krasimir <unknown>	2004-07-27 22:59:35 +0000
commit	f183618bf9c523800ae84d0cb72c65b7ef22aa0b (patch)
tree	6e2403e95c9517005e8d59ee4ad5be4cec24b7bf /src
parent	1d7bc432f61f221c16ecf96903a56a7e5724a587 (diff)