aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock
diff options
context:
space:
mode:
authordavve@dtek.chalmers.se <David Waern>2007-03-25 01:23:25 +0000
committerdavve@dtek.chalmers.se <David Waern>2007-03-25 01:23:25 +0000
commit11ebf08d5ef30375ba5585b6079f696d49402c3f (patch)
tree0287ff78e5f7f0658010c6c18993415693bd9ab9 /src/Haddock
parentbc59490468c17bfc181ffe51cf428314195ad8a0 (diff)
De-flatten the namespace
Diffstat (limited to 'src/Haddock')
-rw-r--r--src/Haddock/DevHelp.hs75
-rw-r--r--src/Haddock/HH.hs174
-rw-r--r--src/Haddock/HH2.hs182
-rw-r--r--src/Haddock/HaddockDB.hs165
-rw-r--r--src/Haddock/Hoogle.hs184
-rw-r--r--src/Haddock/Html.hs1508
-rw-r--r--src/Haddock/InterfaceFile.hs2
-rw-r--r--src/Haddock/ModuleTree.hs38
-rw-r--r--src/Haddock/Rename.hs320
-rw-r--r--src/Haddock/Types.hs123
-rw-r--r--src/Haddock/Utils.hs340
-rw-r--r--src/Haddock/Utils/BlockTable.hs180
-rw-r--r--src/Haddock/Utils/FastMutInt2.hs63
-rw-r--r--src/Haddock/Utils/GHC.hs26
-rw-r--r--src/Haddock/Utils/Html.hs1037
-rw-r--r--src/Haddock/Version.hs18
16 files changed, 4434 insertions, 1 deletions
diff --git a/src/Haddock/DevHelp.hs b/src/Haddock/DevHelp.hs
new file mode 100644
index 00000000..afcbd1c3
--- /dev/null
+++ b/src/Haddock/DevHelp.hs
@@ -0,0 +1,75 @@
+module Haddock.DevHelp(ppDevHelpFile) where
+
+import Haddock.ModuleTree
+import Haddock.Types
+import Haddock.Utils
+
+import Module ( moduleName, moduleNameString, Module, mkModule, mkModuleName )
+import PackageConfig ( stringToPackageId )
+import Name ( Name, nameModule, getOccString )
+
+import Data.Maybe ( fromMaybe )
+import qualified Data.Map as Map
+import Text.PrettyPrint
+
+ppDevHelpFile :: FilePath -> String -> Maybe String -> [HaddockModule] -> IO ()
+ppDevHelpFile odir doctitle maybe_package modules = do
+ let devHelpFile = package++".devhelp"
+ tree = mkModuleTree True [ (hmod_mod mod, toDescription mod) | mod <- modules ]
+ doc =
+ text "<?xml version=\"1.0\" encoding=\"utf-8\" standalone=\"no\"?>" $$
+ (text "<book xmlns=\"http://www.devhelp.net/book\" title=\""<>text doctitle<>
+ text "\" link=\""<>text contentsHtmlFile<>text"\" author=\"\" name=\""<>text package<>text "\">") $$
+ text "<chapters>" $$
+ nest 4 (ppModuleTree [] tree) $+$
+ text "</chapters>" $$
+ text "<functions>" $$
+ nest 4 (ppList index) $+$
+ text "</functions>" $$
+ text "</book>"
+ writeFile (pathJoin [odir, devHelpFile]) (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
+ ppModuleTree _ [] = error "HaddockHH.ppHHContents.fn: no module trees given"
+
+ ppNode :: [String] -> ModuleTree -> Doc
+ ppNode ss (Node s leaf _ _short ts) =
+ case ts of
+ [] -> text "<sub"<+>ppAttribs<>text "/>"
+ ts ->
+ text "<sub"<+>ppAttribs<>text ">" $$
+ nest 4 (ppModuleTree (s:ss) ts) $+$
+ text "</sub>"
+ where
+ ppLink | leaf = text (moduleHtmlFile (mkModule (stringToPackageId "")
+ (mkModuleName mdl)))
+ | otherwise = empty
+
+ ppAttribs = text "name="<>doubleQuotes (text s)<+>text "link="<>doubleQuotes ppLink
+
+ mdl = foldr (++) "" (s' : map ('.':) ss')
+ (s':ss') = reverse (s:ss)
+ -- reconstruct the module name
+
+ index :: [(Name, [Module])]
+ index = Map.toAscList (foldr getModuleIndex Map.empty modules)
+
+ getModuleIndex hmod fm =
+ Map.unionWith (++) (Map.fromListWith (flip (++)) [(name, [mod]) | name <- hmod_exports hmod, nameModule name == mod]) fm
+ where mod = hmod_mod hmod
+
+ ppList :: [(Name, [Module])] -> Doc
+ ppList [] = empty
+ ppList ((name,refs):mdls) =
+ ppReference name refs $$
+ ppList mdls
+
+ ppReference :: Name -> [Module] -> Doc
+ ppReference name [] = empty
+ ppReference name (mod:refs) =
+ text "<function name=\""<>text (escapeStr (getOccString name))<>text"\" link=\""<>text (nameHtmlRef mod name)<>text"\"/>" $$
+ ppReference name refs
diff --git a/src/Haddock/HH.hs b/src/Haddock/HH.hs
new file mode 100644
index 00000000..a41d7297
--- /dev/null
+++ b/src/Haddock/HH.hs
@@ -0,0 +1,174 @@
+module Haddock.HH(ppHHContents, ppHHIndex, ppHHProject) where
+
+ppHHContents = error "not yet"
+ppHHIndex = error "not yet"
+ppHHProject = error "not yet"
+
+{-
+import HaddockModuleTree
+import HaddockTypes
+import HaddockUtil
+import HsSyn2 hiding(Doc)
+import qualified Map
+
+import Data.Char ( toUpper )
+import Data.Maybe ( fromMaybe )
+import Text.PrettyPrint
+
+ppHHContents :: FilePath -> String -> Maybe String -> [ModuleTree] -> IO ()
+ppHHContents odir doctitle maybe_package tree = do
+ let contentsHHFile = package++".hhc"
+
+ html =
+ text "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">" $$
+ text "<HTML>" $$
+ text "<HEAD>" $$
+ text "<META name=\"GENERATOR\" content=\"Haddock\">" $$
+ text "<!-- Sitemap 1.0 -->" $$
+ text "</HEAD><BODY>" $$
+ ppModuleTree tree $$
+ text "</BODY><HTML>"
+ writeFile (pathJoin [odir, contentsHHFile]) (render html)
+ where
+ package = fromMaybe "pkg" maybe_package
+
+ ppModuleTree :: [ModuleTree] -> Doc
+ ppModuleTree ts =
+ text "<OBJECT type=\"text/site properties\">" $$
+ text "<PARAM name=\"FrameName\" value=\"main\">" $$
+ text "</OBJECT>" $$
+ text "<UL>" $+$
+ nest 4 (text "<LI>" <> nest 4
+ (text "<OBJECT type=\"text/sitemap\">" $$
+ nest 4 (text "<PARAM name=\"Name\" value=\""<>text doctitle<>text "\">" $$
+ text "<PARAM name=\"Local\" value=\"index.html\">") $$
+ text "</OBJECT>") $+$
+ text "</LI>" $$
+ text "<UL>" $+$
+ nest 4 (fn [] ts) $+$
+ text "</UL>") $+$
+ text "</UL>"
+
+ fn :: [String] -> [ModuleTree] -> Doc
+ fn ss [x] = ppNode ss x
+ fn ss (x:xs) = ppNode ss x $$ fn ss xs
+ fn _ [] = error "HaddockHH.ppHHContents.fn: no module trees given"
+
+ ppNode :: [String] -> ModuleTree -> Doc
+ ppNode ss (Node s leaf _pkg _ []) =
+ ppLeaf s ss leaf
+ ppNode ss (Node s leaf _pkg _ ts) =
+ ppLeaf s ss leaf $$
+ text "<UL>" $+$
+ nest 4 (fn (s:ss) ts) $+$
+ text "</UL>"
+
+ ppLeaf s ss isleaf =
+ text "<LI>" <> nest 4
+ (text "<OBJECT type=\"text/sitemap\">" $$
+ text "<PARAM name=\"Name\" value=\"" <> text s <> text "\">" $$
+ (if isleaf then text "<PARAM name=\"Local\" value=\"" <> text (moduleHtmlFile mdl) <> text "\">" else empty) $$
+ text "</OBJECT>") $+$
+ text "</LI>"
+ where
+ mdl = foldr (++) "" (s' : map ('.':) ss')
+ (s':ss') = reverse (s:ss)
+ -- reconstruct the module name
+
+-------------------------------
+ppHHIndex :: FilePath -> Maybe String -> [Interface] -> IO ()
+ppHHIndex odir maybe_package ifaces = do
+ let indexHHFile = package++".hhk"
+
+ html =
+ text "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">" $$
+ text "<HTML>" $$
+ text "<HEAD>" $$
+ text "<META name=\"GENERATOR\" content=\"Haddock\">" $$
+ text "<!-- Sitemap 1.0 -->" $$
+ text "</HEAD><BODY>" $$
+ text "<UL>" $+$
+ nest 4 (ppList index) $+$
+ text "</UL>" $$
+ text "</BODY><HTML>"
+ writeFile (pathJoin [odir, indexHHFile]) (render html)
+ where
+ package = fromMaybe "pkg" maybe_package
+
+ index :: [(HsName, [Module])]
+ index = Map.toAscList (foldr getIfaceIndex Map.empty ifaces)
+
+ getIfaceIndex iface fm =
+ foldl (\m (k,e) -> Map.insertWith (++) k e m) fm [(name, [mdl]) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']
+ where mdl = iface_module iface
+
+ ppList [] = empty
+ ppList ((name,refs):mdls) =
+ text "<LI>" <> nest 4
+ (text "<OBJECT type=\"text/sitemap\">" $$
+ text "<PARAM name=\"Name\" value=\"" <> text (show name) <> text "\">" $$
+ ppReference name refs $$
+ text "</OBJECT>") $+$
+ text "</LI>" $$
+ ppList mdls
+
+ ppReference name [] = empty
+ ppReference name (Module mdl:refs) =
+ text "<PARAM name=\"Local\" value=\"" <> text (nameHtmlRef mdl name) <> text "\">" $$
+ ppReference name refs
+
+
+ppHHProject :: FilePath -> String -> Maybe String -> [Interface] -> [FilePath] -> IO ()
+ppHHProject odir doctitle maybe_package ifaces pkg_paths = do
+ let projectHHFile = package++".hhp"
+ doc =
+ text "[OPTIONS]" $$
+ text "Compatibility=1.1 or later" $$
+ text "Compiled file=" <> text package <> text ".chm" $$
+ text "Contents file=" <> text package <> text ".hhc" $$
+ text "Default topic=" <> text contentsHtmlFile $$
+ text "Display compile progress=No" $$
+ text "Index file=" <> text package <> text ".hhk" $$
+ text "Title=" <> text doctitle $$
+ space $$
+ text "[FILES]" $$
+ ppMods ifaces $$
+ text contentsHtmlFile $$
+ text indexHtmlFile $$
+ ppIndexFiles chars $$
+ ppLibFiles ("":pkg_paths)
+ writeFile (pathJoin [odir, projectHHFile]) (render doc)
+ where
+ package = fromMaybe "pkg" maybe_package
+
+ ppMods [] = empty
+ ppMods (iface:ifaces) =
+ let Module mdl = iface_module iface in
+ 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 = pathJoin [path, fname]
+ ppLibFile fname = text (toPath fname)
+
+ chars :: [Char]
+ chars = map fst (Map.toAscList (foldr getIfaceIndex Map.empty ifaces))
+
+ getIfaceIndex iface fm =
+ Map.union (Map.fromList [(toUpper (head (show name)),()) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm
+ where mdl = iface_module iface
+-}
diff --git a/src/Haddock/HH2.hs b/src/Haddock/HH2.hs
new file mode 100644
index 00000000..945734e6
--- /dev/null
+++ b/src/Haddock/HH2.hs
@@ -0,0 +1,182 @@
+module Haddock.HH2(ppHH2Contents, ppHH2Index, ppHH2Files, ppHH2Collection) where
+
+ppHH2Contents = error "not yet"
+ppHH2Index = error "not yet"
+ppHH2Files = error "not yet"
+ppHH2Collection = error "not yet"
+
+{-
+import HaddockModuleTree
+import HaddockTypes
+import HaddockUtil
+import HsSyn2 hiding(Doc)
+import qualified Map
+
+import Data.Char ( toUpper )
+import Data.Maybe ( fromMaybe )
+import Text.PrettyPrint
+
+ppHH2Contents :: FilePath -> String -> Maybe String -> [ModuleTree] -> IO ()
+ppHH2Contents odir doctitle maybe_package tree = do
+ let
+ contentsHH2File = package++".HxT"
+
+ doc =
+ text "<?xml version=\"1.0\"?>" $$
+ text "<!DOCTYPE HelpTOC SYSTEM \"ms-help://hx/resources/HelpTOC.DTD\">" $$
+ text "<HelpTOC DTDVersion=\"1.0\">" $$
+ nest 4 (text "<HelpTOCNode Title=\""<>text doctitle<>text"\" Url=\"index.html\">" $$
+ nest 4 (ppModuleTree [] tree) $+$
+ text "</HelpTOCNode>") $$
+ text "</HelpTOC>"
+ writeFile (pathJoin [odir, 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
+ ppModuleTree _ [] = error "HaddockHH2.ppHH2Contents.ppModuleTree: no module trees given"
+
+ ppNode :: [String] -> ModuleTree -> Doc
+ ppNode ss (Node s leaf _pkg _short []) =
+ text "<HelpTOCNode" <+> ppAttributes leaf (s:ss) <> text "/>"
+ ppNode ss (Node s leaf _pkg _short 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 -> Maybe String -> [Interface] -> IO ()
+ppHH2Index odir maybe_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=\""<>text contentsHtmlFile<>text "\"/>") $$
+ text "</Keyword>" $$
+ text "</HelpIndex>"
+ writeFile (pathJoin [odir, indexKHH2File]) (render docK)
+ writeFile (pathJoin [odir, indexNHH2File]) (render docN)
+ where
+ package = fromMaybe "pkg" maybe_package
+
+ index :: [(HsName, [Module])]
+ index = Map.toAscList (foldr getIfaceIndex Map.empty ifaces)
+
+ getIfaceIndex iface fm =
+ Map.unionWith (++) (Map.fromListWith (flip (++)) [(name, [mdl]) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm
+ where mdl = iface_module iface
+
+ ppList [] = empty
+ ppList ((name,mdls):vs) =
+ text "<Keyword Term=\"" <> text (escapeStr (show name)) <> text "\">" $$
+ nest 4 (vcat (map (ppJump name) mdls)) $$
+ text "</Keyword>" $$
+ ppList vs
+
+ ppJump name (Module mdl) = text "<Jump Url=\"" <> text (nameHtmlRef mdl name) <> text "\"/>"
+
+
+-----------------------------------------------------------------------------------
+
+ppHH2Files :: FilePath -> Maybe String -> [Interface] -> [FilePath] -> IO ()
+ppHH2Files odir maybe_package ifaces pkg_paths = 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=\""<>text contentsHtmlFile<>text "\"/>" $$
+ text "<File Url=\""<>text indexHtmlFile<>text "\"/>" $$
+ ppIndexFiles chars $$
+ ppLibFiles ("":pkg_paths)) $$
+ text "</HelpFileList>"
+ writeFile (pathJoin [odir, filesHH2File]) (render doc)
+ where
+ package = fromMaybe "pkg" maybe_package
+
+ ppMods [] = empty
+ ppMods (iface:ifaces) =
+ text "<File Url=\"" <> text (moduleHtmlFile mdl) <> text "\"/>" $$
+ ppMods ifaces
+ where Module mdl = iface_module iface
+
+ ppIndexFiles [] = empty
+ ppIndexFiles (c:cs) =
+ text "<File Url=\""<>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 = pathJoin [path, fname]
+ ppLibFile fname = text "<File Url=\""<>text (toPath fname)<>text "\"/>"
+
+ chars :: [Char]
+ chars = map fst (Map.toAscList (foldr getIfaceIndex Map.empty ifaces))
+
+ getIfaceIndex iface fm =
+ Map.union (Map.fromList [(toUpper (head (show name)),()) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm
+ where mdl = iface_module iface
+
+-----------------------------------------------------------------------------------
+
+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 doctitle <> 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 (pathJoin [odir, collectionHH2File]) (render doc)
+-}
diff --git a/src/Haddock/HaddockDB.hs b/src/Haddock/HaddockDB.hs
new file mode 100644
index 00000000..6341c6c4
--- /dev/null
+++ b/src/Haddock/HaddockDB.hs
@@ -0,0 +1,165 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+
+module Haddock.HaddockDB (ppDocBook) where
+
+{-
+import HaddockTypes
+import HaddockUtil
+import HsSyn2
+
+import Text.PrettyPrint
+-}
+
+-----------------------------------------------------------------------------
+-- Printing the results in DocBook format
+
+ppDocBook = error "not working"
+{-
+ppDocBook :: FilePath -> [(Module, Interface)] -> String
+ppDocBook odir mods = render (ppIfaces mods)
+
+ppIfaces mods
+ = text "<!DOCTYPE BOOK PUBLIC \"-//OASIS//DTD DocBook V3.1//EN\" ["
+ $$ text "]>"
+ $$ text "<book>"
+ $$ text "<bookinfo>"
+ $$ text "<author><othername>HaskellDoc version 0.0</othername></author>"
+ $$ text "</bookinfo>"
+ $$ text "<article>"
+ $$ vcat (map do_mod mods)
+ $$ text "</article></book>"
+ where
+ do_mod (Module mod, iface)
+ = text "<sect1 id=\"sec-" <> text mod <> text "\">"
+ $$ text "<title><literal>"
+ <> text mod
+ <> text "</literal></title>"
+ $$ text "<indexterm><primary><literal>"
+ <> text mod
+ <> text "</literal></primary></indexterm>"
+ $$ text "<variablelist>"
+ $$ vcat (map (do_export mod) (eltsFM (iface_decls iface)))
+ $$ text "</variablelist>"
+ $$ text "</sect1>"
+
+ do_export mod decl | (nm:_) <- declBinders decl
+ = text "<varlistentry id=" <> ppLinkId mod nm <> char '>'
+ $$ text "<term><literal>"
+ <> do_decl decl
+ <> text "</literal></term>"
+ $$ text "<listitem>"
+ $$ text "<para>"
+ $$ text "</para>"
+ $$ text "</listitem>"
+ $$ text "</varlistentry>"
+ do_export _ _ = empty
+
+ do_decl (HsTypeSig _ [nm] ty _)
+ = ppHsName nm <> text " :: " <> ppHsType ty
+ do_decl (HsTypeDecl _ nm args ty _)
+ = hsep ([text "type", ppHsName nm ]
+ ++ map ppHsName args
+ ++ [equals, ppHsType ty])
+ do_decl (HsNewTypeDecl loc ctx nm args con drv _)
+ = hsep ([text "data", ppHsName nm] -- data, not newtype
+ ++ map ppHsName args
+ ) <+> equals <+> ppHsConstr con -- ToDo: derivings
+ do_decl (HsDataDecl loc ctx nm args cons drv _)
+ = hsep ([text "data", {-ToDo: context-}ppHsName nm]
+ ++ map ppHsName args)
+ <+> vcat (zipWith (<+>) (equals : repeat (char '|'))
+ (map ppHsConstr cons))
+ do_decl (HsClassDecl loc ty fds decl _)
+ = hsep [text "class", ppHsType ty]
+ do_decl decl
+ = empty
+
+ppHsConstr :: HsConDecl -> Doc
+ppHsConstr (HsRecDecl pos name tvs ctxt fieldList maybe_doc) =
+ ppHsName name
+ <> (braces . hsep . punctuate comma . map ppField $ fieldList)
+ppHsConstr (HsConDecl pos name tvs ctxt typeList maybe_doc) =
+ hsep (ppHsName name : map ppHsBangType typeList)
+
+ppField (HsFieldDecl ns ty doc)
+ = hsep (punctuate comma (map ppHsName ns) ++
+ [text "::", ppHsBangType ty])
+
+ppHsBangType :: HsBangType -> Doc
+ppHsBangType (HsBangedTy ty) = char '!' <> ppHsType ty
+ppHsBangType (HsUnBangedTy ty) = ppHsType ty
+
+ppHsContext :: HsContext -> Doc
+ppHsContext [] = empty
+ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+>
+ hsep (map ppHsAType b)) context)
+
+ppHsType :: HsType -> Doc
+ppHsType (HsForAllType Nothing context htype) =
+ hsep [ ppHsContext context, text "=>", ppHsType htype]
+ppHsType (HsForAllType (Just tvs) [] htype) =
+ hsep (text "forall" : map ppHsName tvs ++ text "." : [ppHsType htype])
+ppHsType (HsForAllType (Just tvs) context htype) =
+ hsep (text "forall" : map ppHsName tvs ++ text "." :
+ ppHsContext context : text "=>" : [ppHsType htype])
+ppHsType (HsTyFun a b) = fsep [ppHsBType a, text "-&gt;", ppHsType b]
+ppHsType (HsTyIP n t) = fsep [(char '?' <> ppHsName n), text "::", ppHsType t]
+ppHsType t = ppHsBType t
+
+ppHsBType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b )
+ = brackets $ ppHsType b
+ppHsBType (HsTyApp a b) = fsep [ppHsBType a, ppHsAType b]
+ppHsBType t = ppHsAType t
+
+ppHsAType :: HsType -> Doc
+ppHsAType (HsTyTuple True l) = parenList . map ppHsType $ l
+ppHsAType (HsTyTuple False l) = ubxParenList . map ppHsType $ l
+-- special case
+ppHsAType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b )
+ = brackets $ ppHsType b
+ppHsAType (HsTyVar name) = ppHsName name
+ppHsAType (HsTyCon name) = ppHsQName name
+ppHsAType t = parens $ ppHsType t
+
+ppHsQName :: HsQName -> Doc
+ppHsQName (UnQual str) = ppHsName str
+ppHsQName n@(Qual (Module mod) str)
+ | n == unit_con_name = ppHsName str
+ | isSpecial str = ppHsName str
+ | otherwise
+ = text "<link linkend=" <> ppLinkId mod str <> char '>'
+ <> ppHsName str
+ <> text "</link>"
+
+isSpecial (HsTyClsName id) | HsSpecial _ <- id = True
+isSpecial (HsVarName id) | HsSpecial _ <- id = True
+isSpecial _ = False
+
+ppHsName :: HsName -> Doc
+ppHsName (HsTyClsName id) = ppHsIdentifier id
+ppHsName (HsVarName id) = ppHsIdentifier id
+
+ppHsIdentifier :: HsIdentifier -> Doc
+ppHsIdentifier (HsIdent str) = text str
+ppHsIdentifier (HsSymbol str) = text str
+ppHsIdentifier (HsSpecial str) = text str
+
+ppLinkId :: String -> HsName -> Doc
+ppLinkId mod str
+ = hcat [char '\"', text mod, char '.', ppHsName str, char '\"']
+
+-- -----------------------------------------------------------------------------
+-- * Misc
+
+parenList :: [Doc] -> Doc
+parenList = parens . fsep . punctuate comma
+
+ubxParenList :: [Doc] -> Doc
+ubxParenList = ubxparens . fsep . punctuate comma
+
+ubxparens p = text "(#" <> p <> text "#)"
+-}
diff --git a/src/Haddock/Hoogle.hs b/src/Haddock/Hoogle.hs
new file mode 100644
index 00000000..618d6eb3
--- /dev/null
+++ b/src/Haddock/Hoogle.hs
@@ -0,0 +1,184 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+-- This file, (c) Neil Mitchell 2006
+-- Write out Hoogle compatible documentation
+-- http://www.haskell.org/hoogle/
+
+module Haddock.Hoogle (
+ ppHoogle
+ ) where
+
+ppHoogle = undefined
+
+{-
+import HaddockTypes
+import HaddockUtil
+import HsSyn2
+
+import Data.List ( intersperse )
+
+
+
+prefix = ["-- Hoogle documentation, generated by Haddock",
+ "-- See Hoogle, http://www.haskell.org/hoogle/"]
+
+ppHoogle :: Maybe String -> [Interface] -> FilePath -> IO ()
+ppHoogle maybe_package ifaces odir =
+ do
+ let
+ filename = case maybe_package of
+ Just x -> x ++ ".txt"
+ Nothing -> "hoogle.txt"
+
+ visible_ifaces = filter visible ifaces
+ visible i = OptHide `notElem` iface_options i
+
+ contents = prefix : map ppModule visible_ifaces
+
+ writeFile (pathJoin [odir, filename]) (unlines $ concat contents)
+
+
+
+-- ---------------------------------------------------------------------------
+-- Generate the HTML page for a module
+
+
+ppDecl :: HsDecl -> [String]
+ppDecl (HsNewTypeDecl src context name args ctor unknown docs) =
+ ppData "newtype" context name args [ctor]
+
+ppDecl (HsDataDecl src context name args ctors unknown docs) =
+ ppData "data" context name args ctors
+
+ppDecl (HsTypeSig src names t doc) = map (`ppFunc` t) names
+
+ppDecl (HsForeignImport src _ _ _ name t doc) = ppDecl $ HsTypeSig src [name] t doc
+
+ppDecl (HsClassDecl src context name args fundeps members doc) =
+ ("class " ++ ppContext context ++ ppType typ) : concatMap f members
+ where
+ typ = foldl HsTyApp (HsTyCon $ UnQual name) (map HsTyVar args)
+ newcontext = (UnQual name, map HsTyVar args)
+ f (HsTypeSig src names t doc) = ppDecl (HsTypeSig src names (addContext newcontext t) doc)
+ f (HsFunBind{}) = []
+ f (HsPatBind{}) = []
+ f x = ["-- ERR " ++ show x]
+
+ppDecl (HsTypeDecl src name args t doc) =
+ ["type " ++ show name ++ concatMap (\x -> ' ':show x) args ++ " = " ++ ppType t]
+
+ppDecl x = ["-- ERR " ++ show x]
+
+
+
+addContext :: HsAsst -> HsType -> HsType
+addContext ctx (HsForAllType Nothing context t) = HsForAllType Nothing (HsAssump ctx : context) t
+addContext ctx x = HsForAllType Nothing [HsAssump ctx] x
+
+
+
+ppFunc :: HsName -> HsType -> String
+ppFunc name typ = show name ++ " :: " ++ ppType typ
+
+
+ppData :: String -> HsContext -> HsName -> [HsName] -> [HsConDecl] -> [String]
+ppData mode context name args ctors = (mode ++ " " ++ ppType typ) : concatMap (ppCtor typ) ctors
+ where
+ typ = foldl HsTyApp (HsTyCon $ UnQual name) (map HsTyVar args)
+
+
+deBang :: HsBangType -> HsType
+deBang (HsBangedTy x) = x
+deBang (HsUnBangedTy x) = x
+
+
+ppCtor :: HsType -> HsConDecl -> [String]
+ppCtor result (HsConDecl src name types context typ doc) =
+ [show name ++ " :: " ++ ppContext context ++ ppTypesArr (map deBang typ ++ [result])]
+
+ppCtor result (HsRecDecl src name types context fields doc) =
+ ppCtor result (HsConDecl src name types context (map snd fields2) doc) ++
+ concatMap f fields2
+ where
+ fields2 = [(name, typ) | HsFieldDecl names typ _ <- fields, name <- names]
+ f (name, typ) = ppDecl $ HsTypeSig src [name] (HsTyFun result (deBang typ)) doc
+
+
+brack True x = "(" ++ x ++ ")"
+brack False x = x
+
+ppContext :: HsContext -> String
+ppContext [] = ""
+ppContext xs = brack (length xs > 1) (concat $ intersperse ", " $ map ppContextItem xs) ++ " => "
+
+ppContextItem :: HsAsst -> String
+ppContextItem (name, types) = ppQName name ++ concatMap (\x -> ' ':ppType x) types
+
+ppContext2 :: HsIPContext -> String
+ppContext2 xs = ppContext [x | HsAssump x <- xs]
+
+
+ppType :: HsType -> String
+ppType x = f 0 x
+ where
+ f _ (HsTyTuple _ xs) = brack True $ concat $ intersperse ", " $ map (f 0) xs
+ f _ (HsTyCon x) = ppQName x
+ f _ (HsTyVar x) = show x
+
+ -- ignore ForAll types as Hoogle does not support them
+ f n (HsForAllType (Just items) context t) =
+ -- brack (n > 1) $
+ -- "forall" ++ concatMap (\x -> ' ':toStr x) items ++ " . " ++ f 0 t
+ f n t
+
+ f n (HsForAllType Nothing context t) = brack (n > 1) $
+ ppContext2 context ++ f 0 t
+
+ f n (HsTyFun a b) = brack g $ f (h 3) a ++ " -> " ++ f (h 2) b
+ where
+ g = n > 2
+ h x = if g then 0 else x
+
+ f n (HsTyApp a b) | ppType a == "[]" = "[" ++ f 0 b ++ "]"
+
+ f n (HsTyApp a b) = brack g $ f (h 3) a ++ " " ++ f (h 4) b
+ where
+ g = n > 3
+ h x = if g then 0 else x
+
+ f n (HsTyDoc x _) = f n x
+
+ f n x = brack True $ show x
+
+
+ppQName :: HsQName -> String
+ppQName (Qual _ name) = show name
+ppQName (UnQual name) = show name
+
+
+
+ppTypesArr :: [HsType] -> String
+ppTypesArr xs = ppType $ foldr1 HsTyFun xs
+
+
+
+ppInst :: InstHead -> String
+ppInst (context, item) = "instance " ++ ppContext context ++ ppContextItem item
+
+
+
+ppModule :: Interface -> [String]
+ppModule iface = "" : ("module " ++ mdl) : concatMap ppExport (iface_exports iface)
+ where
+ Module mdl = iface_module iface
+
+
+ppExport :: ExportItem -> [String]
+ppExport (ExportDecl name decl insts) = ppDecl decl ++ map ppInst insts
+ppExport _ = []
+
+
+-}
diff --git a/src/Haddock/Html.hs b/src/Haddock/Html.hs
new file mode 100644
index 00000000..6bd80687
--- /dev/null
+++ b/src/Haddock/Html.hs
@@ -0,0 +1,1508 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+
+module Haddock.Html (
+ ppHtml, copyHtmlBits,
+ ppHtmlIndex, ppHtmlContents,
+ ppHtmlHelpFiles
+ ) where
+
+import Prelude hiding (div)
+
+import Haddock.DevHelp
+import Haddock.HH
+import Haddock.HH2
+import Haddock.ModuleTree
+import Haddock.Types
+import Haddock.Utils
+import Haddock.Version
+import Haddock.Utils.Html
+import qualified Haddock.Utils.Html as Html
+
+import Control.Exception ( bracket )
+import Control.Monad ( when, unless )
+import Data.Char ( isUpper, toUpper )
+import Data.List ( sortBy )
+import Data.Maybe ( fromJust, isJust, mapMaybe, fromMaybe )
+import Foreign.Marshal.Alloc ( allocaBytes )
+import System.IO ( IOMode(..), hClose, hGetBuf, hPutBuf, openFile )
+import Debug.Trace ( trace )
+import Data.Map ( Map )
+import qualified Data.Map as Map hiding ( Map )
+
+import GHC
+import Name
+import Module
+import PackageConfig ( stringToPackageId )
+import RdrName hiding ( Qual )
+import SrcLoc
+import FastString ( unpackFS )
+import BasicTypes ( IPName(..), Boxity(..) )
+import Type ( Kind )
+import Outputable ( ppr, defaultUserStyle, showSDoc )
+
+-- the base, module and entity URLs for the source code and wiki links.
+type SourceURLs = (Maybe String, Maybe String, Maybe String)
+type WikiURLs = (Maybe String, Maybe String, Maybe String)
+
+-- -----------------------------------------------------------------------------
+-- Generating HTML documentation
+
+ppHtml :: String
+ -> Maybe String -- package
+ -> [HaddockModule]
+ -> FilePath -- destination directory
+ -> Maybe (GHC.HsDoc GHC.RdrName) -- prologue text, maybe
+ -> Maybe String -- the Html Help format (--html-help)
+ -> SourceURLs -- the source URL (--source)
+ -> WikiURLs -- the wiki URL (--wiki)
+ -> Maybe String -- the contents URL (--use-contents)
+ -> Maybe String -- the index URL (--use-index)
+ -> IO ()
+
+ppHtml doctitle maybe_package hmods odir prologue maybe_html_help_format
+ maybe_source_url maybe_wiki_url
+ maybe_contents_url maybe_index_url = do
+ let
+ visible_hmods = filter visible hmods
+ visible i = OptHide `notElem` hmod_options i
+
+ when (not (isJust maybe_contents_url)) $
+ ppHtmlContents odir doctitle maybe_package
+ maybe_html_help_format maybe_index_url maybe_source_url maybe_wiki_url
+ visible_hmods
+ False -- we don't want to display the packages in a single-package contents
+ prologue
+
+ when (not (isJust maybe_index_url)) $
+ ppHtmlIndex odir doctitle maybe_package maybe_html_help_format
+ maybe_contents_url maybe_source_url maybe_wiki_url visible_hmods
+
+ when (not (isJust maybe_contents_url && isJust maybe_index_url)) $
+ ppHtmlHelpFiles doctitle maybe_package hmods odir maybe_html_help_format []
+
+ mapM_ (ppHtmlModule odir doctitle
+ maybe_source_url maybe_wiki_url
+ maybe_contents_url maybe_index_url) visible_hmods
+
+ppHtmlHelpFiles
+ :: String -- doctitle
+ -> Maybe String -- package
+ -> [HaddockModule]
+ -> FilePath -- destination directory
+ -> Maybe String -- the Html Help format (--html-help)
+ -> [FilePath] -- external packages paths
+ -> IO ()
+ppHtmlHelpFiles doctitle maybe_package hmods odir maybe_html_help_format pkg_paths = do
+ let
+ visible_hmods = filter visible hmods
+ visible i = OptHide `notElem` hmod_options i
+
+ -- Generate index and contents page for Html Help if requested
+ case maybe_html_help_format of
+ Nothing -> return ()
+ Just "mshelp" -> ppHHProject odir doctitle maybe_package visible_hmods pkg_paths
+ Just "mshelp2" -> do
+ ppHH2Files odir maybe_package visible_hmods pkg_paths
+ ppHH2Collection odir doctitle maybe_package
+ Just "devhelp" -> ppDevHelpFile odir doctitle maybe_package visible_hmods
+ Just format -> fail ("The "++format++" format is not implemented")
+
+copyFile :: FilePath -> FilePath -> IO ()
+copyFile fromFPath toFPath =
+ (bracket (openFile fromFPath ReadMode) hClose $ \hFrom ->
+ bracket (openFile 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 ()
+copyHtmlBits odir libdir maybe_css = do
+ let
+ libhtmldir = pathJoin [libdir, "html"]
+ css_file = case maybe_css of
+ Nothing -> pathJoin [libhtmldir, cssFile]
+ Just f -> f
+ css_destination = pathJoin [odir, cssFile]
+ copyLibFile f = do
+ copyFile (pathJoin [libhtmldir, f]) (pathJoin [odir, f])
+ copyFile css_file css_destination
+ mapM_ copyLibFile [ iconFile, plusFile, minusFile, jsFile ]
+
+footer :: HtmlTable
+footer =
+ tda [theclass "botbar"] <<
+ ( toHtml "Produced by" <+>
+ (anchor ! [href projectUrl] << toHtml projectName) <+>
+ toHtml ("version " ++ projectVersion)
+ )
+
+srcButton :: SourceURLs -> Maybe HaddockModule -> HtmlTable
+srcButton (Just src_base_url, _, _) Nothing =
+ topButBox (anchor ! [href src_base_url] << toHtml "Source code")
+
+srcButton (_, Just src_module_url, _) (Just hmod) =
+ let url = spliceURL (Just $ hmod_orig_filename hmod)
+ (Just $ hmod_mod hmod) Nothing src_module_url
+ in topButBox (anchor ! [href url] << toHtml "Source code")
+
+srcButton _ _ =
+ Html.emptyTable
+
+spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name -> String -> String
+spliceURL maybe_file maybe_mod maybe_name url = run url
+ where
+ file = fromMaybe "" maybe_file
+ mod = case maybe_mod of
+ Nothing -> ""
+ Just mod -> moduleString mod
+
+ (name, kind) =
+ case maybe_name of
+ Nothing -> ("","")
+ Just n | isValOcc (nameOccName n) -> (escapeStr (getOccString n), "v")
+ | otherwise -> (escapeStr (getOccString n), "t")
+
+ run "" = ""
+ run ('%':'M':rest) = mod ++ run rest
+ run ('%':'F':rest) = file ++ run rest
+ run ('%':'N':rest) = name ++ run rest
+ run ('%':'K':rest) = kind ++ run rest
+
+ run ('%':'{':'M':'O':'D':'U':'L':'E':'}':rest) = mod ++ run rest
+ run ('%':'{':'F':'I':'L':'E':'}':rest) = file ++ run rest
+ run ('%':'{':'N':'A':'M':'E':'}':rest) = name ++ run rest
+ run ('%':'{':'K':'I':'N':'D':'}':rest) = kind ++ run rest
+
+ run ('%':'{':'M':'O':'D':'U':'L':'E':'/':'.':'/':c:'}':rest) =
+ map (\x -> if x == '.' then c else x) mod ++ run rest
+
+ run (c:rest) = c : run rest
+
+wikiButton :: WikiURLs -> Maybe Module -> HtmlTable
+wikiButton (Just wiki_base_url, _, _) Nothing =
+ topButBox (anchor ! [href wiki_base_url] << toHtml "User Comments")
+
+wikiButton (_, Just wiki_module_url, _) (Just mod) =
+ let url = spliceURL Nothing (Just mod) Nothing wiki_module_url
+ in topButBox (anchor ! [href url] << toHtml "User Comments")
+
+wikiButton _ _ =
+ Html.emptyTable
+
+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")
+ where url = case maybe_index_url of
+ Nothing -> indexHtmlFile
+ Just url -> url
+
+simpleHeader :: String -> Maybe String -> Maybe String
+ -> SourceURLs -> WikiURLs -> HtmlTable
+simpleHeader doctitle maybe_contents_url maybe_index_url
+ maybe_source_url maybe_wiki_url =
+ (tda [theclass "topbar"] <<
+ vanillaTable << (
+ (td <<
+ image ! [src "haskell_icon.gif", width "16", height 16, alt " " ]
+ ) <->
+ (tda [theclass "title"] << toHtml doctitle) <->
+ srcButton maybe_source_url Nothing <->
+ wikiButton maybe_wiki_url Nothing <->
+ contentsButton maybe_contents_url <-> indexButton maybe_index_url
+ ))
+
+pageHeader :: String -> HaddockModule -> String
+ -> SourceURLs -> WikiURLs
+ -> Maybe String -> Maybe String -> HtmlTable
+pageHeader mdl hmod doctitle
+ maybe_source_url maybe_wiki_url
+ 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) <->
+ srcButton maybe_source_url (Just hmod) <->
+ wikiButton maybe_wiki_url (Just $ hmod_mod hmod) <->
+ contentsButton maybe_contents_url <->
+ indexButton maybe_index_url
+ )
+ ) </>
+ tda [theclass "modulebar"] <<
+ (vanillaTable << (
+ (td << font ! [size "6"] << toHtml mdl) <->
+ moduleInfo hmod
+ )
+ )
+
+moduleInfo :: HaddockModule -> HtmlTable
+moduleInfo hmod =
+ let
+ info = hmod_info hmod
+
+ doOneEntry :: (String, (GHC.HaddockModInfo GHC.Name) -> Maybe String) -> Maybe HtmlTable
+ doOneEntry (fieldName,field) = case field info of
+ Nothing -> Nothing
+ Just fieldValue ->
+ Just ((tda [theclass "infohead"] << toHtml fieldName)
+ <-> (tda [theclass "infoval"]) << toHtml fieldValue)
+
+ entries :: [HtmlTable]
+ entries = mapMaybe doOneEntry [
+ ("Portability",GHC.hmi_portability),
+ ("Stability",GHC.hmi_stability),
+ ("Maintainer",GHC.hmi_maintainer)
+ ]
+ in
+ case entries of
+ [] -> Html.emptyTable
+ _ -> tda [align "right"] << narrowTable << (foldl1 (</>) entries)
+
+-- ---------------------------------------------------------------------------
+-- Generate the module contents
+
+ppHtmlContents
+ :: FilePath
+ -> String
+ -> Maybe String
+ -> Maybe String
+ -> Maybe String
+ -> SourceURLs
+ -> WikiURLs
+ -> [HaddockModule] -> Bool -> Maybe (GHC.HsDoc GHC.RdrName)
+ -> IO ()
+ppHtmlContents odir doctitle
+ maybe_package maybe_html_help_format maybe_index_url
+ maybe_source_url maybe_wiki_url modules showPkgs prologue = do
+ let tree = mkModuleTree showPkgs
+ [(hmod_mod mod, toDescription mod) | mod <- modules]
+ html =
+ header
+ (documentCharacterEncoding +++
+ thetitle (toHtml doctitle) +++
+ styleSheet +++
+ (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++
+ body << vanillaTable << (
+ simpleHeader doctitle Nothing maybe_index_url
+ maybe_source_url maybe_wiki_url </>
+ ppPrologue doctitle prologue </>
+ ppModuleTree doctitle tree </>
+ s15 </>
+ footer
+ )
+ writeFile (pathJoin [odir, contentsHtmlFile]) (renderHtml html)
+
+ -- Generate contents page for Html Help if requested
+ case maybe_html_help_format of
+ Nothing -> return ()
+ Just "mshelp" -> ppHHContents odir doctitle maybe_package tree
+ Just "mshelp2" -> ppHH2Contents odir doctitle maybe_package tree
+ Just "devhelp" -> return ()
+ Just format -> fail ("The "++format++" format is not implemented")
+
+ppPrologue :: String -> Maybe (GHC.HsDoc GHC.RdrName) -> HtmlTable
+ppPrologue title Nothing = Html.emptyTable
+ppPrologue title (Just doc) =
+ (tda [theclass "section1"] << toHtml title) </>
+ docBox (rdrDocToHtml doc)
+
+ppModuleTree :: String -> [ModuleTree] -> HtmlTable
+ppModuleTree _ ts =
+ tda [theclass "section1"] << toHtml "Modules" </>
+ td << vanillaTable2 << htmlTable
+ where
+ genTable htmlTable id [] = (htmlTable,id)
+ genTable htmlTable id (x:xs) = genTable (htmlTable </> u) id' xs
+ where
+ (u,id') = mkNode [] x 0 id
+
+ (htmlTable,_) = genTable emptyTable 0 ts
+
+mkNode :: [String] -> ModuleTree -> Int -> Int -> (HtmlTable,Int)
+mkNode ss (Node s leaf pkg short ts) depth id = htmlNode
+ where
+ htmlNode = case ts of
+ [] -> (td_pad_w 1.25 depth << htmlModule <-> shortDescr <-> htmlPkg,id)
+ _ -> (td_w depth << (collapsebutton id_s +++ htmlModule) <-> shortDescr <-> htmlPkg </>
+ (td_subtree << sub_tree), id')
+
+ mod_width = 50::Int {-em-}
+
+ td_pad_w pad depth =
+ tda [thestyle ("padding-left: " ++ show pad ++ "em;" ++
+ "width: " ++ show (mod_width - depth*2) ++ "em")]
+
+ td_w depth =
+ tda [thestyle ("width: " ++ show (mod_width - depth*2) ++ "em")]
+
+ td_subtree =
+ tda [thestyle ("padding: 0; padding-left: 2em")]
+
+ shortDescr :: HtmlTable
+ shortDescr = case short of
+ Nothing -> td empty
+ Just doc -> tda [theclass "rdoc"] (origDocToHtml doc)
+
+ htmlModule
+ | leaf = ppModule (mkModule (stringToPackageId pkgName)
+ (mkModuleName mdl)) ""
+ | otherwise = toHtml s
+
+ -- ehm.. TODO: change the ModuleTree type
+ (htmlPkg, pkgName) = case pkg of
+ Nothing -> (td << empty, "")
+ Just p -> (td << toHtml p, p)
+
+ mdl = foldr (++) "" (s' : map ('.':) ss')
+ (s':ss') = reverse (s:ss)
+ -- reconstruct the module name
+
+ id_s = "n:" ++ 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 = collapsed vanillaTable2 id_s htmlTable
+ genSubTree htmlTable id (x:xs) = genSubTree (htmlTable </> u) id' xs
+ where
+ (u,id') = mkNode (s:ss) x (depth+1) id
+
+-- The URL for source and wiki links, and the current module
+type LinksInfo = (SourceURLs, WikiURLs, HaddockModule)
+
+
+-- ---------------------------------------------------------------------------
+-- Generate the index
+
+ppHtmlIndex :: FilePath
+ -> String
+ -> Maybe String
+ -> Maybe String
+ -> Maybe String
+ -> SourceURLs
+ -> WikiURLs
+ -> [HaddockModule]
+ -> IO ()
+ppHtmlIndex odir doctitle maybe_package maybe_html_help_format
+ maybe_contents_url maybe_source_url maybe_wiki_url modules = do
+ let html =
+ header (documentCharacterEncoding +++
+ thetitle (toHtml (doctitle ++ " (Index)")) +++
+ styleSheet) +++
+ body << vanillaTable << (
+ simpleHeader doctitle maybe_contents_url Nothing
+ maybe_source_url maybe_wiki_url </>
+ index_html
+ )
+
+ when split_indices $
+ mapM_ (do_sub_index index) initialChars
+
+ writeFile (pathJoin [odir, indexHtmlFile]) (renderHtml html)
+
+ -- Generate index and contents page for Html Help if requested
+ case maybe_html_help_format of
+ Nothing -> return ()
+ Just "mshelp" -> ppHHIndex odir maybe_package modules
+ Just "mshelp2" -> ppHH2Index odir maybe_package modules
+ Just "devhelp" -> return ()
+ Just format -> fail ("The "++format++" format is not implemented")
+ where
+ split_indices = length index > 50
+
+ index_html
+ | split_indices =
+ tda [theclass "section1"] <<
+ toHtml ("Index") </>
+ indexInitialLetterLinks
+ | otherwise =
+ td << table ! [cellpadding 0, cellspacing 5] <<
+ aboves (map indexElt index)
+
+ indexInitialLetterLinks =
+ td << table ! [cellpadding 0, cellspacing 5] <<
+ besides [ td << anchor ! [href (subIndexHtmlFile c)] <<
+ toHtml [c]
+ | c <- initialChars
+ , any ((==c) . toUpper . head . fst) index ]
+
+ do_sub_index this_ix c
+ = unless (null index_part) $
+ writeFile (pathJoin [odir, subIndexHtmlFile c]) (renderHtml html)
+ where
+ html = header (documentCharacterEncoding +++
+ thetitle (toHtml (doctitle ++ " (Index)")) +++
+ styleSheet) +++
+ body << vanillaTable << (
+ simpleHeader doctitle maybe_contents_url Nothing
+ maybe_source_url maybe_wiki_url </>
+ indexInitialLetterLinks </>
+ tda [theclass "section1"] <<
+ toHtml ("Index (" ++ c:")") </>
+ td << table ! [cellpadding 0, cellspacing 5] <<
+ aboves (map indexElt index_part)
+ )
+
+ index_part = [(n,stuff) | (n,stuff) <- this_ix, toUpper (head n) == c]
+
+ index :: [(String, Map GHC.Name [(Module,Bool)])]
+ index = sortBy cmp (Map.toAscList full_index)
+ where cmp (n1,_) (n2,_) = n1 `compare` n2
+
+ -- for each name (a plain string), we have a number of original HsNames that
+ -- it can refer to, and for each of those we have a list of modules
+ -- that export that entity. Each of the modules exports the entity
+ -- in a visible or invisible way (hence the Bool).
+ full_index :: Map String (Map GHC.Name [(Module,Bool)])
+ full_index = Map.fromListWith (flip (Map.unionWith (++)))
+ (concat (map getHModIndex modules))
+
+ getHModIndex hmod =
+ [ (getOccString name,
+ Map.fromList [(name, [(mdl, name `elem` hmod_visible_exports hmod)])])
+ | name <- hmod_exports hmod ]
+ where mdl = hmod_mod hmod
+
+ indexElt :: (String, Map GHC.Name [(Module,Bool)]) -> HtmlTable
+ indexElt (str, entities) =
+ case Map.toAscList entities of
+ [(nm,entries)] ->
+ tda [ theclass "indexentry" ] << toHtml str <->
+ indexLinks nm entries
+ many_entities ->
+ tda [ theclass "indexentry" ] << toHtml str </>
+ aboves (map doAnnotatedEntity (zip [1..] many_entities))
+
+ doAnnotatedEntity (j,(nm,entries))
+ = tda [ theclass "indexannot" ] <<
+ toHtml (show j) <+> parens (ppAnnot (nameOccName nm)) <->
+ indexLinks nm entries
+
+ ppAnnot n | not (isValOcc n) = toHtml "Type/Class"
+ | isDataOcc n = toHtml "Data Constructor"
+ | otherwise = toHtml "Function"
+
+ indexLinks nm entries =
+ tda [ theclass "indexlinks" ] <<
+ hsep (punctuate comma
+ [ if visible then
+ linkId mod (Just nm) << toHtml (moduleString mod)
+ else
+ toHtml (moduleString mod)
+ | (mod, visible) <- entries ])
+
+ initialChars = [ 'A'..'Z' ] ++ ":!#$%&*+./<=>?@\\^|-~"
+
+-- ---------------------------------------------------------------------------
+-- Generate the HTML page for a module
+
+ppHtmlModule
+ :: FilePath -> String
+ -> SourceURLs -> WikiURLs
+ -> Maybe String -> Maybe String
+ -> HaddockModule -> IO ()
+ppHtmlModule odir doctitle
+ maybe_source_url maybe_wiki_url
+ maybe_contents_url maybe_index_url hmod = do
+ let
+ mod = hmod_mod hmod
+ mdl = moduleString mod
+ html =
+ header (documentCharacterEncoding +++
+ thetitle (toHtml mdl) +++
+ styleSheet +++
+ (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++
+ body << vanillaTable << (
+ pageHeader mdl hmod doctitle
+ maybe_source_url maybe_wiki_url
+ maybe_contents_url maybe_index_url </> s15 </>
+ hmodToHtml maybe_source_url maybe_wiki_url hmod </> s15 </>
+ footer
+ )
+ writeFile (pathJoin [odir, moduleHtmlFile mod]) (renderHtml html)
+
+hmodToHtml :: SourceURLs -> WikiURLs -> HaddockModule -> HtmlTable
+hmodToHtml maybe_source_url maybe_wiki_url hmod
+ = abovesSep s15 (contents: description: synopsis: maybe_doc_hdr: bdy)
+ where
+ docMap = hmod_rn_doc_map hmod
+
+ exports = numberSectionHeadings (hmod_rn_export_items hmod)
+
+ has_doc (ExportDecl _ _ doc _) = isJust doc
+ has_doc (ExportNoDecl _ _ _) = False
+ has_doc (ExportModule _) = False
+ has_doc _ = True
+
+ no_doc_at_all = not (any has_doc exports)
+
+ contents = td << vanillaTable << ppModuleContents exports
+
+ description
+ = case hmod_rn_doc hmod of
+ Nothing -> Html.emptyTable
+ Just doc -> (tda [theclass "section1"] << toHtml "Description") </>
+ docBox (docToHtml doc)
+
+ -- omit the synopsis if there are no documentation annotations at all
+ synopsis
+ | no_doc_at_all = Html.emptyTable
+ | otherwise
+ = (tda [theclass "section1"] << toHtml "Synopsis") </>
+ s15 </>
+ (tda [theclass "body"] << vanillaTable <<
+ abovesSep s8 (map (processExport True linksInfo docMap)
+ (filter forSummary exports))
+ )
+
+ -- if the documentation doesn't begin with a section header, then
+ -- add one ("Documentation").
+ maybe_doc_hdr
+ = case exports of
+ [] -> Html.emptyTable
+ ExportGroup _ _ _ : _ -> Html.emptyTable
+ _ -> tda [ theclass "section1" ] << toHtml "Documentation"
+
+ bdy = map (processExport False linksInfo docMap) exports
+ linksInfo = (maybe_source_url, maybe_wiki_url, hmod)
+
+ppModuleContents :: [ExportItem DocName] -> HtmlTable
+ppModuleContents exports
+ | length sections == 0 = Html.emptyTable
+ | otherwise = tda [theclass "section4"] << bold << toHtml "Contents"
+ </> td << dlist << concatHtml sections
+ where
+ (sections, _leftovers{-should be []-}) = process 0 exports
+
+ process :: Int -> [ExportItem DocName] -> ([Html],[ExportItem DocName])
+ process _ [] = ([], [])
+ process n items@(ExportGroup lev id0 doc : rest)
+ | lev <= n = ( [], items )
+ | otherwise = ( html:secs, rest2 )
+ where
+ html = (dterm << linkedAnchor id0 << docToHtml doc)
+ +++ mk_subsections ssecs
+ (ssecs, rest1) = process lev rest
+ (secs, rest2) = process n rest1
+ process n (_ : rest) = process n rest
+
+ mk_subsections [] = noHtml
+ mk_subsections ss = ddef << dlist << concatHtml ss
+
+-- we need to assign a unique id to each section heading so we can hyperlink
+-- them from the contents:
+numberSectionHeadings :: [ExportItem DocName] -> [ExportItem DocName]
+numberSectionHeadings exports = go 1 exports
+ where go :: Int -> [ExportItem DocName] -> [ExportItem DocName]
+ go _ [] = []
+ go n (ExportGroup lev _ doc : es)
+ = ExportGroup lev (show n) doc : go (n+1) es
+ go n (other:es)
+ = other : go n es
+
+processExport :: Bool -> LinksInfo -> DocMap -> (ExportItem DocName) -> HtmlTable
+processExport _ _ _ (ExportGroup lev id0 doc)
+ = ppDocGroup lev (namedAnchor id0 << docToHtml doc)
+processExport summary links docMap (ExportDecl x decl doc insts)
+ = doDecl summary links x decl doc insts docMap
+processExport summmary _ _ (ExportNoDecl _ y [])
+ = declBox (ppDocName y)
+processExport summmary _ _ (ExportNoDecl _ y subs)
+ = declBox (ppDocName y <+> parenList (map ppDocName subs))
+processExport _ _ _ (ExportDoc doc)
+ = docBox (docToHtml doc)
+processExport _ _ _ (ExportModule mod)
+ = declBox (toHtml "module" <+> ppModule mod "")
+
+forSummary :: (ExportItem DocName) -> Bool
+forSummary (ExportGroup _ _ _) = False
+forSummary (ExportDoc _) = False
+forSummary _ = True
+
+ppDocGroup :: Int -> Html -> HtmlTable
+ppDocGroup lev doc
+ | lev == 1 = tda [ theclass "section1" ] << doc
+ | lev == 2 = tda [ theclass "section2" ] << doc
+ | lev == 3 = tda [ theclass "section3" ] << doc
+ | otherwise = tda [ theclass "section4" ] << doc
+
+declWithDoc :: Bool -> LinksInfo -> SrcSpan -> Name -> Maybe (HsDoc DocName) -> 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 -> LinksInfo -> Name -> LHsDecl DocName ->
+ Maybe (HsDoc DocName) -> [InstHead DocName] -> DocMap -> HtmlTable
+doDecl summary links x (L loc d) mbDoc instances docMap = doDecl d
+ where
+ doDecl (TyClD d) = doTyClD d
+ doDecl (SigD s) = ppSig summary links loc mbDoc s
+ doDecl (ForD d) = ppFor summary links loc mbDoc d
+
+ doTyClD d0@(TyData {}) = ppDataDecl summary links instances x loc mbDoc d0
+ doTyClD d0@(TySynonym {}) = ppTySyn summary links loc mbDoc d0
+ doTyClD d0@(ClassDecl {}) = ppClassDecl summary links instances x loc mbDoc docMap d0
+
+ppSig :: Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) -> Sig DocName -> HtmlTable
+ppSig summary links loc mbDoc (TypeSig lname ltype)
+ | summary || noArgDocs t =
+ declWithDoc summary links loc n mbDoc (ppTypeSig summary n t)
+ | otherwise = topDeclBox links loc n (ppBinder False n) </>
+ (tda [theclass "body"] << vanillaTable << (
+ do_args dcolon t </>
+ (case mbDoc of
+ Just doc -> ndocBox (docToHtml doc)
+ Nothing -> Html.emptyTable)
+ ))
+
+ where
+ t = unLoc ltype
+ NoLink n = unLoc lname
+
+ noLArgDocs (L _ t) = noArgDocs t
+ noArgDocs (HsForAllTy _ _ _ t) = noLArgDocs t
+ noArgDocs (HsFunTy (L _ (HsDocTy _ _)) _) = False
+ noArgDocs (HsFunTy _ r) = noLArgDocs r
+ noArgDocs (HsDocTy _ _) = False
+ noArgDocs _ = True
+
+ do_largs leader (L _ t) = do_args leader t
+ do_args :: Html -> (HsType DocName) -> HtmlTable
+ do_args leader (HsForAllTy Explicit tvs lctxt ltype)
+ = (argBox (
+ leader <+>
+ hsep (keyword "forall" : ppTyVars tvs ++ [dot]) <+>
+ ppLContextNoArrow lctxt)
+ <-> rdocBox noHtml) </>
+ do_largs darrow ltype
+ do_args leader (HsForAllTy Implicit _ lctxt ltype)
+ = (argBox (leader <+> ppLContextNoArrow lctxt)
+ <-> rdocBox noHtml) </>
+ do_largs darrow ltype
+ do_args leader (HsFunTy (L _ (HsDocTy lt ldoc)) r)
+ = (argBox (leader <+> ppLType lt) <-> rdocBox (docToHtml (unLoc ldoc)))
+ </> do_largs arrow r
+ do_args leader (HsFunTy lt r)
+ = (argBox (leader <+> ppLType lt) <-> rdocBox noHtml) </> do_largs arrow r
+ do_args leader (HsDocTy lt ldoc)
+ = (argBox (leader <+> ppLType lt) <-> rdocBox (docToHtml (unLoc ldoc)))
+ do_args leader t
+ = argBox (leader <+> ppType t) <-> rdocBox (noHtml)
+
+ppTyVars tvs = map ppName (tyvarNames tvs)
+
+tyvarNames = map f
+ where f x = let NoLink n = hsTyVarName (unLoc x) in n
+
+ppFor summary links loc mbDoc (ForeignImport lname ltype _)
+ = ppSig summary links loc mbDoc (TypeSig lname ltype)
+ppFor _ _ _ _ _ = error "ppFor"
+
+-- we skip type patterns for now
+ppTySyn summary links loc mbDoc (TySynonym lname ltyvars _ ltype)
+ = declWithDoc summary links loc n mbDoc (
+ hsep ([keyword "type", ppBinder summary n]
+ ++ ppTyVars ltyvars) <+> equals <+> ppLType ltype)
+ where NoLink n = unLoc lname
+
+ppLType (L _ t) = ppType t
+
+ppTypeSig :: Bool -> Name -> (HsType DocName) -> Html
+ppTypeSig summary nm ty = ppBinder summary nm <+> dcolon <+> ppType ty
+
+--------------------------------------------------------------------------------
+-- Contexts
+--------------------------------------------------------------------------------
+
+ppLContext = ppContext . unLoc
+ppLContextNoArrow = ppContextNoArrow . unLoc
+
+ppContextNoArrow :: HsContext DocName -> Html
+ppContextNoArrow [] = empty
+ppContextNoArrow cxt = pp_hs_context (map unLoc cxt)
+
+ppContextNoLocs :: [HsPred DocName] -> Html
+ppContextNoLocs [] = empty
+ppContextNoLocs cxt = pp_hs_context cxt <+> darrow
+
+ppContext :: HsContext DocName -> Html
+ppContext cxt = ppContextNoLocs (map unLoc cxt)
+
+pp_hs_context [] = empty
+pp_hs_context [p] = ppPred p
+pp_hs_context cxt = parenList (map ppPred cxt)
+
+ppLPred = ppPred . unLoc
+
+ppPred (HsClassP n ts) = ppDocName n <+> hsep (map ppLType ts)
+-- TODO: find out what happened to the Dupable/Linear distinction
+ppPred (HsIParam (IPName n) t)
+ = toHtml "?" +++ ppDocName n <+> dcolon <+> ppLType t
+
+-- -----------------------------------------------------------------------------
+-- Class declarations
+
+ppClassHdr summ (L _ []) n tvs fds =
+ keyword "class"
+ <+> ppBinder summ n <+> hsep (ppTyVars tvs)
+ <+> ppFds fds
+ppClassHdr summ lctxt n tvs fds =
+ keyword "class" <+> ppLContext lctxt
+ <+> ppBinder summ n <+> hsep (ppTyVars tvs)
+ <+> ppFds fds
+
+ppFds fds =
+ if null fds then noHtml else
+ char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))
+ where
+ fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> toHtml "->" <+>
+ hsep (map ppDocName vars2)
+
+ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> DocMap -> HtmlTable
+ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc docMap =
+ if null sigs && null ats
+ 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 ([ ppAT summary at | L _ at <- ats ] ++
+ [ ppSig summary links loc mbDoc sig
+ | L _ sig@(TypeSig (L _ (NoLink n)) ty) <- sigs, let mbDoc = Map.lookup n docMap ])
+ )
+ where
+ hdr = ppClassHdr summary lctxt nm tvs fds
+ NoLink nm = unLoc lname
+
+ ppAT summary at = case at of
+ TyData {} -> topDeclBox links loc nm (ppDataHeader summary at)
+ _ -> error "associated type synonyms or type families not supported yet"
+
+-- we skip ATs for now
+ppClassDecl :: Ord key => Bool -> LinksInfo -> [InstHead DocName] -> key -> SrcSpan ->
+ Maybe (HsDoc DocName) -> DocMap -> TyClDecl DocName ->
+ HtmlTable
+ppClassDecl summary links instances orig_c loc mbDoc docMap
+ decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ _ _)
+ | summary = ppShortClassDecl summary links decl loc docMap
+ | otherwise
+ = classheader </>
+ tda [theclass "body"] << vanillaTable << (
+ classdoc </> methodsBit </> instancesBit
+ )
+ where
+ classheader
+ | null lsigs = topDeclBox links loc nm hdr
+ | otherwise = topDeclBox links loc nm (hdr <+> keyword "where")
+
+ NoLink nm = unLoc lname
+ ctxt = unLoc lctxt
+
+ hdr = ppClassHdr summary lctxt nm ltyvars lfds
+
+ classdoc = case mbDoc of
+ Nothing -> Html.emptyTable
+ Just d -> ndocBox (docToHtml d)
+
+ methodsBit
+ | null lsigs = Html.emptyTable
+ | otherwise =
+ s8 </> methHdr </>
+ tda [theclass "body"] << vanillaTable << (
+ abovesSep s8 [ ppSig summary links loc mbDoc sig
+ | L _ sig@(TypeSig n _) <- lsigs,
+ let mbDoc = Map.lookup (orig n) docMap ]
+ )
+
+ instId = collapseId nm
+ instancesBit
+ | null instances = Html.emptyTable
+ | otherwise
+ = s8 </> instHdr instId </>
+ tda [theclass "body"] <<
+ collapsed thediv instId (
+ spacedTable1 << (
+ aboves (map (declBox . ppInstHead) instances)
+ ))
+
+ppInstHead :: InstHead DocName -> Html
+ppInstHead ([], n, ts) = ppAsst n ts
+ppInstHead (ctxt, n, ts) = ppContextNoLocs ctxt <+> ppAsst n ts
+
+ppAsst n ts = ppDocName n <+> hsep (map ppParendType ts)
+
+-- -----------------------------------------------------------------------------
+-- Data & newtype declarations
+
+orig (L _ (NoLink name)) = name
+orig _ = error "orig"
+
+-- TODO: print contexts
+ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan ->
+ Maybe (HsDoc DocName) -> TyClDecl DocName -> Html
+ppShortDataDecl summary links loc mbDoc dataDecl
+
+ | [lcon] <- cons, ResTyH98 <- resTy =
+ ppDataHeader summary dataDecl
+ <+> equals <+> ppShortConstr summary (unLoc lcon)
+
+ | [] <- cons = ppDataHeader summary dataDecl
+
+ | otherwise = vanillaTable << (
+ case resTy of
+ ResTyH98 -> dataHeader </>
+ tda [theclass "body"] << vanillaTable << (
+ aboves (zipWith doConstr ('=':repeat '|') cons)
+ )
+ ResTyGADT _ -> dataHeader </>
+ tda [theclass "body"] << vanillaTable << (
+ aboves (map doGADTConstr cons)
+ )
+ )
+
+ where
+ dataHeader =
+ (if summary then declBox else topDeclBox links loc name)
+ ((ppDataHeader summary dataDecl) <+>
+ case resTy of ResTyGADT _ -> keyword "where"; _ -> empty)
+
+ doConstr c con = declBox (toHtml [c] <+> ppShortConstr summary (unLoc con))
+ doGADTConstr con = declBox (ppShortConstr summary (unLoc con))
+
+ name = orig (tcdLName dataDecl)
+ context = unLoc (tcdCtxt dataDecl)
+ newOrData = tcdND dataDecl
+ tyVars = tyvarNames (tcdTyVars dataDecl)
+ mbKSig = tcdKindSig dataDecl
+ cons = tcdCons dataDecl
+ resTy = (con_res . unLoc . head) cons
+
+ppDataDecl :: Ord key => Bool -> LinksInfo -> [InstHead DocName] -> key ->
+ SrcSpan -> Maybe (HsDoc DocName) -> TyClDecl DocName -> HtmlTable
+ppDataDecl summary links instances x loc mbDoc dataDecl
+
+ | summary = declWithDoc summary links loc name mbDoc
+ (ppShortDataDecl summary links loc mbDoc dataDecl)
+
+ | otherwise = dataHeader </>
+ tda [theclass "body"] << vanillaTable << (
+ datadoc </>
+ constrBit </>
+ instancesBit
+ )
+
+ where
+ name = orig (tcdLName dataDecl)
+ context = unLoc (tcdCtxt dataDecl)
+ newOrData = tcdND dataDecl
+ tyVars = tyvarNames (tcdTyVars dataDecl)
+ mbKSig = tcdKindSig dataDecl
+ cons = tcdCons dataDecl
+ resTy = (con_res . unLoc . head) cons
+
+ dataHeader =
+ (if summary then declBox else topDeclBox links loc name)
+ ((ppDataHeader summary dataDecl) <+> whereBit)
+
+ whereBit
+ | null cons = empty
+ | otherwise = case resTy of
+ ResTyGADT _ -> keyword "where"
+ _ -> empty
+
+ constrTable
+ | any isRecCon cons = spacedTable5
+ | otherwise = spacedTable1
+
+ datadoc = case mbDoc of
+ Just doc -> ndocBox (docToHtml doc)
+ Nothing -> Html.emptyTable
+
+ constrBit
+ | null cons = Html.emptyTable
+ | otherwise = constrHdr </> (
+ tda [theclass "body"] << constrTable <<
+ aboves (map ppSideBySideConstr cons)
+ )
+
+ instId = collapseId name
+
+ instancesBit
+ | null instances = Html.emptyTable
+ | otherwise
+ = instHdr instId </>
+ tda [theclass "body"] <<
+ collapsed thediv instId (
+ spacedTable1 << (
+ aboves (map (declBox . ppInstHead) instances)
+ )
+ )
+
+isRecCon lcon = case con_details (unLoc lcon) of
+ RecCon _ -> True
+ _ -> False
+
+ppShortConstr :: Bool -> ConDecl DocName -> Html
+ppShortConstr summary con = case con_res con of
+
+ ResTyH98 -> case con_details con of
+ PrefixCon args -> header +++ hsep (ppBinder summary name : map ppLType args)
+ RecCon fields -> header +++ ppBinder summary name <+>
+ braces (vanillaTable << aboves (map (ppShortField summary) fields))
+ InfixCon arg1 arg2 -> header +++
+ hsep [ppLType arg1, ppBinder summary name, ppLType arg2]
+
+ ResTyGADT resTy -> case con_details con of
+ PrefixCon args -> doGADTCon args resTy
+ RecCon _ -> error "GADT records not suported"
+ InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy
+
+ where
+ doGADTCon args resTy = ppBinder summary name <+> dcolon <+> hsep [
+ ppForAll forall ltvs lcontext,
+ ppLType (foldr mkFunTy resTy args) ]
+
+ header = ppConstrHdr forall tyVars context
+ name = orig (con_name con)
+ ltvs = con_qvars con
+ tyVars = tyvarNames ltvs
+ lcontext = con_cxt con
+ context = unLoc (con_cxt con)
+ forall = con_explicit con
+ mkFunTy a b = noLoc (HsFunTy a b)
+
+ppConstrHdr :: HsExplicitForAll -> [Name] -> HsContext DocName -> Html
+ppConstrHdr forall tvs ctxt
+ = (if null tvs then noHtml else ppForall)
+ +++
+ (if null ctxt then noHtml else ppContext ctxt <+> toHtml "=> ")
+ where
+ ppForall = case forall of
+ Explicit -> keyword "forall" <+> hsep (map ppName tvs) <+> toHtml ". "
+ Implicit -> empty
+
+ppSideBySideConstr :: LConDecl DocName -> HtmlTable
+ppSideBySideConstr (L _ con) = case con_res con of
+
+ ResTyH98 -> case con_details con of
+
+ PrefixCon args ->
+ argBox (hsep ((header +++ ppBinder False name) : map ppLType args))
+ <-> maybeRDocBox mbLDoc
+
+ RecCon fields ->
+ argBox (header +++ ppBinder False name) <->
+ maybeRDocBox mbLDoc </>
+ (tda [theclass "body"] << spacedTable1 <<
+ aboves (map ppSideBySideField fields))
+
+ InfixCon arg1 arg2 ->
+ argBox (hsep [header+++ppLType arg1, ppBinder False name, ppLType arg2])
+ <-> maybeRDocBox mbLDoc
+
+ ResTyGADT resTy -> case con_details con of
+ PrefixCon args -> doGADTCon args resTy
+ RecCon _ -> error "GADT records not supported"
+ InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy
+
+ where
+ doGADTCon args resTy = argBox (ppBinder False name <+> dcolon <+> hsep [
+ ppForAll forall ltvs (con_cxt con),
+ ppLType (foldr mkFunTy resTy args) ]
+ ) <-> maybeRDocBox mbLDoc
+
+
+ header = ppConstrHdr forall tyVars context
+ name = orig (con_name con)
+ ltvs = con_qvars con
+ tyVars = tyvarNames (con_qvars con)
+ context = unLoc (con_cxt con)
+ forall = con_explicit con
+ mbLDoc = con_doc con
+ mkFunTy a b = noLoc (HsFunTy a b)
+
+ppSideBySideField :: HsRecField DocName (LHsType DocName) -> HtmlTable
+ppSideBySideField (HsRecField lname ltype mbLDoc) =
+ argBox (ppBinder False (orig lname)
+ <+> dcolon <+> ppLType ltype) <->
+ maybeRDocBox mbLDoc
+
+{-
+ppHsFullConstr :: HsConDecl -> Html
+ppHsFullConstr (HsConDecl _ nm tvs ctxt typeList doc) =
+ declWithDoc False doc (
+ hsep ((ppHsConstrHdr tvs ctxt +++
+ ppHsBinder False nm) : map ppHsBangType typeList)
+ )
+ppHsFullConstr (HsRecDecl _ nm tvs ctxt fields doc) =
+ td << vanillaTable << (
+ case doc of
+ Nothing -> aboves [hdr, fields_html]
+ Just _ -> aboves [hdr, constr_doc, fields_html]
+ )
+
+ where hdr = declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm)
+
+ constr_doc
+ | isJust doc = docBox (docToHtml (fromJust doc))
+ | otherwise = Html.emptyTable
+
+ fields_html =
+ td <<
+ table ! [width "100%", cellpadding 0, cellspacing 8] << (
+ aboves (map ppFullField (concat (map expandField fields)))
+ )
+-}
+
+ppShortField :: Bool -> HsRecField DocName (LHsType DocName)-> HtmlTable
+ppShortField summary (HsRecField lname ltype mbLDoc)
+ = tda [theclass "recfield"] << (
+ ppBinder summary (orig lname)
+ <+> dcolon <+> ppLType ltype
+ )
+
+{-
+ppFullField :: HsFieldDecl -> Html
+ppFullField (HsFieldDecl [n] ty doc)
+ = declWithDoc False doc (
+ ppHsBinder False n <+> dcolon <+> ppHsBangType ty
+ )
+ppFullField _ = error "ppFullField"
+
+expandField :: HsFieldDecl -> [HsFieldDecl]
+expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ]
+-}
+
+-- | Print the LHS of a data/newtype declaration.
+-- Currently doesn't handle 'data instance' decls or kind signatures
+ppDataHeader :: Bool -> TyClDecl DocName -> Html
+ppDataHeader summary decl
+ | not (isDataDecl decl) = error "ppDataHeader: illegal argument"
+ | otherwise =
+ -- newtype or data
+ (if tcdND decl == NewType then keyword "newtype" else keyword "data") <+>
+ -- context
+ ppLContext (tcdCtxt decl) <+>
+ -- T a b c ..., or a :+: b
+ (if isConSym name
+ then ppName (tyvars!!0) <+> ppBinder summary name <+> ppName (tyvars!!1)
+ else ppBinder summary name <+> hsep (map ppName tyvars))
+ where
+ tyvars = tyvarNames $ tcdTyVars decl
+ name = orig $ tcdLName decl
+
+-- ----------------------------------------------------------------------------
+-- Types and contexts
+
+ppKind k = toHtml $ showSDoc (ppr k)
+
+{-
+ppForAll Implicit _ lctxt = ppCtxtPart lctxt
+ppForAll Explicit ltvs lctxt =
+ hsep (keyword "forall" : ppTyVars ltvs ++ [dot]) <+> ppCtxtPart lctxt
+-}
+
+ppBang HsStrict = toHtml "!"
+ppBang HsUnbox = toHtml "!!"
+
+tupleParens Boxed = parenList
+tupleParens Unboxed = ubxParenList
+{-
+ppType :: HsType DocName -> Html
+ppType t = case t of
+ t@(HsForAllTy expl ltvs lcontext ltype) -> ppForAllTy t <+> ppLType ltype
+ HsTyVar n -> ppDocName n
+ HsBangTy HsStrict lt -> toHtml "!" <+> ppLType lt
+ HsBangTy HsUnbox lt -> toHtml "!!" <+> ppLType lt
+ HsAppTy a b -> ppLType a <+> ppLType b
+ HsFunTy a b -> hsep [ppLType a, toHtml "->", ppLType b]
+ HsListTy t -> brackets $ ppLType t
+ HsPArrTy t -> toHtml "[:" +++ ppLType t +++ toHtml ":]"
+ HsTupleTy Boxed ts -> parenList $ map ppLType ts
+ HsTupleTy Unboxed ts -> ubxParenList $ map ppLType ts
+ HsOpTy a n b -> ppLType a <+> ppLDocName n <+> ppLType b
+ HsParTy t -> parens $ ppLType t
+ HsNumTy n -> toHtml (show n)
+ HsPredTy p -> ppPred p
+ HsKindSig t k -> hsep [ppLType t, dcolon, ppKind k]
+ HsSpliceTy _ -> error "ppType"
+ HsDocTy t _ -> ppLType t
+-}
+--------------------------------------------------------------------------------
+-- Rendering of HsType
+--------------------------------------------------------------------------------
+
+pREC_TOP = (0 :: Int) -- type in ParseIface.y in GHC
+pREC_FUN = (1 :: Int) -- btype in ParseIface.y in GHC
+ -- Used for LH arg of (->)
+pREC_OP = (2 :: Int) -- Used for arg of any infix operator
+ -- (we don't keep their fixities around)
+pREC_CON = (3 :: Int) -- Used for arg of type applicn:
+ -- always parenthesise unless atomic
+
+maybeParen :: Int -- Precedence of context
+ -> Int -- Precedence of top-level operator
+ -> Html -> Html -- Wrap in parens if (ctxt >= op)
+maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p
+ | otherwise = p
+
+ppType ty = ppr_mono_ty pREC_TOP (prepare ty)
+ppParendType ty = ppr_mono_ty pREC_CON ty
+
+-- Before printing a type
+-- (a) Remove outermost HsParTy parens
+-- (b) Drop top-level for-all type variables in user style
+-- since they are implicit in Haskell
+prepare (HsParTy ty) = prepare (unLoc ty)
+prepare ty = ty
+
+ppForAll exp tvs cxt
+ | show_forall = forall_part <+> ppLContext cxt
+ | otherwise = ppLContext cxt
+ where
+ show_forall = not (null tvs) && is_explicit
+ is_explicit = case exp of {Explicit -> True; Implicit -> False}
+ forall_part = hsep (keyword "forall" : ppTyVars tvs) +++ dot
+
+ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
+
+ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty)
+ = maybeParen ctxt_prec pREC_FUN $
+ hsep [ppForAll exp tvs ctxt, ppr_mono_lty pREC_TOP ty]
+
+-- gaw 2004
+ppr_mono_ty ctxt_prec (HsBangTy b ty) = ppBang b +++ ppLType ty
+ppr_mono_ty ctxt_prec (HsTyVar name) = ppDocName name
+ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) = ppr_fun_ty ctxt_prec ty1 ty2
+ppr_mono_ty ctxt_prec (HsTupleTy con tys) = tupleParens con (map ppLType tys)
+ppr_mono_ty ctxt_prec (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> ppKind kind)
+ppr_mono_ty ctxt_prec (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty)
+ppr_mono_ty ctxt_prec (HsPArrTy ty) = pabrackets (ppr_mono_lty pREC_TOP ty)
+ppr_mono_ty ctxt_prec (HsPredTy pred) = parens (ppPred pred)
+ppr_mono_ty ctxt_prec (HsNumTy n) = toHtml (show n) -- generics only
+ppr_mono_ty ctxt_prec (HsSpliceTy s) = error "ppr_mono_ty-haddock"
+
+ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty)
+ = maybeParen ctxt_prec pREC_CON $
+ hsep [ppr_mono_lty pREC_FUN fun_ty, ppr_mono_lty pREC_CON arg_ty]
+
+ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2)
+ = maybeParen ctxt_prec pREC_OP $
+ ppr_mono_lty pREC_OP ty1 <+> ppLDocName op <+> ppr_mono_lty pREC_OP ty2
+
+ppr_mono_ty ctxt_prec (HsParTy ty)
+ = parens (ppr_mono_lty pREC_TOP ty)
+
+ppr_mono_ty ctxt_prec (HsDocTy ty doc)
+ = ppLType ty
+
+ppr_fun_ty ctxt_prec ty1 ty2
+ = let p1 = ppr_mono_lty pREC_FUN ty1
+ p2 = ppr_mono_lty pREC_TOP ty2
+ in
+ maybeParen ctxt_prec pREC_FUN $
+ hsep [p1, arrow <+> p2]
+
+-- ----------------------------------------------------------------------------
+-- Names
+
+ppOccName :: OccName -> Html
+ppOccName name = toHtml $ occNameString name
+
+ppRdrName :: RdrName -> Html
+ppRdrName = ppOccName . rdrNameOcc
+
+ppLDocName (L _ d) = ppDocName d
+
+ppDocName :: DocName -> Html
+ppDocName (Link name) = linkId (nameModule name) (Just name) << ppName name
+ppDocName (NoLink name) = toHtml (getOccString name)
+
+linkTarget :: Name -> Html
+linkTarget name = namedAnchor (anchorNameStr name) << toHtml ""
+
+ppName :: Name -> Html
+ppName name = toHtml (getOccString name)
+
+ppBinder :: Bool -> Name -> Html
+-- The Bool indicates whether we are generating the summary, in which case
+-- the binder will be a link to the full definition.
+ppBinder True nm = linkedAnchor (anchorNameStr nm) << ppBinder' nm
+ppBinder False nm = linkTarget nm +++ bold << ppBinder' nm
+
+ppBinder' :: Name -> Html
+ppBinder' name
+ | isVarSym name = parens $ toHtml (getOccString name)
+ | otherwise = toHtml (getOccString name)
+
+linkId :: Module -> Maybe Name -> Html -> Html
+linkId mod mbName = anchor ! [href hr]
+ where
+ hr = case mbName of
+ Nothing -> moduleHtmlFile mod
+ Just name -> nameHtmlRef mod name
+
+ppModule :: Module -> String -> Html
+ppModule mod ref = anchor ! [href ((moduleHtmlFile mod) ++ ref)]
+ << toHtml (moduleString mod)
+
+-- -----------------------------------------------------------------------------
+-- * Doc Markup
+
+parHtmlMarkup :: (a -> Html) -> DocMarkup a Html
+parHtmlMarkup ppId = Markup {
+ markupParagraph = paragraph,
+ markupEmpty = toHtml "",
+ markupString = toHtml,
+ markupAppend = (+++),
+ markupIdentifier = tt . ppId . head,
+ markupModule = \m -> ppModule (mkModuleNoPkg m) "",
+ markupEmphasis = emphasize . toHtml,
+ 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
+
+htmlMarkup = parHtmlMarkup ppDocName
+htmlOrigMarkup = parHtmlMarkup ppName
+htmlRdrMarkup = parHtmlMarkup ppRdrName
+
+-- If the doc is a single paragraph, don't surround it with <P> (this causes
+-- ugly extra whitespace with some browsers).
+docToHtml :: GHC.HsDoc DocName -> Html
+docToHtml doc = markup htmlMarkup (unParagraph (markup htmlCleanup doc))
+
+origDocToHtml :: GHC.HsDoc GHC.Name -> Html
+origDocToHtml doc = markup htmlOrigMarkup (unParagraph (markup htmlCleanup doc))
+
+rdrDocToHtml doc = markup htmlRdrMarkup (unParagraph (markup htmlCleanup doc))
+
+-- If there is a single paragraph, then surrounding it with <P>..</P>
+-- can add too much whitespace in some browsers (eg. IE). However if
+-- we have multiple paragraphs, then we want the extra whitespace to
+-- separate them. So we catch the single paragraph case and transform it
+-- here.
+unParagraph (GHC.DocParagraph d) = d
+--NO: This eliminates line breaks in the code block: (SDM, 6/5/2003)
+--unParagraph (DocCodeBlock d) = (DocMonospaced d)
+unParagraph doc = doc
+
+htmlCleanup :: DocMarkup a (GHC.HsDoc a)
+htmlCleanup = idMarkup {
+ markupUnorderedList = GHC.DocUnorderedList . map unParagraph,
+ markupOrderedList = GHC.DocOrderedList . map unParagraph
+ }
+
+-- -----------------------------------------------------------------------------
+-- * Misc
+
+hsep :: [Html] -> Html
+hsep [] = noHtml
+hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls
+
+infixr 8 <+>
+(<+>) :: Html -> Html -> Html
+a <+> b = Html (getHtmlElements (toHtml a) ++ HtmlString " ": getHtmlElements (toHtml b))
+
+keyword :: String -> Html
+keyword s = thespan ! [theclass "keyword"] << toHtml s
+
+equals, comma :: Html
+equals = char '='
+comma = char ','
+
+char :: Char -> Html
+char c = toHtml [c]
+
+empty :: Html
+empty = noHtml
+
+parens, brackets, braces :: Html -> Html
+parens h = char '(' +++ h +++ char ')'
+brackets h = char '[' +++ h +++ char ']'
+pabrackets h = toHtml "[:" +++ h +++ toHtml ":]"
+braces h = char '{' +++ h +++ char '}'
+
+punctuate :: Html -> [Html] -> [Html]
+punctuate _ [] = []
+punctuate h (d0:ds) = go d0 ds
+ where
+ go d [] = [d]
+ go d (e:es) = (d +++ h) : go e es
+
+abovesSep :: HtmlTable -> [HtmlTable] -> HtmlTable
+abovesSep _ [] = Html.emptyTable
+abovesSep h (d0:ds) = go d0 ds
+ where
+ go d [] = d
+ go d (e:es) = d </> h </> go e es
+
+parenList :: [Html] -> Html
+parenList = parens . hsep . punctuate comma
+
+ubxParenList :: [Html] -> Html
+ubxParenList = ubxparens . hsep . punctuate comma
+
+ubxparens :: Html -> Html
+ubxparens h = toHtml "(#" +++ h +++ toHtml "#)"
+
+{-
+text :: Html
+text = strAttr "TEXT"
+-}
+
+-- a box for displaying code
+declBox :: Html -> HtmlTable
+declBox html = tda [theclass "decl"] << html
+
+-- a box for top level documented names
+-- it adds a source and wiki link at the right hand side of the box
+topDeclBox :: LinksInfo -> SrcSpan -> Name -> Html -> HtmlTable
+topDeclBox ((_,_,Nothing), (_,_,Nothing), _) _ _ html = declBox html
+topDeclBox ((_,_,maybe_source_url), (_,_,maybe_wiki_url), hmod)
+ loc name html =
+ tda [theclass "topdecl"] <<
+ ( table ! [theclass "declbar"] <<
+ ((tda [theclass "declname"] << html)
+ <-> srcLink
+ <-> wikiLink)
+ )
+ where srcLink =
+ case maybe_source_url of
+ Nothing -> Html.emptyTable
+ Just url -> tda [theclass "declbut"] <<
+ let url' = spliceURL (Just fname) (Just mod)
+ (Just name) url
+ in anchor ! [href url'] << toHtml "Source"
+ wikiLink =
+ case maybe_wiki_url of
+ Nothing -> Html.emptyTable
+ Just url -> tda [theclass "declbut"] <<
+ let url' = spliceURL (Just fname) (Just mod)
+ (Just name) url
+ in anchor ! [href url'] << toHtml "Comments"
+
+ mod = hmod_mod hmod
+ fname = unpackFS (srcSpanFile loc)
+
+-- 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
+-- in a declBox.
+argBox :: Html -> HtmlTable
+argBox html = tda [theclass "arg"] << html
+
+-- a box for displaying documentation,
+-- indented and with a little padding at the top
+docBox :: Html -> HtmlTable
+docBox html = tda [theclass "doc"] << html
+
+-- a box for displaying documentation, not indented.
+ndocBox :: Html -> HtmlTable
+ndocBox html = tda [theclass "ndoc"] << html
+
+-- a box for displaying documentation, padded on the left a little
+rdocBox :: Html -> HtmlTable
+rdocBox html = tda [theclass "rdoc"] << html
+
+maybeRDocBox :: Maybe (GHC.LHsDoc DocName) -> HtmlTable
+maybeRDocBox Nothing = rdocBox (noHtml)
+maybeRDocBox (Just ldoc) = rdocBox (docToHtml (unLoc ldoc))
+
+-- a box for the buttons at the top of the page
+topButBox :: Html -> HtmlTable
+topButBox html = tda [theclass "topbut"] << html
+
+-- a vanilla table has width 100%, no border, no padding, no spacing
+-- a narrow table is the same but without width 100%.
+vanillaTable, narrowTable :: Html -> Html
+vanillaTable = table ! [theclass "vanilla", cellspacing 0, cellpadding 0]
+vanillaTable2 = table ! [theclass "vanilla2", cellspacing 0, cellpadding 0]
+narrowTable = table ! [theclass "narrow", cellspacing 0, cellpadding 0]
+
+spacedTable1, spacedTable5 :: Html -> Html
+spacedTable1 = table ! [theclass "vanilla", cellspacing 1, cellpadding 0]
+spacedTable5 = table ! [theclass "vanilla", cellspacing 5, cellpadding 0]
+
+constrHdr, methHdr :: HtmlTable
+constrHdr = tda [ theclass "section4" ] << toHtml "Constructors"
+methHdr = tda [ theclass "section4" ] << toHtml "Methods"
+
+instHdr :: String -> HtmlTable
+instHdr id =
+ tda [ theclass "section4" ] << (collapsebutton id +++ toHtml " Instances")
+
+dcolon, arrow, darrow :: Html
+dcolon = toHtml "::"
+arrow = toHtml "->"
+darrow = toHtml "=>"
+dot = toHtml "."
+
+s8, s15 :: HtmlTable
+s8 = tda [ theclass "s8" ] << noHtml
+s15 = tda [ theclass "s15" ] << noHtml
+
+namedAnchor :: String -> Html -> Html
+namedAnchor n = anchor ! [name (escapeStr n)]
+
+--
+-- A section of HTML which is collapsible via a +/- button.
+--
+
+-- TODO: Currently the initial state is non-collapsed. Change the 'minusFile'
+-- below to a 'plusFile' and the 'display:block;' to a 'display:none;' when we
+-- use cookies from JavaScript to have a more persistent state.
+
+collapsebutton :: String -> Html
+collapsebutton id =
+ image ! [ src minusFile, theclass "coll", onclick ("toggle(this,'" ++ id ++ "')"), alt "show/hide" ]
+
+collapsed :: (HTML a) => (Html -> Html) -> String -> a -> Html
+collapsed fn id html =
+ fn ! [identifier id, thestyle "display:block;"] << 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 :: Name -> String
+collapseId nm = "i:" ++ escapeStr (getOccString nm)
+
+linkedAnchor :: String -> Html -> Html
+linkedAnchor frag = anchor ! [href hr]
+ where hr | null frag = ""
+ | otherwise = '#': escapeStr frag
+
+documentCharacterEncoding :: Html
+documentCharacterEncoding =
+ meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"]
+
+styleSheet :: Html
+styleSheet =
+ thelink ! [href cssFile, rel "stylesheet", thetype "text/css"]
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index becd40df..7964a3a5 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -4,7 +4,7 @@ module Haddock.InterfaceFile (
readInterfaceFile
) where
-import HaddockTypes
+import Haddock.Types
import Haddock.Exception
import Binary
diff --git a/src/Haddock/ModuleTree.hs b/src/Haddock/ModuleTree.hs
new file mode 100644
index 00000000..e4c72880
--- /dev/null
+++ b/src/Haddock/ModuleTree.hs
@@ -0,0 +1,38 @@
+module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where
+
+import Haddock.Types ( DocName )
+import GHC ( HsDoc, Name )
+import Module ( Module, moduleNameString, moduleName, modulePackageId )
+import PackageConfig ( packageIdString )
+
+data ModuleTree = Node String Bool (Maybe String) (Maybe (HsDoc Name)) [ModuleTree]
+
+mkModuleTree :: Bool -> [(Module, Maybe (HsDoc Name))] -> [ModuleTree]
+mkModuleTree showPkgs mods =
+ foldr fn [] [ (splitModule mod, modPkg mod, short) | (mod, short) <- mods ]
+ where
+ modPkg mod | showPkgs = Just (packageIdString (modulePackageId mod))
+ | otherwise = Nothing
+ fn (mod,pkg,short) trees = addToTrees mod pkg short trees
+
+addToTrees :: [String] -> Maybe String -> Maybe (HsDoc Name) -> [ModuleTree] -> [ModuleTree]
+addToTrees [] pkg short ts = ts
+addToTrees ss pkg short [] = mkSubTree ss pkg short
+addToTrees (s1:ss) pkg short (t@(Node s2 leaf node_pkg node_short subs) : ts)
+ | s1 > s2 = t : addToTrees (s1:ss) pkg short ts
+ | s1 == s2 = Node s2 (leaf || null ss) this_pkg this_short (addToTrees ss pkg short subs) : ts
+ | otherwise = mkSubTree (s1:ss) pkg short ++ t : ts
+ where
+ this_pkg = if null ss then pkg else node_pkg
+ this_short = if null ss then short else node_short
+
+mkSubTree :: [String] -> Maybe String -> Maybe (HsDoc Name) -> [ModuleTree]
+mkSubTree [] pkg short = []
+mkSubTree [s] pkg short = [Node s True pkg short []]
+mkSubTree (s:ss) pkg short = [Node s (null ss) Nothing Nothing (mkSubTree ss pkg short)]
+
+splitModule :: Module -> [String]
+splitModule mod = split (moduleNameString (moduleName mod))
+ where split mod0 = case break (== '.') mod0 of
+ (s1, '.':s2) -> s1 : split s2
+ (s1, _) -> [s1]
diff --git a/src/Haddock/Rename.hs b/src/Haddock/Rename.hs
new file mode 100644
index 00000000..7e12a412
--- /dev/null
+++ b/src/Haddock/Rename.hs
@@ -0,0 +1,320 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+
+module Haddock.Rename (
+ runRnFM, -- the monad (instance of Monad)
+ renameDoc, renameMaybeDoc, renameExportItems,
+) where
+
+import Haddock.Types
+
+import GHC
+import BasicTypes
+import SrcLoc
+import Bag ( emptyBag )
+
+import Data.Map ( Map )
+import qualified Data.Map as Map hiding ( Map )
+import Prelude hiding ( mapM )
+import Data.Traversable ( mapM )
+
+-- -----------------------------------------------------------------------------
+-- Monad for renaming
+
+-- The monad does two things for us: it passes around the environment for
+-- renaming, and it returns a list of names which couldn't be found in
+-- the environment.
+
+newtype GenRnM n a =
+ RnM { unRn :: (n -> (Bool, DocName)) -- name lookup function
+ -> (a,[n])
+ }
+
+type RnM a = GenRnM Name a
+
+instance Monad (GenRnM n) where
+ (>>=) = thenRn
+ return = returnRn
+
+returnRn :: a -> GenRnM n a
+returnRn a = RnM (\_ -> (a,[]))
+thenRn :: GenRnM n a -> (a -> GenRnM n b) -> GenRnM n b
+m `thenRn` k = RnM (\lkp -> case unRn m lkp of
+ (a,out1) -> case unRn (k a) lkp of
+ (b,out2) -> (b,out1++out2))
+
+getLookupRn :: RnM (Name -> (Bool, DocName))
+getLookupRn = RnM (\lkp -> (lkp,[]))
+outRn :: Name -> RnM ()
+outRn name = RnM (\_ -> ((),[name]))
+
+lookupRn :: (DocName -> a) -> Name -> RnM a
+lookupRn and_then name = do
+ lkp <- getLookupRn
+ case lkp name of
+ (False,maps_to) -> do outRn name; return (and_then maps_to)
+ (True, maps_to) -> return (and_then maps_to)
+
+runRnFM :: Map Name Name -> RnM a -> (a,[Name])
+runRnFM env rn = unRn rn lkp
+ where lkp n = case Map.lookup n env of
+ Nothing -> (False, NoLink n)
+ Just q -> (True, Link q)
+
+runRn :: (n -> (Bool,DocName)) -> GenRnM n a -> (a,[n])
+runRn lkp rn = unRn rn lkp
+
+-- -----------------------------------------------------------------------------
+-- Renaming
+
+keep n = NoLink n
+keepL (L loc n) = L loc (NoLink n)
+
+rename = lookupRn id
+renameL (L loc name) = return . L loc =<< rename name
+
+renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName]
+renameExportItems items = mapM renameExportItem items
+
+renameMaybeDoc :: Maybe (HsDoc Name) -> RnM (Maybe (HsDoc DocName))
+renameMaybeDoc mbDoc = mapM renameDoc mbDoc
+
+renameLDoc (L loc doc) = return . L loc =<< renameDoc doc
+
+renameDoc :: HsDoc Name -> RnM (HsDoc DocName)
+renameDoc doc = case doc of
+ DocEmpty -> return DocEmpty
+ DocAppend a b -> do
+ a' <- renameDoc a
+ b' <- renameDoc b
+ return (DocAppend a' b')
+ DocString str -> return (DocString str)
+ DocParagraph doc -> do
+ doc' <- renameDoc doc
+ return (DocParagraph doc')
+ DocIdentifier ids -> do
+ lkp <- getLookupRn
+ case [ n | (True, n) <- map lkp ids ] of
+ ids'@(_:_) -> return (DocIdentifier ids')
+ [] -> return (DocIdentifier (map NoLink ids))
+ DocModule str -> return (DocModule str)
+ DocEmphasis doc -> do
+ doc' <- renameDoc doc
+ return (DocEmphasis doc')
+ DocMonospaced doc -> do
+ doc' <- renameDoc doc
+ return (DocMonospaced doc')
+ DocUnorderedList docs -> do
+ docs' <- mapM renameDoc docs
+ return (DocUnorderedList docs')
+ DocOrderedList docs -> do
+ docs' <- mapM renameDoc docs
+ return (DocOrderedList docs')
+ DocDefList docs -> do
+ docs' <- mapM (\(a,b) -> do
+ a' <- renameDoc a
+ b' <- renameDoc b
+ return (a',b')) docs
+ return (DocDefList docs')
+ DocCodeBlock doc -> do
+ doc' <- renameDoc doc
+ return (DocCodeBlock doc')
+ DocURL str -> return (DocURL str)
+ DocAName str -> return (DocAName str)
+
+renameLPred (L loc p) = return . L loc =<< renamePred p
+
+renamePred :: HsPred Name -> RnM (HsPred DocName)
+renamePred (HsClassP name types) = do
+ name' <- rename name
+ types' <- mapM renameLType types
+ return (HsClassP name' types')
+renamePred (HsIParam (IPName name) t) = do
+ name' <- rename name
+ t' <- renameLType t
+ return (HsIParam (IPName name') t')
+
+renameLType (L loc t) = return . L loc =<< renameType t
+
+renameType t = case t of
+ HsForAllTy expl tyvars lcontext ltype -> do
+ tyvars' <- mapM renameLTyVarBndr tyvars
+ lcontext' <- renameLContext lcontext
+ ltype' <- renameLType ltype
+ return (HsForAllTy expl tyvars' lcontext' ltype')
+
+ HsTyVar n -> return . HsTyVar =<< rename n
+ HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype
+
+ HsAppTy a b -> do
+ a' <- renameLType a
+ b' <- renameLType b
+ return (HsAppTy a' b')
+
+ HsFunTy a b -> do
+ a' <- renameLType a
+ b' <- renameLType b
+ return (HsFunTy a' b')
+
+ HsListTy t -> return . HsListTy =<< renameLType t
+ HsPArrTy t -> return . HsPArrTy =<< renameLType t
+
+ HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts
+
+ HsOpTy a (L loc op) b -> do
+ op' <- rename op
+ a' <- renameLType a
+ b' <- renameLType b
+ return (HsOpTy a' (L loc op') b')
+
+ HsParTy t -> return . HsParTy =<< renameLType t
+
+ HsNumTy n -> return (HsNumTy n)
+
+ HsPredTy p -> return . HsPredTy =<< renamePred p
+
+ HsKindSig t k -> do
+ t' <- renameLType t
+ return (HsKindSig t' k)
+
+ HsDocTy t doc -> do
+ t' <- renameLType t
+ doc' <- renameLDoc doc
+ return (HsDocTy t' doc')
+
+ _ -> error "renameType"
+
+renameLTyVarBndr (L loc tv) = do
+ name' <- rename (hsTyVarName tv)
+ return $ L loc (replaceTyVarName tv name')
+
+renameLContext (L loc context) = do
+ context' <- mapM renameLPred context
+ return (L loc context')
+
+renameInstHead :: InstHead Name -> RnM (InstHead DocName)
+renameInstHead (preds, className, types) = do
+ preds' <- mapM renamePred preds
+ className' <- rename className
+ types' <- mapM renameType types
+ return (preds', className', types')
+
+renameLDecl (L loc d) = return . L loc =<< renameDecl d
+
+renameDecl d = case d of
+ TyClD d -> do
+ d' <- renameTyClD d
+ return (TyClD d')
+ SigD s -> do
+ s' <- renameSig s
+ return (SigD s')
+ ForD d -> do
+ d' <- renameForD d
+ return (ForD d')
+ _ -> error "renameDecl"
+
+renameTyClD d = case d of
+ ForeignType _ _ _ -> error "renameTyClD" -- I'm guessing these can't be exported
+ -- ForeignType name a b -> do
+ -- name' <- renameL name
+ -- return (ForeignType name' a b)
+
+ TyData x lcontext lname ltyvars _ k cons _ -> do
+ lcontext' <- renameLContext lcontext
+ ltyvars' <- mapM renameLTyVarBndr ltyvars
+ cons' <- mapM renameLCon cons
+ -- I don't think we need the derivings, so we return Nothing
+ -- We skip the type patterns too. TODO: find out what they are :-)
+ return (TyData x lcontext' (keepL lname) ltyvars' Nothing k cons' Nothing)
+
+ TySynonym lname ltyvars typat ltype -> do
+ ltyvars' <- mapM renameLTyVarBndr ltyvars
+ ltype' <- renameLType ltype
+ -- We skip type patterns here as well.
+ return (TySynonym (keepL lname) ltyvars' Nothing ltype')
+
+ ClassDecl lcontext lname ltyvars lfundeps lsigs _ _ _ -> do
+ lcontext' <- renameLContext lcontext
+ ltyvars' <- mapM renameLTyVarBndr ltyvars
+ lfundeps' <- mapM renameLFunDep lfundeps
+ lsigs' <- mapM renameLSig lsigs
+ -- we don't need the default methods or the already collected doc entities
+ -- we skip the ATs for now.
+ return (ClassDecl lcontext' (keepL lname) ltyvars' lfundeps' lsigs' emptyBag [] [])
+
+ where
+ renameLCon (L loc con) = return . L loc =<< renameCon con
+ renameCon (ConDecl lname expl ltyvars lcontext details restype mbldoc) = do
+ ltyvars' <- mapM renameLTyVarBndr ltyvars
+ lcontext' <- renameLContext lcontext
+ details' <- renameDetails details
+ restype' <- renameResType restype
+ mbldoc' <- mapM renameLDoc mbldoc
+ return (ConDecl (keepL lname) expl ltyvars' lcontext' details' restype' mbldoc')
+
+ renameDetails (RecCon fields) = return . RecCon =<< mapM renameField fields
+ renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps
+ renameDetails (InfixCon a b) = do
+ a' <- renameLType a
+ b' <- renameLType b
+ return (InfixCon a' b')
+
+ renameField (HsRecField id arg doc) = do
+ arg' <- renameLType arg
+ doc' <- mapM renameLDoc doc
+ return (HsRecField (keepL id) arg' doc')
+
+ renameResType (ResTyH98) = return ResTyH98
+ renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t
+
+ renameLFunDep (L loc (xs, ys)) = return (L loc (map keep xs, map keep ys))
+
+ renameLSig (L loc sig) = return . L loc =<< renameSig sig
+
+renameSig sig = case sig of
+ TypeSig (L loc name) ltype -> do
+ ltype' <- renameLType ltype
+ return (TypeSig (L loc (keep name)) ltype')
+{- SpecSig lname ltype x -> do
+ lname' <- renameL lname
+ ltype' <- renameLType ltype
+ return (SpecSig lname' ltype' x)
+ InlineSig lname x -> do
+ lname' <- renameL lname
+ return (InlineSig lname' x)
+ SpecInstSig t -> return . SpecInstSig =<< renameLType t
+ FixSig fsig -> return . FixSig =<< renameFixitySig fsig
+ where
+ renameFixitySig (FixitySig lname x) = do
+ lname' <- renameL lname
+ return (FixitySig lname' x)
+-}
+
+renameForD (ForeignImport lname ltype x) = do
+ ltype' <- renameLType ltype
+ return (ForeignImport (keepL lname) ltype' x)
+renameForD (ForeignExport lname ltype x) = do
+ ltype' <- renameLType ltype
+ return (ForeignExport (keepL lname) ltype' x)
+
+renameExportItem :: ExportItem Name -> RnM (ExportItem DocName)
+renameExportItem item = case item of
+ ExportModule mod -> return (ExportModule mod)
+ ExportGroup lev id doc -> do
+ doc' <- renameDoc doc
+ return (ExportGroup lev id doc')
+ ExportDecl x decl doc instances -> do
+ decl' <- renameLDecl decl
+ doc' <- mapM renameDoc doc
+ instances' <- mapM renameInstHead instances
+ return (ExportDecl x decl' doc' instances')
+ ExportNoDecl x y subs -> do
+ y' <- lookupRn id y
+ subs' <- mapM (lookupRn id) subs
+ return (ExportNoDecl x y' subs')
+ ExportDoc doc -> do
+ doc' <- renameDoc doc
+ return (ExportDoc doc')
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
new file mode 100644
index 00000000..4c4587ac
--- /dev/null
+++ b/src/Haddock/Types.hs
@@ -0,0 +1,123 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+-- Ported to use the GHC API by David Waern 2006
+--
+
+module Haddock.Types where
+
+import GHC
+import Outputable
+
+import Data.Map
+
+data DocOption
+ = OptHide -- ^ This module should not appear in the docs
+ | OptPrune
+ | OptIgnoreExports -- ^ Pretend everything is exported
+ | OptNotHome -- ^ Not the best place to get docs for things
+ -- exported by this module.
+ deriving (Eq, Show)
+
+data ExportItem name
+ = ExportDecl
+ Name -- ^ The original name
+ (LHsDecl name) -- ^ A declaration
+ (Maybe (HsDoc name)) -- ^ Maybe a doc comment
+ [InstHead name] -- ^ Instances relevant to this declaration
+
+ | ExportNoDecl -- ^ An exported entity for which we have no
+ -- documentation (perhaps because it resides in
+ -- another package)
+ Name -- ^ The original name
+ name -- ^ Where to link to
+ [name] -- ^ Subordinate names
+
+ | ExportGroup -- ^ A section heading
+ Int -- ^ section level (1, 2, 3, ... )
+ String -- ^ Section "id" (for hyperlinks)
+ (HsDoc name) -- ^ Section heading text
+
+ | ExportDoc -- ^ Some documentation
+ (HsDoc name)
+
+ | ExportModule -- ^ A cross-reference to another module
+ Module
+
+type InstHead name = ([HsPred name], name, [HsType name])
+type ModuleMap = Map Module HaddockModule
+type DocMap = Map Name (HsDoc DocName)
+type DocEnv = Map Name Name
+
+data DocName = Link Name | NoLink Name
+
+instance Outputable DocName where
+ ppr (Link n) = ppr n
+ ppr (NoLink n) = ppr n
+
+data HaddockModule = HM {
+
+ -- | A value to identify the module
+ hmod_mod :: Module,
+
+ -- | The original filename for this module
+ hmod_orig_filename :: FilePath,
+
+ -- | Textual information about the module
+ hmod_info :: HaddockModInfo Name,
+
+ -- | The documentation header for this module
+ hmod_doc :: Maybe (HsDoc Name),
+
+ -- | The renamed documentation header for this module
+ hmod_rn_doc :: Maybe (HsDoc DocName),
+
+ -- | The Haddock options for this module (prune, ignore-exports, etc)
+ hmod_options :: [DocOption],
+
+ hmod_exported_decl_map :: Map Name (LHsDecl Name),
+ hmod_doc_map :: Map Name (HsDoc Name),
+ hmod_rn_doc_map :: Map Name (HsDoc DocName),
+
+ hmod_export_items :: [ExportItem Name],
+ hmod_rn_export_items :: [ExportItem DocName],
+
+ -- | All the names that are defined in this module
+ hmod_locals :: [Name],
+
+ -- | All the names that are exported by this module
+ hmod_exports :: [Name],
+
+ -- | All the visible names exported by this module
+ -- For a name to be visible, it has to:
+ -- - be exported normally, and not via a full module re-exportation.
+ -- - have a declaration in this module or any of it's imports, with the
+ -- exception that it can't be from another package.
+ -- Basically, a visible name is a name that will show up in the documentation
+ -- for this module.
+ hmod_visible_exports :: [Name],
+
+ hmod_sub_map :: Map Name [Name],
+
+ -- | The instances exported by this module
+ hmod_instances :: [Instance]
+}
+
+data DocMarkup id a = Markup {
+ markupEmpty :: a,
+ markupString :: String -> a,
+ markupParagraph :: a -> a,
+ markupAppend :: a -> a -> a,
+ markupIdentifier :: [id] -> a,
+ markupModule :: String -> a,
+ markupEmphasis :: a -> a,
+ markupMonospaced :: a -> a,
+ markupUnorderedList :: [a] -> a,
+ markupOrderedList :: [a] -> a,
+ markupDefList :: [(a,a)] -> a,
+ markupCodeBlock :: a -> a,
+ markupURL :: String -> a,
+ markupAName :: String -> a
+}
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
new file mode 100644
index 00000000..27f60e4a
--- /dev/null
+++ b/src/Haddock/Utils.hs
@@ -0,0 +1,340 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) The University of Glasgow 2001-2002
+-- (c) Simon Marlow 2003
+--
+
+module Haddock.Utils (
+
+ -- * Misc utilities
+ restrictTo,
+ toDescription,
+
+ -- * Filename utilities
+ basename, dirname, splitFilename3,
+ moduleHtmlFile, nameHtmlRef,
+ contentsHtmlFile, indexHtmlFile, subIndexHtmlFile, pathJoin,
+ anchorNameStr,
+ cssFile, iconFile, jsFile, plusFile, minusFile,
+
+ -- * Miscellaneous utilities
+ getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr,
+ isConSym, isVarSym, nameOccString, moduleString, mkModuleNoPkg,
+
+ -- * HTML cross reference mapping
+ html_xrefs_ref,
+
+ -- * HsDoc markup
+ markup,
+ idMarkup,
+
+ -- * Binary extras
+-- FormatVersion, mkFormatVersion
+ ) where
+
+import Haddock.Types
+
+import GHC
+import SrcLoc
+import Name
+import OccName
+import Binary
+import Module
+import PackageConfig ( stringToPackageId )
+
+import Control.Monad ( liftM, MonadPlus(..) )
+import Data.Map ( Map )
+import qualified Data.Map as Map hiding ( Map )
+import Data.Char
+import Data.IORef ( IORef, newIORef, readIORef )
+import Data.List ( intersect, isSuffixOf, intersperse )
+import Data.Maybe ( maybeToList, fromMaybe, isJust, fromJust )
+import Data.Word ( Word8 )
+import Data.Bits ( testBit )
+import Network.URI
+import System.Environment ( getProgName )
+import System.Exit ( exitWith, ExitCode(..) )
+import System.IO ( hPutStr, stderr )
+import System.IO.Unsafe ( unsafePerformIO )
+
+-- -----------------------------------------------------------------------------
+-- Some Utilities
+
+-- | extract a module's short description.
+toDescription :: HaddockModule -> Maybe (HsDoc Name)
+toDescription = hmi_description . hmod_info
+
+-- ---------------------------------------------------------------------------
+-- Making abstract declarations
+
+restrictTo :: [Name] -> (LHsDecl Name) -> (LHsDecl Name)
+restrictTo names (L loc decl) = L loc $ case decl of
+ TyClD d | isDataDecl d && tcdND d == DataType ->
+ TyClD (d { tcdCons = restrictCons names (tcdCons d) })
+ TyClD d | isDataDecl d && tcdND d == NewType ->
+ case restrictCons names (tcdCons d) of
+ [] -> TyClD (d { tcdND = DataType, tcdCons = [] })
+ [con] -> TyClD (d { tcdCons = [con] })
+ TyClD d | isClassDecl d ->
+ TyClD (d { tcdSigs = restrictDecls names (tcdSigs d) })
+ _ -> decl
+
+restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name]
+restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
+ where
+ keep d | unLoc (con_name d) `elem` names =
+ case con_details d of
+ PrefixCon _ -> Just d
+ RecCon fields
+ | all field_avail fields -> Just d
+ | otherwise -> Just (d { con_details = PrefixCon (field_types fields) })
+ -- if we have *all* the field names available, then
+ -- keep the record declaration. Otherwise degrade to
+ -- a constructor declaration. This isn't quite right, but
+ -- it's the best we can do.
+ InfixCon _ _ -> Just d
+ where
+ field_avail (HsRecField n _ _) = (unLoc n) `elem` names
+ field_types flds = [ ty | HsRecField n ty _ <- flds]
+
+ keep d | otherwise = Nothing
+
+restrictDecls :: [Name] -> [LSig Name] -> [LSig Name]
+restrictDecls names decls = filter keep decls
+ where keep d = fromJust (sigName d) `elem` names
+ -- has to have a name, since it's a class method type signature
+
+-- -----------------------------------------------------------------------------
+-- Filename mangling functions stolen from s main/DriverUtil.lhs.
+
+type Suffix = String
+
+splitFilename :: String -> (String,Suffix)
+splitFilename f = split_longest_prefix f (=='.')
+
+basename :: String -> String
+basename f = base where (_dir, base, _suff) = splitFilename3 f
+
+dirname :: String -> String
+dirname f = dir where (dir, _base, _suff) = splitFilename3 f
+
+-- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
+splitFilename3 :: String -> (String,String,Suffix)
+splitFilename3 str
+ = let (dir, rest) = split_longest_prefix str isPathSeparator
+ (name, ext) = splitFilename rest
+ real_dir | null dir = "."
+ | otherwise = dir
+ in (real_dir, name, ext)
+
+split_longest_prefix :: String -> (Char -> Bool) -> (String,String)
+split_longest_prefix s pred0
+ = case pre0 of
+ [] -> ([], reverse suf)
+ (_:pre) -> (reverse pre, reverse suf)
+ where (suf,pre0) = break pred0 (reverse s)
+
+pathSeparator :: Char
+#ifdef __WIN32__
+pathSeparator = '\\'
+#else
+pathSeparator = '/'
+#endif
+
+isPathSeparator :: Char -> Bool
+isPathSeparator ch =
+#ifdef mingw32_TARGET_OS
+ ch == '/' || ch == '\\'
+#else
+ ch == '/'
+#endif
+
+moduleHtmlFile :: Module -> FilePath
+moduleHtmlFile mdl =
+ case Map.lookup mdl html_xrefs of
+ Nothing -> mdl' ++ ".html"
+ Just fp0 -> pathJoin [fp0, mdl' ++ ".html"]
+ where
+ mdl' = map (\c -> if c == '.' then '-' else c)
+ (moduleNameString (moduleName mdl))
+
+nameHtmlRef :: Module -> Name -> String
+nameHtmlRef mdl str = moduleHtmlFile mdl ++ '#':escapeStr (anchorNameStr str)
+
+contentsHtmlFile, indexHtmlFile :: String
+contentsHtmlFile = "index.html"
+indexHtmlFile = "doc-index.html"
+
+subIndexHtmlFile :: Char -> String
+subIndexHtmlFile a = "doc-index-" ++ b ++ ".html"
+ where b | isAlpha a = [a]
+ | otherwise = show (ord a)
+
+anchorNameStr :: Name -> String
+anchorNameStr name | isValOcc occName = "v:" ++ getOccString name
+ | otherwise = "t:" ++ getOccString name
+ where occName = nameOccName name
+
+pathJoin :: [FilePath] -> FilePath
+pathJoin = foldr join []
+ where join :: FilePath -> FilePath -> FilePath
+ join path1 "" = path1
+ join "" path2 = path2
+ join path1 path2
+ | isPathSeparator (last path1) = path1++path2
+ | otherwise = path1++pathSeparator:path2
+
+-- -----------------------------------------------------------------------------
+-- 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.gif"
+minusFile = "minus.gif"
+
+-----------------------------------------------------------------------------
+-- misc.
+
+getProgramName :: IO String
+getProgramName = liftM (`withoutSuffix` ".bin") getProgName
+ where str `withoutSuffix` suff
+ | suff `isSuffixOf` str = take (length str - length suff) str
+ | otherwise = str
+
+bye :: String -> IO a
+bye s = putStr s >> exitWith ExitSuccess
+
+die :: String -> IO a
+die s = hPutStr stderr s >> exitWith (ExitFailure 1)
+
+dieMsg :: String -> IO a
+dieMsg s = getProgramName >>= \prog -> die (prog ++ ": " ++ s)
+
+noDieMsg :: String -> IO ()
+noDieMsg s = getProgramName >>= \prog -> hPutStr stderr (prog ++ ": " ++ s)
+
+mapSnd :: (b -> c) -> [(a,b)] -> [(a,c)]
+mapSnd _ [] = []
+mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs
+
+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
+#if __GLASGOW_HASKELL__ < 603
+escapeStr = flip escapeString unreserved
+#else
+escapeStr = escapeURIString isUnreserved
+#endif
+
+-- there should be a better way to check this using the GHC API
+isConSym n = head (nameOccString n) == ':'
+isVarSym n = fstChar /= '_' && not (isConSym n) && (not . isLetter) fstChar
+ where fstChar = head (nameOccString n)
+
+nameOccString = occNameString . nameOccName
+
+moduleString :: Module -> String
+moduleString = moduleNameString . moduleName
+
+mkModuleNoPkg :: String -> Module
+mkModuleNoPkg str = mkModule (stringToPackageId "") (mkModuleName str)
+
+-----------------------------------------------------------------------------
+-- HTML cross references
+
+-- For each module, we need to know where its HTML documentation lives
+-- so that we can point hyperlinks to it. It is extremely
+-- inconvenient to plumb this information to all the places that need
+-- it (basically every function in HaddockHtml), and furthermore the
+-- mapping is constant for any single run of Haddock. So for the time
+-- being I'm going to use a write-once global variable.
+
+{-# NOINLINE html_xrefs_ref #-}
+html_xrefs_ref :: IORef (Map Module FilePath)
+html_xrefs_ref = unsafePerformIO (newIORef (error "module_map"))
+
+{-# NOINLINE html_xrefs #-}
+html_xrefs :: Map Module FilePath
+html_xrefs = unsafePerformIO (readIORef html_xrefs_ref)
+
+-----------------------------------------------------------------------------
+-- put here temporarily
+
+markup :: DocMarkup id a -> HsDoc id -> a
+markup m DocEmpty = markupEmpty m
+markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2)
+markup m (DocString s) = markupString m s
+markup m (DocParagraph d) = markupParagraph m (markup m d)
+markup m (DocIdentifier ids) = markupIdentifier m ids
+markup m (DocModule mod0) = markupModule m mod0
+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 :: DocMarkup id a -> (HsDoc id, HsDoc id) -> (a, a)
+markupPair m (a,b) = (markup m a, markup m b)
+
+-- | The identity markup
+idMarkup :: DocMarkup a (HsDoc a)
+idMarkup = Markup {
+ markupEmpty = DocEmpty,
+ markupString = DocString,
+ markupParagraph = DocParagraph,
+ markupAppend = DocAppend,
+ markupIdentifier = DocIdentifier,
+ markupModule = DocModule,
+ markupEmphasis = DocEmphasis,
+ markupMonospaced = DocMonospaced,
+ markupUnorderedList = DocUnorderedList,
+ markupOrderedList = DocOrderedList,
+ markupDefList = DocDefList,
+ markupCodeBlock = DocCodeBlock,
+ markupURL = DocURL,
+ markupAName = DocAName
+ }
+
+-- | Since marking up is just a matter of mapping 'Doc' into some
+-- other type, we can \'rename\' documentation by marking up 'Doc' into
+-- the same thing, modifying only the identifiers embedded in it.
+
+mapIdent f = idMarkup { markupIdentifier = f }
+
+-----------------------------------------------------------------------------
+-- put here temporarily
+
+newtype FormatVersion = FormatVersion Int deriving (Eq,Ord)
+
+nullFormatVersion :: FormatVersion
+nullFormatVersion = mkFormatVersion 0
+
+mkFormatVersion :: Int -> FormatVersion
+mkFormatVersion i = FormatVersion i
+
+instance Binary FormatVersion where
+ put_ bh (FormatVersion i) =
+ case compare i 0 of
+ EQ -> return ()
+ GT -> put_ bh (-i)
+ LT -> error (
+ "Binary.hs: negative FormatVersion " ++ show i
+ ++ " is not allowed")
+ get bh =
+ do
+ (w8 :: Word8) <- get bh
+ if testBit w8 7
+ then
+ do
+ i <- get bh
+ return (FormatVersion (-i))
+ else
+ return nullFormatVersion
diff --git a/src/Haddock/Utils/BlockTable.hs b/src/Haddock/Utils/BlockTable.hs
new file mode 100644
index 00000000..ed51654e
--- /dev/null
+++ b/src/Haddock/Utils/BlockTable.hs
@@ -0,0 +1,180 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Text.Html.BlockTable
+-- Copyright : (c) Andy Gill, and the Oregon Graduate Institute of
+-- Science and Technology, 1999-2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : Andy Gill <andy@galconn.com>
+-- Stability : experimental
+-- Portability : portable
+--
+-- $Id: BlockTable.hs,v 1.2 2002/07/24 09:42:18 simonmar Exp $
+--
+-- An Html combinator library
+--
+-----------------------------------------------------------------------------
+
+module Haddock.Utils.BlockTable (
+
+-- Datatypes:
+
+ BlockTable, -- abstract
+
+-- Contruction Functions:
+
+ single,
+ empty,
+ above,
+ beside,
+
+-- Investigation Functions:
+
+ getMatrix,
+ showsTable,
+ showTable,
+
+ ) where
+
+import Prelude
+
+infixr 4 `beside`
+infixr 3 `above`
+
+-- These combinators can be used to build formated 2D tables.
+-- The specific target useage is for HTML table generation.
+
+{-
+ Examples of use:
+
+ > table1 :: BlockTable String
+ > table1 = single "Hello" +-----+
+ |Hello|
+ This is a 1x1 cell +-----+
+ Note: single has type
+
+ single :: a -> BlockTable a
+
+ So the cells can contain anything.
+
+ > table2 :: BlockTable String
+ > table2 = single "World" +-----+
+ |World|
+ +-----+
+
+
+ > table3 :: BlockTable String
+ > table3 = table1 %-% table2 +-----%-----+
+ |Hello%World|
+ % is used to indicate +-----%-----+
+ the join edge between
+ the two Tables.
+
+ > table4 :: BlockTable String
+ > table4 = table3 %/% table2 +-----+-----+
+ |Hello|World|
+ Notice the padding on the %%%%%%%%%%%%%
+ smaller (bottom) cell to |World |
+ force the table to be a +-----------+
+ rectangle.
+
+ > table5 :: BlockTable String
+ > table5 = table1 %-% table4 +-----%-----+-----+
+ |Hello%Hello|World|
+ Notice the padding on the | %-----+-----+
+ leftmost cell, again to | %World |
+ force the table to be a +-----%-----------+
+ rectangle.
+
+ Now the table can be rendered with processTable, for example:
+ Main> processTable table5
+ [[("Hello",(1,2)),
+ ("Hello",(1,1)),
+ ("World",(1,1))],
+ [("World",(2,1))]] :: [[([Char],(Int,Int))]]
+ Main>
+-}
+
+-- ---------------------------------------------------------------------------
+-- Contruction Functions
+
+-- Perhaps one day I'll write the Show instance
+-- to show boxes aka the above ascii renditions.
+
+instance (Show a) => Show (BlockTable a) where
+ showsPrec _ = showsTable
+
+type TableI a = [[(a,(Int,Int))]] -> [[(a,(Int,Int))]]
+
+data BlockTable a = Table (Int -> Int -> TableI a) Int Int
+
+
+-- You can create a (1x1) table entry
+
+single :: a -> BlockTable a
+single a = Table (\ x y r -> [(a,(x+1,y+1))] : r) 1 1
+
+empty :: BlockTable a
+empty = Table (\ _ _ r -> r) 0 0
+
+
+-- You can compose tables, horizonally and vertically
+
+above :: BlockTable a -> BlockTable a -> BlockTable a
+beside :: BlockTable a -> BlockTable a -> BlockTable a
+
+t1 `above` t2 = trans (combine (trans t1) (trans t2) (.))
+
+t1 `beside` t2 = combine t1 t2 (\ lst1 lst2 r ->
+ let
+ -- Note this depends on the fact that
+ -- that the result has the same number
+ -- of lines as the y dimention; one list
+ -- per line. This is not true in general
+ -- but is always true for these combinators.
+ -- I should assert this!
+ -- I should even prove this.
+ beside' (x:xs) (y:ys) = (x ++ y) : beside' xs ys
+ beside' (x:xs) [] = x : xs ++ r
+ beside' [] (y:ys) = y : ys ++ r
+ beside' [] [] = r
+ in
+ beside' (lst1 []) (lst2 []))
+
+-- trans flips (transposes) over the x and y axis of
+-- the table. It is only used internally, and typically
+-- in pairs, ie. (flip ... munge ... (un)flip).
+
+trans :: BlockTable a -> BlockTable a
+trans (Table f1 x1 y1) = Table (flip f1) y1 x1
+
+combine :: BlockTable a
+ -> BlockTable b
+ -> (TableI a -> TableI b -> TableI c)
+ -> BlockTable c
+combine (Table f1 x1 y1) (Table f2 x2 y2) comb = Table new_fn (x1+x2) max_y
+ where
+ max_y = max y1 y2
+ new_fn x y =
+ case compare y1 y2 of
+ EQ -> comb (f1 0 y) (f2 x y)
+ GT -> comb (f1 0 y) (f2 x (y + y1 - y2))
+ LT -> comb (f1 0 (y + y2 - y1)) (f2 x y)
+
+-- ---------------------------------------------------------------------------
+-- Investigation Functions
+
+-- This is the other thing you can do with a Table;
+-- turn it into a 2D list, tagged with the (x,y)
+-- sizes of each cell in the table.
+
+getMatrix :: BlockTable a -> [[(a,(Int,Int))]]
+getMatrix (Table r _ _) = r 0 0 []
+
+-- You can also look at a table
+
+showsTable :: (Show a) => BlockTable a -> ShowS
+showsTable table = shows (getMatrix table)
+
+showTable :: (Show a) => BlockTable a -> String
+showTable table = showsTable table ""
diff --git a/src/Haddock/Utils/FastMutInt2.hs b/src/Haddock/Utils/FastMutInt2.hs
new file mode 100644
index 00000000..c47b514b
--- /dev/null
+++ b/src/Haddock/Utils/FastMutInt2.hs
@@ -0,0 +1,63 @@
+{-# OPTIONS_GHC -cpp -fglasgow-exts #-}
+--
+-- (c) The University of Glasgow 2002
+--
+-- Unboxed mutable Ints
+
+module Haddock.Utils.FastMutInt2(
+ FastMutInt, newFastMutInt,
+ readFastMutInt, writeFastMutInt,
+ incFastMutInt, incFastMutIntBy
+ ) where
+
+#include "MachDeps.h"
+
+#ifndef SIZEOF_HSINT
+#define SIZEOF_HSINT INT_SIZE_IN_BYTES
+#endif
+
+
+#if __GLASGOW_HASKELL__ < 503
+import GlaExts
+import PrelIOBase
+#else
+import GHC.Base
+import GHC.IOBase
+#endif
+
+#if __GLASGOW_HASKELL__ < 411
+newByteArray# = newCharArray#
+#endif
+
+#ifdef __GLASGOW_HASKELL__
+data FastMutInt = FastMutInt (MutableByteArray# RealWorld)
+
+newFastMutInt :: IO FastMutInt
+newFastMutInt = IO $ \s0 ->
+ case newByteArray# size s0 of { (# s, arr #) ->
+ (# s, FastMutInt arr #) }
+ where I# size = SIZEOF_HSINT
+
+readFastMutInt :: FastMutInt -> IO Int
+readFastMutInt (FastMutInt arr) = IO $ \s0 ->
+ case readIntArray# arr 0# s0 of { (# s, i #) ->
+ (# s, I# i #) }
+
+writeFastMutInt :: FastMutInt -> Int -> IO ()
+writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s0 ->
+ case writeIntArray# arr 0# i s0 of { s ->
+ (# s, () #) }
+
+incFastMutInt :: FastMutInt -> IO Int -- Returns original value
+incFastMutInt (FastMutInt arr) = IO $ \s0 ->
+ case readIntArray# arr 0# s0 of { (# s1, i #) ->
+ case writeIntArray# arr 0# (i +# 1#) s1 of { s ->
+ (# s, I# i #) } }
+
+incFastMutIntBy :: FastMutInt -> Int -> IO Int -- Returns original value
+incFastMutIntBy (FastMutInt arr) (I# n) = IO $ \s0 ->
+ case readIntArray# arr 0# s0 of { (# s1, i #) ->
+ case writeIntArray# arr 0# (i +# n) s1 of { s ->
+ (# s, I# i #) } }
+#endif
+
diff --git a/src/Haddock/Utils/GHC.hs b/src/Haddock/Utils/GHC.hs
new file mode 100644
index 00000000..b6fb54d4
--- /dev/null
+++ b/src/Haddock/Utils/GHC.hs
@@ -0,0 +1,26 @@
+module Haddock.Utils.GHC where
+
+import Debug.Trace
+
+import GHC
+import HsSyn
+import SrcLoc
+import HscTypes
+import Outputable
+
+getMainDeclBinder :: HsDecl name -> Maybe name
+getMainDeclBinder (TyClD d) = Just (tcdName d)
+getMainDeclBinder (ValD d)
+ = case collectAcc d [] of
+ [] -> Nothing
+ (name:_) -> Just (unLoc name)
+getMainDeclBinder (SigD d) = sigNameNoLoc d
+getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name)
+getMainDeclBinder (ForD (ForeignExport name _ _)) = Nothing
+getMainDeclBinder _ = Nothing
+
+-- To keep if if minf_iface is re-introduced
+--modInfoName = moduleName . mi_module . minf_iface
+--modInfoMod = mi_module . minf_iface
+
+trace_ppr x y = trace (showSDoc (ppr x)) y
diff --git a/src/Haddock/Utils/Html.hs b/src/Haddock/Utils/Html.hs
new file mode 100644
index 00000000..dbef2112
--- /dev/null
+++ b/src/Haddock/Utils/Html.hs
@@ -0,0 +1,1037 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Text.Html
+-- Copyright : (c) Andy Gill, and the Oregon Graduate Institute of
+-- Science and Technology, 1999-2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : Andy Gill <andy@galconn.com>
+-- Stability : experimental
+-- Portability : portable
+--
+-- An Html combinator library
+--
+-----------------------------------------------------------------------------
+
+module Haddock.Utils.Html (
+ module Haddock.Utils.Html,
+ ) where
+
+import qualified Haddock.Utils.BlockTable as BT
+
+import Data.Char (isAscii, ord)
+import Numeric (showHex)
+
+infixr 2 +++ -- combining Html
+infixr 7 << -- nesting Html
+infixl 8 ! -- adding optional arguments
+
+
+-- A important property of Html is that all strings inside the
+-- structure are already in Html friendly format.
+-- For example, use of &gt;,etc.
+
+data HtmlElement
+{-
+ - ..just..plain..normal..text... but using &copy; and &amb;, etc.
+ -}
+ = HtmlString String
+{-
+ - <thetag {..attrs..}> ..content.. </thetag>
+ -}
+ | HtmlTag { -- tag with internal markup
+ markupTag :: String,
+ markupAttrs :: [HtmlAttr],
+ markupContent :: Html
+ }
+
+{- These are the index-value pairs.
+ - The empty string is a synonym for tags with no arguments.
+ - (not strictly HTML, but anyway).
+ -}
+
+
+data HtmlAttr = HtmlAttr String String
+
+
+newtype Html = Html { getHtmlElements :: [HtmlElement] }
+
+-- Read MARKUP as the class of things that can be validly rendered
+-- inside MARKUP tag brackets. So this can be one or more Html's,
+-- or a String, for example.
+
+class HTML a where
+ toHtml :: a -> Html
+ toHtmlFromList :: [a] -> Html
+
+ toHtmlFromList xs = Html (concat [ x | (Html x) <- map toHtml xs])
+
+instance HTML Html where
+ toHtml a = a
+
+instance HTML Char where
+ toHtml a = toHtml [a]
+ toHtmlFromList [] = Html []
+ toHtmlFromList str = Html [HtmlString (stringToHtmlString str)]
+
+instance (HTML a) => HTML [a] where
+ toHtml xs = toHtmlFromList xs
+
+class ADDATTRS a where
+ (!) :: a -> [HtmlAttr] -> a
+
+instance (ADDATTRS b) => ADDATTRS (a -> b) where
+ (!) fn attr = \ arg -> fn arg ! attr
+
+instance ADDATTRS Html where
+ (!) (Html htmls) attr = Html (map addAttrs htmls)
+ where
+ addAttrs html =
+ case html of
+ HtmlTag { markupAttrs = markupAttrs0
+ , markupTag = markupTag0
+ , markupContent = markupContent0 } ->
+ HtmlTag { markupAttrs = markupAttrs0 ++ attr
+ , markupTag = markupTag0
+ , markupContent = markupContent0 }
+ _ -> html
+
+
+(<<) :: (HTML a) => (Html -> b) -> a -> b
+fn << arg = fn (toHtml arg)
+
+
+concatHtml :: (HTML a) => [a] -> Html
+concatHtml as = Html (concat (map (getHtmlElements.toHtml) as))
+
+(+++) :: (HTML a,HTML b) => a -> b -> Html
+a +++ b = Html (getHtmlElements (toHtml a) ++ getHtmlElements (toHtml b))
+
+noHtml :: Html
+noHtml = Html []
+
+
+isNoHtml :: Html -> Bool
+isNoHtml (Html xs) = null xs
+
+
+tag :: String -> Html -> Html
+tag str htmls =
+ Html [ HtmlTag { markupTag = str,
+ markupAttrs = [],
+ markupContent = htmls }
+ ]
+
+itag :: String -> Html
+itag str = tag str noHtml
+
+emptyAttr :: String -> HtmlAttr
+emptyAttr s = HtmlAttr s ""
+
+intAttr :: String -> Int -> HtmlAttr
+intAttr s i = HtmlAttr s (show i)
+
+strAttr :: String -> String -> HtmlAttr
+strAttr s t = HtmlAttr s t
+
+
+{-
+foldHtml :: (String -> [HtmlAttr] -> [a] -> a)
+ -> (String -> a)
+ -> Html
+ -> a
+foldHtml f g (HtmlTag str attr fmls)
+ = f str attr (map (foldHtml f g) fmls)
+foldHtml f g (HtmlString str)
+ = g str
+
+-}
+-- Processing Strings into Html friendly things.
+-- This converts a String to a Html String.
+stringToHtmlString :: String -> String
+stringToHtmlString = concatMap fixChar
+ where
+ fixChar '<' = "&lt;"
+ fixChar '>' = "&gt;"
+ fixChar '&' = "&amp;"
+ fixChar '"' = "&quot;"
+ fixChar c
+ | isAscii c = [c]
+ | otherwise = "&#x" ++ showHex (ord c) ";"
+
+-- ---------------------------------------------------------------------------
+-- Classes
+
+instance Show Html where
+ showsPrec _ html = showString (prettyHtml html)
+ showList htmls = showString (concat (map show htmls))
+
+instance Show HtmlAttr where
+ showsPrec _ (HtmlAttr str val) =
+ showString str .
+ showString "=" .
+ shows val
+
+
+-- ---------------------------------------------------------------------------
+-- Data types
+
+type URL = String
+
+-- ---------------------------------------------------------------------------
+-- Basic primitives
+
+-- This is not processed for special chars.
+-- use stringToHtml or lineToHtml instead, for user strings,
+-- because they understand special chars, like '<'.
+
+primHtml :: String -> Html
+primHtml x = Html [HtmlString x]
+
+-- ---------------------------------------------------------------------------
+-- Basic Combinators
+
+stringToHtml :: String -> Html
+stringToHtml = primHtml . stringToHtmlString
+
+-- This converts a string, but keeps spaces as non-line-breakable
+
+lineToHtml :: String -> Html
+lineToHtml = primHtml . concatMap htmlizeChar2 . stringToHtmlString
+ where
+ htmlizeChar2 ' ' = "&nbsp;"
+ htmlizeChar2 c = [c]
+
+-- ---------------------------------------------------------------------------
+-- Html Constructors
+
+-- (automatically generated)
+
+address :: Html -> Html
+anchor :: Html -> Html
+applet :: Html -> Html
+area :: Html
+basefont :: Html
+big :: Html -> Html
+blockquote :: Html -> Html
+body :: Html -> Html
+bold :: Html -> Html
+br :: Html
+button :: Html -> Html
+caption :: Html -> Html
+center :: Html -> Html
+cite :: Html -> Html
+ddef :: Html -> Html
+define :: Html -> Html
+dlist :: Html -> Html
+dterm :: Html -> Html
+emphasize :: Html -> Html
+fieldset :: Html -> Html
+font :: Html -> Html
+form :: Html -> Html
+frame :: Html -> Html
+frameset :: Html -> Html
+h1 :: Html -> Html
+h2 :: Html -> Html
+h3 :: Html -> Html
+h4 :: Html -> Html
+h5 :: Html -> Html
+h6 :: Html -> Html
+header :: Html -> Html
+hr :: Html
+image :: Html
+input :: Html
+italics :: Html -> Html
+keyboard :: Html -> Html
+legend :: Html -> Html
+li :: Html -> Html
+meta :: Html
+noframes :: Html -> Html
+olist :: Html -> Html
+option :: Html -> Html
+paragraph :: Html -> Html
+param :: Html
+pre :: Html -> Html
+sample :: Html -> Html
+script :: Html -> Html
+select :: Html -> Html
+small :: Html -> Html
+strong :: Html -> Html
+style :: Html -> Html
+sub :: Html -> Html
+sup :: Html -> Html
+table :: Html -> Html
+thetd :: Html -> Html
+textarea :: Html -> Html
+th :: Html -> Html
+thebase :: Html
+thecode :: Html -> Html
+thediv :: Html -> Html
+thehtml :: Html -> Html
+thelink :: Html
+themap :: Html -> Html
+thespan :: Html -> Html
+thetitle :: Html -> Html
+tr :: Html -> Html
+tt :: Html -> Html
+ulist :: Html -> Html
+underline :: Html -> Html
+variable :: Html -> Html
+
+address = tag "ADDRESS"
+anchor = tag "A"
+applet = tag "APPLET"
+area = itag "AREA"
+basefont = itag "BASEFONT"
+big = tag "BIG"
+blockquote = tag "BLOCKQUOTE"
+body = tag "BODY"
+bold = tag "B"
+br = itag "BR"
+button = tag "BUTTON"
+caption = tag "CAPTION"
+center = tag "CENTER"
+cite = tag "CITE"
+ddef = tag "DD"
+define = tag "DFN"
+dlist = tag "DL"
+dterm = tag "DT"
+emphasize = tag "EM"
+fieldset = tag "FIELDSET"
+font = tag "FONT"
+form = tag "FORM"
+frame = tag "FRAME"
+frameset = tag "FRAMESET"
+h1 = tag "H1"
+h2 = tag "H2"
+h3 = tag "H3"
+h4 = tag "H4"
+h5 = tag "H5"
+h6 = tag "H6"
+header = tag "HEAD"
+hr = itag "HR"
+image = itag "IMG"
+input = itag "INPUT"
+italics = tag "I"
+keyboard = tag "KBD"
+legend = tag "LEGEND"
+li = tag "LI"
+meta = itag "META"
+noframes = tag "NOFRAMES"
+olist = tag "OL"
+option = tag "OPTION"
+paragraph = tag "P"
+param = itag "PARAM"
+pre = tag "PRE"
+sample = tag "SAMP"
+script = tag "SCRIPT"
+select = tag "SELECT"
+small = tag "SMALL"
+strong = tag "STRONG"
+style = tag "STYLE"
+sub = tag "SUB"
+sup = tag "SUP"
+table = tag "TABLE"
+thetd = tag "TD"
+textarea = tag "TEXTAREA"
+th = tag "TH"
+thebase = itag "BASE"
+thecode = tag "CODE"
+thediv = tag "DIV"
+thehtml = tag "HTML"
+thelink = itag "LINK"
+themap = tag "MAP"
+thespan = tag "SPAN"
+thetitle = tag "TITLE"
+tr = tag "TR"
+tt = tag "TT"
+ulist = tag "UL"
+underline = tag "U"
+variable = tag "VAR"
+
+-- ---------------------------------------------------------------------------
+-- Html Attributes
+
+-- (automatically generated)
+
+action :: String -> HtmlAttr
+align :: String -> HtmlAttr
+alink :: String -> HtmlAttr
+alt :: String -> HtmlAttr
+altcode :: String -> HtmlAttr
+archive :: String -> HtmlAttr
+background :: String -> HtmlAttr
+base :: String -> HtmlAttr
+bgcolor :: String -> HtmlAttr
+border :: Int -> HtmlAttr
+bordercolor :: String -> HtmlAttr
+cellpadding :: Int -> HtmlAttr
+cellspacing :: Int -> HtmlAttr
+checked :: HtmlAttr
+clear :: String -> HtmlAttr
+code :: String -> HtmlAttr
+codebase :: String -> HtmlAttr
+color :: String -> HtmlAttr
+cols :: String -> HtmlAttr
+colspan :: Int -> HtmlAttr
+compact :: HtmlAttr
+content :: String -> HtmlAttr
+coords :: String -> HtmlAttr
+enctype :: String -> HtmlAttr
+face :: String -> HtmlAttr
+frameborder :: Int -> HtmlAttr
+height :: Int -> HtmlAttr
+href :: String -> HtmlAttr
+hspace :: Int -> HtmlAttr
+httpequiv :: String -> HtmlAttr
+identifier :: String -> HtmlAttr
+ismap :: HtmlAttr
+lang :: String -> HtmlAttr
+link :: String -> HtmlAttr
+marginheight :: Int -> HtmlAttr
+marginwidth :: Int -> HtmlAttr
+maxlength :: Int -> HtmlAttr
+method :: String -> HtmlAttr
+multiple :: HtmlAttr
+name :: String -> HtmlAttr
+nohref :: HtmlAttr
+noresize :: HtmlAttr
+noshade :: HtmlAttr
+nowrap :: HtmlAttr
+onclick :: String -> HtmlAttr
+rel :: String -> HtmlAttr
+rev :: String -> HtmlAttr
+rows :: String -> HtmlAttr
+rowspan :: Int -> HtmlAttr
+rules :: String -> HtmlAttr
+scrolling :: String -> HtmlAttr
+selected :: HtmlAttr
+shape :: String -> HtmlAttr
+size :: String -> HtmlAttr
+src :: String -> HtmlAttr
+start :: Int -> HtmlAttr
+target :: String -> HtmlAttr
+text :: String -> HtmlAttr
+theclass :: String -> HtmlAttr
+thestyle :: String -> HtmlAttr
+thetype :: String -> HtmlAttr
+title :: String -> HtmlAttr
+usemap :: String -> HtmlAttr
+valign :: String -> HtmlAttr
+value :: String -> HtmlAttr
+version :: String -> HtmlAttr
+vlink :: String -> HtmlAttr
+vspace :: Int -> HtmlAttr
+width :: String -> HtmlAttr
+
+action = strAttr "ACTION"
+align = strAttr "ALIGN"
+alink = strAttr "ALINK"
+alt = strAttr "ALT"
+altcode = strAttr "ALTCODE"
+archive = strAttr "ARCHIVE"
+background = strAttr "BACKGROUND"
+base = strAttr "BASE"
+bgcolor = strAttr "BGCOLOR"
+border = intAttr "BORDER"
+bordercolor = strAttr "BORDERCOLOR"
+cellpadding = intAttr "CELLPADDING"
+cellspacing = intAttr "CELLSPACING"
+checked = emptyAttr "CHECKED"
+clear = strAttr "CLEAR"
+code = strAttr "CODE"
+codebase = strAttr "CODEBASE"
+color = strAttr "COLOR"
+cols = strAttr "COLS"
+colspan = intAttr "COLSPAN"
+compact = emptyAttr "COMPACT"
+content = strAttr "CONTENT"
+coords = strAttr "COORDS"
+enctype = strAttr "ENCTYPE"
+face = strAttr "FACE"
+frameborder = intAttr "FRAMEBORDER"
+height = intAttr "HEIGHT"
+href = strAttr "HREF"
+hspace = intAttr "HSPACE"
+httpequiv = strAttr "HTTP-EQUIV"
+identifier = strAttr "ID"
+ismap = emptyAttr "ISMAP"
+lang = strAttr "LANG"
+link = strAttr "LINK"
+marginheight = intAttr "MARGINHEIGHT"
+marginwidth = intAttr "MARGINWIDTH"
+maxlength = intAttr "MAXLENGTH"
+method = strAttr "METHOD"
+multiple = emptyAttr "MULTIPLE"
+name = strAttr "NAME"
+nohref = emptyAttr "NOHREF"
+noresize = emptyAttr "NORESIZE"
+noshade = emptyAttr "NOSHADE"
+nowrap = emptyAttr "NOWRAP"
+onclick = strAttr "ONCLICK"
+rel = strAttr "REL"
+rev = strAttr "REV"
+rows = strAttr "ROWS"
+rowspan = intAttr "ROWSPAN"
+rules = strAttr "RULES"
+scrolling = strAttr "SCROLLING"
+selected = emptyAttr "SELECTED"
+shape = strAttr "SHAPE"
+size = strAttr "SIZE"
+src = strAttr "SRC"
+start = intAttr "START"
+target = strAttr "TARGET"
+text = strAttr "TEXT"
+theclass = strAttr "CLASS"
+thestyle = strAttr "STYLE"
+thetype = strAttr "TYPE"
+title = strAttr "TITLE"
+usemap = strAttr "USEMAP"
+valign = strAttr "VALIGN"
+value = strAttr "VALUE"
+version = strAttr "VERSION"
+vlink = strAttr "VLINK"
+vspace = intAttr "VSPACE"
+width = strAttr "WIDTH"
+
+-- ---------------------------------------------------------------------------
+-- Html Constructors
+
+-- (automatically generated)
+
+validHtmlTags :: [String]
+validHtmlTags = [
+ "ADDRESS",
+ "A",
+ "APPLET",
+ "BIG",
+ "BLOCKQUOTE",
+ "BODY",
+ "B",
+ "CAPTION",
+ "CENTER",
+ "CITE",
+ "DD",
+ "DFN",
+ "DL",
+ "DT",
+ "EM",
+ "FIELDSET",
+ "FONT",
+ "FORM",
+ "FRAME",
+ "FRAMESET",
+ "H1",
+ "H2",
+ "H3",
+ "H4",
+ "H5",
+ "H6",
+ "HEAD",
+ "I",
+ "KBD",
+ "LEGEND",
+ "LI",
+ "NOFRAMES",
+ "OL",
+ "OPTION",
+ "P",
+ "PRE",
+ "SAMP",
+ "SELECT",
+ "SMALL",
+ "STRONG",
+ "STYLE",
+ "SUB",
+ "SUP",
+ "TABLE",
+ "TD",
+ "TEXTAREA",
+ "TH",
+ "CODE",
+ "DIV",
+ "HTML",
+ "LINK",
+ "MAP",
+ "TITLE",
+ "TR",
+ "TT",
+ "UL",
+ "U",
+ "VAR"]
+
+validHtmlITags :: [String]
+validHtmlITags = [
+ "AREA",
+ "BASEFONT",
+ "BR",
+ "HR",
+ "IMG",
+ "INPUT",
+ "LINK",
+ "META",
+ "PARAM",
+ "BASE"]
+
+validHtmlAttrs :: [String]
+validHtmlAttrs = [
+ "ACTION",
+ "ALIGN",
+ "ALINK",
+ "ALT",
+ "ALTCODE",
+ "ARCHIVE",
+ "BACKGROUND",
+ "BASE",
+ "BGCOLOR",
+ "BORDER",
+ "BORDERCOLOR",
+ "CELLPADDING",
+ "CELLSPACING",
+ "CHECKED",
+ "CLEAR",
+ "CODE",
+ "CODEBASE",
+ "COLOR",
+ "COLS",
+ "COLSPAN",
+ "COMPACT",
+ "CONTENT",
+ "COORDS",
+ "ENCTYPE",
+ "FACE",
+ "FRAMEBORDER",
+ "HEIGHT",
+ "HREF",
+ "HSPACE",
+ "HTTP-EQUIV",
+ "ID",
+ "ISMAP",
+ "LANG",
+ "LINK",
+ "MARGINHEIGHT",
+ "MARGINWIDTH",
+ "MAXLENGTH",
+ "METHOD",
+ "MULTIPLE",
+ "NAME",
+ "NOHREF",
+ "NORESIZE",
+ "NOSHADE",
+ "NOWRAP",
+ "REL",
+ "REV",
+ "ROWS",
+ "ROWSPAN",
+ "RULES",
+ "SCROLLING",
+ "SELECTED",
+ "SHAPE",
+ "SIZE",
+ "SRC",
+ "START",
+ "TARGET",
+ "TEXT",
+ "CLASS",
+ "STYLE",
+ "TYPE",
+ "TITLE",
+ "USEMAP",
+ "VALIGN",
+ "VALUE",
+ "VERSION",
+ "VLINK",
+ "VSPACE",
+ "WIDTH"]
+
+-- ---------------------------------------------------------------------------
+-- Html colors
+
+aqua :: String
+black :: String
+blue :: String
+fuchsia :: String
+gray :: String
+green :: String
+lime :: String
+maroon :: String
+navy :: String
+olive :: String
+purple :: String
+red :: String
+silver :: String
+teal :: String
+yellow :: String
+white :: String
+
+aqua = "aqua"
+black = "black"
+blue = "blue"
+fuchsia = "fuchsia"
+gray = "gray"
+green = "green"
+lime = "lime"
+maroon = "maroon"
+navy = "navy"
+olive = "olive"
+purple = "purple"
+red = "red"
+silver = "silver"
+teal = "teal"
+yellow = "yellow"
+white = "white"
+
+-- ---------------------------------------------------------------------------
+-- Basic Combinators
+
+linesToHtml :: [String] -> Html
+
+linesToHtml [] = noHtml
+linesToHtml (x:[]) = lineToHtml x
+linesToHtml (x:xs) = lineToHtml x +++ br +++ linesToHtml xs
+
+
+-- ---------------------------------------------------------------------------
+-- Html abbriviations
+
+primHtmlChar :: String -> Html
+copyright :: Html
+spaceHtml :: Html
+bullet :: Html
+p :: Html -> Html
+
+primHtmlChar = \ x -> primHtml ("&" ++ x ++ ";")
+copyright = primHtmlChar "copy"
+spaceHtml = primHtmlChar "nbsp"
+bullet = primHtmlChar "#149"
+
+p = paragraph
+
+-- ---------------------------------------------------------------------------
+-- Html tables
+
+cell :: Html -> HtmlTable
+cell h = let
+ cellFn x y = h ! (add x colspan $ add y rowspan $ [])
+ add 1 _ rest = rest
+ add n fn rest = fn n : rest
+ r = BT.single cellFn
+ in
+ mkHtmlTable r
+
+-- We internally represent the Cell inside a Table with an
+-- object of the type
+-- \pre{
+-- Int -> Int -> Html
+-- }
+-- When we render it later, we find out how many columns
+-- or rows this cell will span over, and can
+-- include the correct colspan/rowspan command.
+
+newtype HtmlTable
+ = HtmlTable (BT.BlockTable (Int -> Int -> Html))
+
+td :: Html -> HtmlTable
+td = cell . thetd
+
+tda :: [HtmlAttr] -> Html -> HtmlTable
+tda as = cell . (thetd ! as)
+
+above, beside :: HtmlTable -> HtmlTable -> HtmlTable
+above a b = combine BT.above a b
+beside a b = combine BT.beside a b
+
+infixr 3 </> -- combining table cells
+infixr 4 <-> -- combining table cells
+(</>), (<->) :: HtmlTable -> HtmlTable -> HtmlTable
+(</>) = above
+(<->) = beside
+
+emptyTable :: HtmlTable
+emptyTable = HtmlTable BT.empty
+
+aboves, besides :: [HtmlTable] -> HtmlTable
+aboves = foldr above emptyTable
+besides = foldr beside emptyTable
+
+mkHtmlTable :: BT.BlockTable (Int -> Int -> Html) -> HtmlTable
+mkHtmlTable r = HtmlTable r
+
+combine :: (BT.BlockTable (Int -> Int -> Html)
+ -> BT.BlockTable (Int -> Int -> Html)
+ -> BT.BlockTable (Int -> Int -> Html))
+ -> HtmlTable -> HtmlTable -> HtmlTable
+combine fn (HtmlTable a) (HtmlTable b) = mkHtmlTable (a `fn` b)
+
+-- renderTable takes the HtmlTable, and renders it back into
+-- and Html object.
+
+renderTable :: BT.BlockTable (Int -> Int -> Html) -> Html
+renderTable theTable
+ = concatHtml
+ [tr << [theCell x y | (theCell,(x,y)) <- theRow ]
+ | theRow <- BT.getMatrix theTable]
+
+instance HTML HtmlTable where
+ toHtml (HtmlTable tab) = renderTable tab
+
+instance Show HtmlTable where
+ showsPrec _ (HtmlTable tab) = shows (renderTable tab)
+
+
+-- If you can't be bothered with the above, then you
+-- can build simple tables with simpleTable.
+-- Just provide the attributes for the whole table,
+-- attributes for the cells (same for every cell),
+-- and a list of lists of cell contents,
+-- and this function will build the table for you.
+-- It does presume that all the lists are non-empty,
+-- and there is at least one list.
+--
+-- Different length lists means that the last cell
+-- gets padded. If you want more power, then
+-- use the system above, or build tables explicitly.
+
+simpleTable :: HTML a => [HtmlAttr] -> [HtmlAttr] -> [[a]] -> Html
+simpleTable attr cellAttr lst
+ = table ! attr
+ << (aboves
+ . map (besides . map (cell . (thetd ! cellAttr) . toHtml))
+ ) lst
+
+
+-- ---------------------------------------------------------------------------
+-- Tree Displaying Combinators
+
+-- The basic idea is you render your structure in the form
+-- of this tree, and then use treeHtml to turn it into a Html
+-- object with the structure explicit.
+
+data HtmlTree
+ = HtmlLeaf Html
+ | HtmlNode Html [HtmlTree] Html
+
+treeHtml :: [String] -> HtmlTree -> Html
+treeHtml colors h = table ! [
+ border 0,
+ cellpadding 0,
+ cellspacing 2] << treeHtml' colors h
+ where
+ manycolors = scanr (:) []
+
+ treeHtmls :: [[String]] -> [HtmlTree] -> HtmlTable
+ treeHtmls c ts = aboves (zipWith treeHtml' c ts)
+
+ treeHtml' :: [String] -> HtmlTree -> HtmlTable
+ treeHtml' (_:_) (HtmlLeaf leaf) = cell
+ (thetd ! [width "100%"]
+ << bold
+ << leaf)
+ treeHtml' (c:cs@(c2:_)) (HtmlNode hopen ts hclose) =
+ if null ts && isNoHtml hclose
+ then
+ hd
+ else if null ts
+ then
+ hd </> bar `beside` (cell . (thetd ! [bgcolor c2]) << spaceHtml)
+ </> tl
+ else
+ hd </> (bar `beside` treeHtmls morecolors ts)
+ </> tl
+ where
+ -- This stops a column of colors being the same
+ -- color as the immeduately outside nesting bar.
+ morecolors = filter ((/= c).head) (manycolors cs)
+ bar = cell (thetd ! [bgcolor c,width "10"] << spaceHtml)
+ hd = cell (thetd ! [bgcolor c] << hopen)
+ tl = cell (thetd ! [bgcolor c] << hclose)
+ treeHtml' _ _ = error "The imposible happens"
+
+instance HTML HtmlTree where
+ toHtml x = treeHtml treeColors x
+
+-- type "length treeColors" to see how many colors are here.
+treeColors :: [String]
+treeColors = ["#88ccff","#ffffaa","#ffaaff","#ccffff"] ++ treeColors
+
+
+-- ---------------------------------------------------------------------------
+-- Html Debugging Combinators
+
+-- This uses the above tree rendering function, and displays the
+-- Html as a tree structure, allowing debugging of what is
+-- actually getting produced.
+
+debugHtml :: (HTML a) => a -> Html
+debugHtml obj = table ! [border 0] << (
+ cell (th ! [bgcolor "#008888"]
+ << underline
+ << "Debugging Output")
+ </> td << (toHtml (debug' (toHtml obj)))
+ )
+ where
+
+ debug' :: Html -> [HtmlTree]
+ debug' (Html markups) = map debug markups
+
+ debug :: HtmlElement -> HtmlTree
+ debug (HtmlString str) = HtmlLeaf (spaceHtml +++
+ linesToHtml (lines str))
+ debug (HtmlTag {
+ markupTag = markupTag0,
+ markupContent = markupContent0,
+ markupAttrs = markupAttrs0
+ }) =
+ case markupContent0 of
+ Html [] -> HtmlNode hd [] noHtml
+ Html xs -> HtmlNode hd (map debug xs) tl
+ where
+ args = if null markupAttrs0
+ then ""
+ else " " ++ unwords (map show markupAttrs0)
+ hd = font ! [size "1"] << ("<" ++ markupTag0 ++ args ++ ">")
+ tl = font ! [size "1"] << ("</" ++ markupTag0 ++ ">")
+
+-- ---------------------------------------------------------------------------
+-- Hotlink datatype
+
+data HotLink = HotLink {
+ hotLinkURL :: URL,
+ hotLinkContents :: [Html],
+ hotLinkAttributes :: [HtmlAttr]
+ } deriving Show
+
+instance HTML HotLink where
+ toHtml hl = anchor ! (href (hotLinkURL hl) : hotLinkAttributes hl)
+ << hotLinkContents hl
+
+hotlink :: URL -> [Html] -> HotLink
+hotlink url h = HotLink {
+ hotLinkURL = url,
+ hotLinkContents = h,
+ hotLinkAttributes = [] }
+
+
+-- ---------------------------------------------------------------------------
+-- More Combinators
+
+-- (Abridged from Erik Meijer's Original Html library)
+
+ordList :: (HTML a) => [a] -> Html
+ordList items = olist << map (li <<) items
+
+unordList :: (HTML a) => [a] -> Html
+unordList items = ulist << map (li <<) items
+
+defList :: (HTML a,HTML b) => [(a,b)] -> Html
+defList items
+ = dlist << [ [ dterm << bold << dt, ddef << dd ] | (dt,dd) <- items ]
+
+
+widget :: String -> String -> [HtmlAttr] -> Html
+widget w n markupAttrs0 = input ! ([thetype w,name n] ++ markupAttrs0)
+
+checkbox :: String -> String -> Html
+hidden :: String -> String -> Html
+radio :: String -> String -> Html
+reset :: String -> String -> Html
+submit :: String -> String -> Html
+password :: String -> Html
+textfield :: String -> Html
+afile :: String -> Html
+clickmap :: String -> Html
+
+checkbox n v = widget "CHECKBOX" n [value v]
+hidden n v = widget "HIDDEN" n [value v]
+radio n v = widget "RADIO" n [value v]
+reset n v = widget "RESET" n [value v]
+submit n v = widget "SUBMIT" n [value v]
+password n = widget "PASSWORD" n []
+textfield n = widget "TEXT" n []
+afile n = widget "FILE" n []
+clickmap n = widget "IMAGE" n []
+
+menu :: String -> [Html] -> Html
+menu n choices
+ = select ! [name n] << [ option << p << choice | choice <- choices ]
+
+gui :: String -> Html -> Html
+gui act = form ! [action act,method "POST"]
+
+-- ---------------------------------------------------------------------------
+-- Html Rendering
+
+-- Uses the append trick to optimize appending.
+-- The output is quite messy, because space matters in
+-- HTML, so we must not generate needless spaces.
+
+renderHtml :: (HTML html) => html -> String
+renderHtml theHtml =
+ renderMessage ++
+ foldr (.) id (map unprettyHtml
+ (getHtmlElements (tag "HTML" << theHtml))) "\n"
+
+renderMessage :: String
+renderMessage =
+ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">\n" ++
+ "<!--Rendered using the Haskell Html Library v0.2-->\n"
+
+unprettyHtml :: HtmlElement -> ShowS
+unprettyHtml (HtmlString str) = (++) str
+unprettyHtml (HtmlTag
+ { markupTag = name0,
+ markupContent = html,
+ markupAttrs = markupAttrs0 })
+ = if isNoHtml html && elem name0 validHtmlITags
+ then renderTag True name0 markupAttrs0 0
+ else (renderTag True name0 markupAttrs0 0
+ . foldr (.) id (map unprettyHtml (getHtmlElements html))
+ . renderTag False name0 [] 0)
+
+-- Local Utilities
+prettyHtml :: (HTML html) => html -> String
+prettyHtml theHtml =
+ unlines
+ $ concat
+ $ map prettyHtml'
+ $ getHtmlElements
+ $ toHtml theHtml
+
+prettyHtml' :: HtmlElement -> [String]
+prettyHtml' (HtmlString str) = [str]
+prettyHtml' (HtmlTag
+ { markupTag = name0,
+ markupContent = html,
+ markupAttrs = markupAttrs0 })
+ = if isNoHtml html && elem name0 validHtmlITags
+ then
+ [rmNL (renderTag True name0 markupAttrs0 0 "")]
+ else
+ [rmNL (renderTag True name0 markupAttrs0 0 "")] ++
+ shift (concat (map prettyHtml' (getHtmlElements html))) ++
+ [rmNL (renderTag False name0 [] 0 "")]
+ where
+ shift = map (\x -> " " ++ x)
+
+rmNL :: [Char] -> [Char]
+rmNL = filter (/= '\n')
+
+-- This prints the Tags The lack of spaces in intentunal, because Html is
+-- actually space dependant.
+
+renderTag :: Bool -> String -> [HtmlAttr] -> Int -> ShowS
+renderTag x name0 markupAttrs0 n r
+ = open ++ name0 ++ rest markupAttrs0 ++ ">" ++ r
+ where
+ open = if x then "<" else "</"
+
+ nl = "\n" ++ replicate (n `div` 8) '\t'
+ ++ replicate (n `mod` 8) ' '
+
+ rest [] = nl
+ rest attr = " " ++ unwords (map showPair attr) ++ nl
+
+ showPair :: HtmlAttr -> String
+ showPair (HtmlAttr tag0 val)
+ = tag0 ++ "=\"" ++ val ++ "\""
+
diff --git a/src/Haddock/Version.hs b/src/Haddock/Version.hs
new file mode 100644
index 00000000..f4d02b7d
--- /dev/null
+++ b/src/Haddock/Version.hs
@@ -0,0 +1,18 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+
+module Haddock.Version (
+ projectName, projectVersion, projectUrl
+ ) where
+
+import Paths_haddock_ghc ( version )
+import Data.Version ( showVersion )
+
+projectName, projectUrl :: String
+projectName = "Haddock-GHC"
+projectUrl = "http://www.haskell.org/haddock/"
+
+projectVersion = showVersion version
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-24 05:24:53 +0000