From 658e79eddf0ac941d2719ec0a3aea58f42ef1277 Mon Sep 17 00:00:00 2001
From: David Waern <unknown>
Date: Wed, 29 Aug 2007 22:40:23 +0000
Subject: Major refactoring
---
haddock.cabal | 43 +-
src/Haddock/Backends/DevHelp.hs | 81 ++
src/Haddock/Backends/HH.hs | 180 +++++
src/Haddock/Backends/HH2.hs | 190 +++++
src/Haddock/Backends/HaddockDB.hs | 165 ++++
src/Haddock/Backends/Hoogle.hs | 184 +++++
src/Haddock/Backends/Html.hs | 1510 +++++++++++++++++++++++++++++++++++++
src/Haddock/DevHelp.hs | 81 --
src/Haddock/GHC/Typecheck.hs | 106 +++
src/Haddock/GHC/Utils.hs | 79 ++
src/Haddock/HH.hs | 180 -----
src/Haddock/HH2.hs | 188 -----
src/Haddock/HaddockDB.hs | 165 ----
src/Haddock/Hoogle.hs | 184 -----
src/Haddock/Html.hs | 1508 ------------------------------------
src/Haddock/Interface.hs | 91 +++
src/Haddock/InterfaceFile.hs | 2 +-
src/Haddock/Options.hs | 3 +-
src/Haddock/Packages.hs | 89 +--
src/Haddock/Rename.hs | 330 --------
src/Haddock/Syntax/Rename.hs | 333 ++++++++
src/Haddock/Typecheck.hs | 123 ---
src/Haddock/Types.hs | 32 +-
src/Haddock/Utils/GHC.hs | 76 --
src/Main.hs | 922 ++--------------------
25 files changed, 3050 insertions(+), 3795 deletions(-)
create mode 100644 src/Haddock/Backends/DevHelp.hs
create mode 100644 src/Haddock/Backends/HH.hs
create mode 100644 src/Haddock/Backends/HH2.hs
create mode 100644 src/Haddock/Backends/HaddockDB.hs
create mode 100644 src/Haddock/Backends/Hoogle.hs
create mode 100644 src/Haddock/Backends/Html.hs
delete mode 100644 src/Haddock/DevHelp.hs
create mode 100644 src/Haddock/GHC/Typecheck.hs
create mode 100644 src/Haddock/GHC/Utils.hs
delete mode 100644 src/Haddock/HH.hs
delete mode 100644 src/Haddock/HH2.hs
delete mode 100644 src/Haddock/HaddockDB.hs
delete mode 100644 src/Haddock/Hoogle.hs
delete mode 100644 src/Haddock/Html.hs
create mode 100644 src/Haddock/Interface.hs
delete mode 100644 src/Haddock/Rename.hs
create mode 100644 src/Haddock/Syntax/Rename.hs
delete mode 100644 src/Haddock/Typecheck.hs
delete mode 100644 src/Haddock/Utils/GHC.hs
diff --git a/haddock.cabal b/haddock.cabal
index 8a8496b5..e97da9c0 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -23,10 +23,10 @@ ghc-options: -fglasgow-exts
hs-source-dirs: src
exposed-modules:
Distribution.Haddock
+ Haddock.Types
other-modules:
Haddock.InterfaceFile
Haddock.Exception
- Haddock.Types
data-files:
html/haddock-DEBUG.css
html/haddock.css
@@ -76,23 +76,24 @@ main-is: Main.hs
extensions: CPP, PatternGuards
ghc-options: -fglasgow-exts
other-modules:
- Haddock.Utils.FastMutInt2
- Haddock.Utils.BlockTable
- Haddock.HaddockDB
- Haddock.DevHelp
- Haddock.HH
- Haddock.HH2
- Haddock.Hoogle
- Haddock.Utils.Html
- Haddock.ModuleTree
- Haddock.Rename
- Haddock.Types
- Haddock.Utils
- Haddock.Version
- Haddock.Utils.Html
- Haddock.Utils.GHC
- Haddock.InterfaceFile
- Haddock.Exception
- Haddock.Options
- Haddock.Typecheck
- Main
+ Haddock.Interface.Rename
+ Haddock.Interface.Create
+ Haddock.Utils.FastMutInt2
+ Haddock.Utils.BlockTable
+ Haddock.Utils.Html
+ Haddock.Utils
+ Haddock.Backends.HaddockDB
+ Haddock.Backends.DevHelp
+ Haddock.Backends.HH
+ Haddock.Backends.HH2
+ Haddock.Backends.Hoogle
+ Haddock.ModuleTree
+ Haddock.Types
+ Haddock.Version
+ Haddock.InterfaceFile
+ Haddock.Exception
+ Haddock.Options
+ Haddock.GHC.Typecheck
+ Haddock.GHC.Utils
+ Haddock.GHC
+ Main
diff --git a/src/Haddock/Backends/DevHelp.hs b/src/Haddock/Backends/DevHelp.hs
new file mode 100644
index 00000000..9441d4a9
--- /dev/null
+++ b/src/Haddock/Backends/DevHelp.hs
@@ -0,0 +1,81 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+
+module Haddock.Backends.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/Backends/HH.hs b/src/Haddock/Backends/HH.hs
new file mode 100644
index 00000000..6cb5491d
--- /dev/null
+++ b/src/Haddock/Backends/HH.hs
@@ -0,0 +1,180 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+
+module Haddock.Backends.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/Backends/HH2.hs b/src/Haddock/Backends/HH2.hs
new file mode 100644
index 00000000..685be3ad
--- /dev/null
+++ b/src/Haddock/Backends/HH2.hs
@@ -0,0 +1,190 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+
+
+module Haddock.Backends.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/Backends/HaddockDB.hs b/src/Haddock/Backends/HaddockDB.hs
new file mode 100644
index 00000000..9be79c27
--- /dev/null
+++ b/src/Haddock/Backends/HaddockDB.hs
@@ -0,0 +1,165 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+
+module Haddock.Backends.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 "->", 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/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
new file mode 100644
index 00000000..d93c055b
--- /dev/null
+++ b/src/Haddock/Backends/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.Backends.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/Backends/Html.hs b/src/Haddock/Backends/Html.hs
new file mode 100644
index 00000000..b49bf213
--- /dev/null
+++ b/src/Haddock/Backends/Html.hs
@@ -0,0 +1,1510 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+
+
+module Haddock.Backends.Html (
+ ppHtml, copyHtmlBits,
+ ppHtmlIndex, ppHtmlContents,
+ ppHtmlHelpFiles
+) where
+
+
+import Prelude hiding (div)
+
+import Haddock.Backends.DevHelp
+import Haddock.Backends.HH
+import Haddock.Backends.HH2
+import Haddock.ModuleTree
+import Haddock.Types
+import Haddock.Version
+import Haddock.Utils
+import Haddock.Utils.GHC
+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 Data.Map ( Map )
+import qualified Data.Map as Map hiding ( Map )
+
+import GHC hiding ( NoLink )
+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 :: ConDeclField DocName -> HtmlTable
+ppSideBySideField (ConDeclField 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 -> ConDeclField DocName -> HtmlTable
+ppShortField summary (ConDeclField lname ltype _)
+ = 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/DevHelp.hs b/src/Haddock/DevHelp.hs
deleted file mode 100644
index 3401a7b4..00000000
--- a/src/Haddock/DevHelp.hs
+++ /dev/null
@@ -1,81 +0,0 @@
---
--- Haddock - A Haskell Documentation Tool
---
--- (c) Simon Marlow 2003
---
-
-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/GHC/Typecheck.hs b/src/Haddock/GHC/Typecheck.hs
new file mode 100644
index 00000000..e8e291ad
--- /dev/null
+++ b/src/Haddock/GHC/Typecheck.hs
@@ -0,0 +1,106 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+
+
+module Haddock.GHC.Typecheck (
+ typecheckFiles
+) where
+
+
+import Haddock.Exception
+import Haddock.Utils.GHC
+import Haddock.Types
+
+import Data.Maybe
+import Control.Monad
+import GHC
+import Digraph
+import BasicTypes
+import SrcLoc
+
+
+typecheckFiles :: Session -> [FilePath] -> IO [GhcModule]
+typecheckFiles session files = do
+ checkedMods <- sortAndCheckModules session files
+ return (map mkGhcModule checkedMods)
+
+
+-- | Get the sorted graph of all loaded modules and their dependencies
+getSortedModuleGraph :: Session -> IO [(Module, FilePath)]
+getSortedModuleGraph session = do
+ mbModGraph <- depanal session [] True
+ moduleGraph <- case mbModGraph of
+ Just mg -> return mg
+ Nothing -> throwE "Failed to load all modules"
+ let
+ getModFile = fromJust . ml_hs_file . ms_location
+ sortedGraph = topSortModuleGraph False moduleGraph Nothing
+ sortedModules = concatMap flattenSCC sortedGraph
+ modsAndFiles = [ (ms_mod modsum, getModFile modsum) |
+ modsum <- sortedModules ]
+ return modsAndFiles
+
+
+type CheckedMod = (Module, FilePath, FullyCheckedMod)
+
+
+type FullyCheckedMod = (ParsedSource,
+ RenamedSource,
+ TypecheckedSource,
+ ModuleInfo)
+
+
+-- TODO: make it handle cleanup
+sortAndCheckModules :: Session -> [FilePath] -> IO [CheckedMod]
+sortAndCheckModules session files = do
+
+ -- load all argument files
+
+ targets <- mapM (\f -> guessTarget f Nothing) files
+ setTargets session targets
+
+ -- compute the dependencies and load them as well
+
+ allMods <- getSortedModuleGraph session
+ targets' <- mapM (\(_, f) -> guessTarget f Nothing) allMods
+ setTargets session targets'
+
+ flag <- load session LoadAllTargets
+ when (failed flag) $
+ throwE "Failed to load all needed modules"
+
+ -- typecheck the argument modules
+
+ let argMods = filter ((`elem` files) . snd) allMods
+
+ checkedMods <- forM argMods $ \(mod, file) -> do
+ mbMod <- checkModule session (moduleName mod) False
+ case mbMod of
+ Just (CheckedModule a (Just b) (Just c) (Just d) _)
+ -> return (mod, file, (a,b,c,d))
+ _ -> throwE ("Failed to check module: " ++ moduleString mod)
+
+ return checkedMods
+
+
+-- | Dig out what we want from the typechecker output
+mkGhcModule :: CheckedMod -> GhcModule
+mkGhcModule (mod, file, checkedMod) = GhcModule {
+ ghcModule = mod,
+ ghcFilename = file,
+ ghcMbDocOpts = mbOpts,
+ ghcHaddockModInfo = info,
+ ghcMbDoc = mbDoc,
+ ghcGroup = group,
+ ghcMbExports = mbExports,
+ ghcExportedNames = modInfoExports modInfo,
+ ghcNamesInScope = fromJust $ modInfoTopLevelScope modInfo,
+ ghcInstances = modInfoInstances modInfo
+}
+ where
+ HsModule _ _ _ _ _ mbOpts _ _ = unLoc parsed
+ (group, _, mbExports, mbDoc, info) = renamed
+ (parsed, renamed, _, modInfo) = checkedMod
diff --git a/src/Haddock/GHC/Utils.hs b/src/Haddock/GHC/Utils.hs
new file mode 100644
index 00000000..8e70057f
--- /dev/null
+++ b/src/Haddock/GHC/Utils.hs
@@ -0,0 +1,79 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+
+
+module Haddock.GHC.Utils where
+
+
+import Debug.Trace
+import Data.Char
+
+import GHC
+import HsSyn
+import SrcLoc
+import HscTypes
+import Outputable
+import Packages
+import UniqFM
+import Name
+
+
+-- names
+
+nameOccString = occNameString . nameOccName
+
+
+nameSetMod n newMod =
+ mkExternalName (nameUnique n) newMod (nameOccName n) (nameSrcSpan n)
+
+
+nameSetPkg pkgId n =
+ mkExternalName (nameUnique n) (mkModule pkgId (moduleName mod))
+ (nameOccName n) (nameSrcSpan n)
+ where mod = nameModule n
+
+
+-- modules
+
+
+moduleString :: Module -> String
+moduleString = moduleNameString . moduleName
+
+
+mkModuleNoPkg :: String -> Module
+mkModuleNoPkg str = mkModule (stringToPackageId "") (mkModuleName str)
+
+
+modulePkgStr = packageIdString . modulePackageId
+
+
+-- misc
+
+
+-- 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)
+
+
+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/HH.hs b/src/Haddock/HH.hs
deleted file mode 100644
index dc8f37e0..00000000
--- a/src/Haddock/HH.hs
+++ /dev/null
@@ -1,180 +0,0 @@
---
--- Haddock - A Haskell Documentation Tool
---
--- (c) Simon Marlow 2003
---
-
-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
deleted file mode 100644
index 7f88ed51..00000000
--- a/src/Haddock/HH2.hs
+++ /dev/null
@@ -1,188 +0,0 @@
---
--- Haddock - A Haskell Documentation Tool
---
--- (c) Simon Marlow 2003
---
-
-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
deleted file mode 100644
index 6341c6c4..00000000
--- a/src/Haddock/HaddockDB.hs
+++ /dev/null
@@ -1,165 +0,0 @@
---
--- 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 "->", 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
deleted file mode 100644
index 618d6eb3..00000000
--- a/src/Haddock/Hoogle.hs
+++ /dev/null
@@ -1,184 +0,0 @@
---
--- 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
deleted file mode 100644
index 74aa4e34..00000000
--- a/src/Haddock/Html.hs
+++ /dev/null
@@ -1,1508 +0,0 @@
---
--- 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.Version
-import Haddock.Utils
-import Haddock.Utils.GHC
-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 Data.Map ( Map )
-import qualified Data.Map as Map hiding ( Map )
-
-import GHC hiding ( NoLink )
-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 :: ConDeclField DocName -> HtmlTable
-ppSideBySideField (ConDeclField 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 -> ConDeclField DocName -> HtmlTable
-ppShortField summary (ConDeclField lname ltype _)
- = 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/Interface.hs b/src/Haddock/Interface.hs
new file mode 100644
index 00000000..aed4af34
--- /dev/null
+++ b/src/Haddock/Interface.hs
@@ -0,0 +1,91 @@
+-------------------------------------------------------------------------------
+-- Haddock.Interface
+--
+-- Here we build the actual module interfaces. By interface we mean the
+-- information which is used to render a Haddock page for a module. Parts of
+-- this information is also stored in the interface files.
+--
+-- The HaddockModule structure holds the interface data as well as
+-- intermediate information needed during its creation.
+-------------------------------------------------------------------------------
+
+
+module Haddock.Interface (
+ createInterfaces
+) where
+
+
+import Haddock.Interface.Create
+import Haddock.Interface.AttachInstances
+import Haddock.Interface.Rename
+import Haddock.Types
+import Haddock.Options
+import Haddock.GHC.Utils
+
+import qualified Data.Map as Map
+import Data.Map (Map)
+import Data.List
+import Control.Monad.Writer
+import Control.Monad
+
+import Name
+
+
+-- | Turn a topologically sorted list of GhcModules into interfaces. Also
+-- return the home link environment created in the process, and any error
+-- messages.
+createInterfaces :: [GhcModule] -> LinkEnv -> [Flag] ->
+ ([HaddockModule], LinkEnv, [ErrMsg])
+createInterfaces modules extLinks flags = (interfaces, homeLinks, messages)
+ where
+ ((interfaces, homeLinks), messages) = runWriter $ do
+ -- part 1, create the interfaces
+ interfaces <- createInterfaces' modules flags
+ -- part 2, attach the instances
+ let interfaces' = attachInstances interfaces
+ -- part 3, rename the interfaces
+ renameInterfaces interfaces' extLinks
+
+
+createInterfaces' :: [GhcModule] -> [Flag] -> ErrMsgM [HaddockModule]
+createInterfaces' modules flags = do
+ resultMap <- foldM addInterface Map.empty modules
+ return (Map.elems resultMap)
+ where
+ addInterface :: ModuleMap -> GhcModule -> ErrMsgM ModuleMap
+ addInterface map mod = do
+ interface <- createInterface mod flags map
+ return $ Map.insert (hmod_mod interface) interface map
+
+
+renameInterfaces :: [HaddockModule] -> LinkEnv ->
+ ErrMsgM ([HaddockModule], LinkEnv)
+renameInterfaces interfaces externalLinks = do
+ let homeLinks = buildHomeLinks interfaces
+ let links = homeLinks `Map.union` externalLinks
+ interfaces' <- mapM (renameInterface links) interfaces
+ return (interfaces', homeLinks)
+
+-- | Build a mapping which for each original name, points to the "best"
+-- place to link to in the documentation. For the definition of
+-- "best", we use "the module nearest the bottom of the dependency
+-- graph which exports this name", not including hidden modules. When
+-- there are multiple choices, we pick a random one.
+--
+-- The interfaces are passed in in topologically sorted order, but we start
+-- by reversing the list so we can do a foldl.
+buildHomeLinks :: [HaddockModule] -> LinkEnv
+buildHomeLinks modules = foldl upd Map.empty (reverse modules)
+ where
+ upd old_env mod
+ | OptHide `elem` hmod_options mod = old_env
+ | OptNotHome `elem` hmod_options mod =
+ foldl' keep_old old_env exported_names
+ | otherwise = foldl' keep_new old_env exported_names
+ where
+ exported_names = hmod_visible_exports mod
+ modName = hmod_mod mod
+
+ keep_old env n = Map.insertWith (\new old -> old) n
+ (nameSetMod n modName) env
+ keep_new env n = Map.insert n (nameSetMod n modName) env
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index 246c6dba..228efa71 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -45,7 +45,7 @@ data InterfaceMod = InterfaceMod {
}
data InterfaceFile = InterfaceFile {
- ifDocEnv :: DocEnv
+ ifLinkEnv :: LinkEnv
-- ifModules :: [InterfaceMod]
}
diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs
index 2b459f8d..c330f35e 100644
--- a/src/Haddock/Options.hs
+++ b/src/Haddock/Options.hs
@@ -132,6 +132,5 @@ options backwardsCompat =
Option [] ["use-package"] (ReqArg Flag_UsePackage "PACKAGE")
"the modules being processed depend on PACKAGE",
Option ['g'] [] (ReqArg Flag_GhcFlag "FLAGS + ARGS")
- ("send a flag to the Glasgow Haskell Compiler (use quotation to "
- ++ "pass arguments to the flag)")
+ ("send a flag to GHC")
]
diff --git a/src/Haddock/Packages.hs b/src/Haddock/Packages.hs
index 18383c4c..c2de11b4 100644
--- a/src/Haddock/Packages.hs
+++ b/src/Haddock/Packages.hs
@@ -7,8 +7,8 @@
module Haddock.Packages (
HaddockPackage(..),
- initAndReadPackages,
- combineDocEnvs
+ getHaddockPackages,
+ combineLinkEnvs
) where
@@ -33,68 +33,22 @@ import Packages
-- to the html files and the list of modules in the package
data HaddockPackage = HaddockPackage {
pdModules :: [Module],
- pdDocEnv :: DocEnv,
+ pdLinkEnv :: LinkEnv,
pdHtmlPath :: FilePath
}
--- | Expose the list of packages to GHC. Then initialize GHC's package state
--- and get the name of the actually loaded packages matching the supplied
--- list of packages. The matching packages might be newer versions of the
--- supplied ones. For each matching package, try to read its installed Haddock
--- information.
---
--- It would be better to try to get the "in scope" packages from GHC instead.
--- This would make the -use-package flag unnecessary. But currently it
--- seems all you can get from the GHC api is all packages that are linked in
--- (i.e the closure of the "in scope" packages).
-initAndReadPackages :: Session -> [String] -> IO [HaddockPackage]
-initAndReadPackages session pkgStrs = do
-
- -- expose the packages
-
- dfs <- getSessionDynFlags session
- let dfs' = dfs { packageFlags = packageFlags dfs ++ map ExposePackage pkgStrs }
- setSessionDynFlags session dfs'
-
- -- try to parse the packages and get their names, without versions
- pkgNames <- mapM (handleParse . unpackPackageId . stringToPackageId) pkgStrs
-
- -- init GHC's package state
- (_, depPackages) <- initPackages dfs'
-
- -- compute the pkgIds of the loaded packages matching the
- -- supplied ones
-
- let depPkgs = map (fromJust . unpackPackageId) depPackages
- matchingPackages = [ mkPackageId pkg | pkg <- depPkgs,
- pkgName pkg `elem` pkgNames ]
-
- -- read the Haddock information for the matching packages
- getPackages session matchingPackages
- where
- handleParse (Just pkg) = return (pkgName pkg)
- handleParse Nothing = throwE "Could not parse package identifier"
-
-
--- | Try to create a HaddockPackage for each package.
--- Print a warning on stdout if a HaddockPackage could not be created.
-getPackages :: Session -> [PackageId] -> IO [HaddockPackage]
-getPackages session packages = do
-
- -- get InstalledPackageInfos for each package
- dynflags <- getSessionDynFlags session
- let pkgInfos = map (getPackageDetails (pkgState dynflags)) packages
-
- -- try to read the installed haddock information (.haddock interface file and
- -- html path) for the packages
- liftM catMaybes $ mapM tryGetPackage pkgInfos
+-- | Try to read the installed Haddock information for the given packages,
+-- if it exists. Print a warning on stdout if it couldn't be found for a
+-- package.
+getHaddockPackages :: [InstalledPackageInfo] -> IO [HaddockPackage]
+getHaddockPackages pkgInfos = liftM catMaybes $ mapM tryGetPackage pkgInfos
where
-- try to get a HaddockPackage, warn if we can't
tryGetPackage pkgInfo =
- (getPackage session pkgInfo >>= return . Just)
+ (getPackage pkgInfo >>= return . Just)
`catchDyn`
- (\(e::HaddockException) -> do
+ (\(e::HaddockException) -> do
let pkgName = showPackageId (package pkgInfo)
putStrLn ("Warning: Cannot use package " ++ pkgName ++ ":")
putStrLn (" " ++ show e)
@@ -102,20 +56,17 @@ getPackages session packages = do
)
--- | Try to create a HaddockPackage structure for a package
-getPackage :: Session -> InstalledPackageInfo -> IO HaddockPackage
-getPackage session pkgInfo = do
+-- | Try to read a HaddockPackage structure for a package
+getPackage :: InstalledPackageInfo -> IO HaddockPackage
+getPackage pkgInfo = do
- html <- getHtml pkgInfo
+ html <- getHtml pkgInfo
ifacePath <- getIface pkgInfo
- iface <- readInterfaceFile ifacePath
+ iface <- readInterfaceFile ifacePath
- let docEnv = ifDocEnv iface
- modules = packageModules pkgInfo
-
return $ HaddockPackage {
- pdModules = modules,
- pdDocEnv = docEnv,
+ pdModules = packageModules pkgInfo,
+ pdLinkEnv = ifLinkEnv iface,
pdHtmlPath = html
}
@@ -148,8 +99,8 @@ getIface pkgInfo = case haddockInterfaces pkgInfo of
_ -> throwE "No Haddock interface installed."
--- | Build one big doc env out of a list of packages. If multiple packages
+-- | Build one big link env out of a list of packages. If multiple packages
-- export the same (original) name, we just pick one of the packages as the
-- documentation site.
-combineDocEnvs :: [HaddockPackage] -> DocEnv
-combineDocEnvs packages = Map.unions (map pdDocEnv packages)
+combineLinkEnvs :: [HaddockPackage] -> LinkEnv
+combineLinkEnvs packages = Map.unions (map pdLinkEnv packages)
diff --git a/src/Haddock/Rename.hs b/src/Haddock/Rename.hs
deleted file mode 100644
index 5ac711cb..00000000
--- a/src/Haddock/Rename.hs
+++ /dev/null
@@ -1,330 +0,0 @@
---
--- 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 hiding ( NoLink )
-import Name
-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 )
-import Control.Arrow
-
--- -----------------------------------------------------------------------------
--- 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)
-
-newtype OrdName = MkOrdName Name
-
-instance Eq OrdName where
- (MkOrdName a) == (MkOrdName b) = a == b
-
-instance Ord OrdName where
- (MkOrdName a) `compare` (MkOrdName b) = nameOccName a `compare` nameOccName b
-
-runRnFM :: Map Name Name -> RnM a -> (a,[Name])
-runRnFM env rn = unRn rn lkp
- where
- lkp n = case Map.lookup (MkOrdName n) ordEnv of
- Nothing -> (False, NoLink n)
- Just (MkOrdName q) -> (True, Link q)
-
- ordEnv = Map.fromList . map (MkOrdName *** MkOrdName) . Map.toList $ env
-
--- -----------------------------------------------------------------------------
--- 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 (ConDeclField name t doc) = do
- t' <- renameLType t
- doc' <- mapM renameLDoc doc
- return (ConDeclField (keepL name) t' 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/Syntax/Rename.hs b/src/Haddock/Syntax/Rename.hs
new file mode 100644
index 00000000..81dfb1cc
--- /dev/null
+++ b/src/Haddock/Syntax/Rename.hs
@@ -0,0 +1,333 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+
+
+module Haddock.Syntax.Rename (
+ runRnFM, -- the monad (instance of Monad)
+ renameDoc, renameMaybeDoc, renameExportItems,
+) where
+
+
+import Haddock.Types
+
+import GHC hiding ( NoLink )
+import Name
+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 )
+import Control.Arrow
+
+
+-- -----------------------------------------------------------------------------
+-- 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)
+
+newtype OrdName = MkOrdName Name
+
+instance Eq OrdName where
+ (MkOrdName a) == (MkOrdName b) = a == b
+
+instance Ord OrdName where
+ (MkOrdName a) `compare` (MkOrdName b) = nameOccName a `compare` nameOccName b
+
+runRnFM :: Map Name Name -> RnM a -> (a,[Name])
+runRnFM env rn = unRn rn lkp
+ where
+ lkp n = case Map.lookup (MkOrdName n) ordEnv of
+ Nothing -> (False, NoLink n)
+ Just (MkOrdName q) -> (True, Link q)
+
+ ordEnv = Map.fromList . map (MkOrdName *** MkOrdName) . Map.toList $ env
+
+-- -----------------------------------------------------------------------------
+-- 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 (ConDeclField name t doc) = do
+ t' <- renameLType t
+ doc' <- mapM renameLDoc doc
+ return (ConDeclField (keepL name) t' 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/Typecheck.hs b/src/Haddock/Typecheck.hs
deleted file mode 100644
index 088ee8a1..00000000
--- a/src/Haddock/Typecheck.hs
+++ /dev/null
@@ -1,123 +0,0 @@
---
--- Haddock - A Haskell Documentation Tool
---
--- (c) Simon Marlow 2003
---
-
-
-module Haddock.Typecheck (
- GhcModule(..),
- typecheckFiles
-) where
-
-
-import Haddock.Exception
-import Haddock.Utils.GHC
-
-
-import Data.Maybe
-import Control.Monad
-import GHC
-import Digraph
-import BasicTypes
-import SrcLoc
-
-
--- | This data structure collects all the information we want about a home
--- package module that we can get from GHC's typechecker
-data GhcModule = GhcModule {
- ghcModule :: Module,
- ghcFilename :: FilePath,
- ghcMbDocOpts :: Maybe String,
- ghcHaddockModInfo :: HaddockModInfo Name,
- ghcMbDoc :: Maybe (HsDoc Name),
- ghcGroup :: HsGroup Name,
- ghcMbExports :: Maybe [LIE Name],
- ghcExportedNames :: [Name],
- ghcNamesInScope :: [Name],
- ghcInstances :: [Instance]
-}
-
-
-typecheckFiles :: Session -> [FilePath] -> IO [GhcModule]
-typecheckFiles session files = do
- checkedMods <- sortAndCheckModules session files
- return (map mkGhcModule checkedMods)
-
-
--- | Get the sorted graph of all loaded modules and their dependencies
-getSortedModuleGraph :: Session -> IO [(Module, FilePath)]
-getSortedModuleGraph session = do
- mbModGraph <- depanal session [] True
- moduleGraph <- case mbModGraph of
- Just mg -> return mg
- Nothing -> throwE "Failed to load all modules"
- let
- getModFile = fromJust . ml_hs_file . ms_location
- sortedGraph = topSortModuleGraph False moduleGraph Nothing
- sortedModules = concatMap flattenSCC sortedGraph
- modsAndFiles = [ (ms_mod modsum, getModFile modsum) |
- modsum <- sortedModules ]
- return modsAndFiles
-
-
-type CheckedMod = (Module, FilePath, FullyCheckedMod)
-
-
-type FullyCheckedMod = (ParsedSource,
- RenamedSource,
- TypecheckedSource,
- ModuleInfo)
-
-
--- TODO: make it handle cleanup
-sortAndCheckModules :: Session -> [FilePath] -> IO [CheckedMod]
-sortAndCheckModules session files = do
-
- -- load all argument files
-
- targets <- mapM (\f -> guessTarget f Nothing) files
- setTargets session targets
-
- -- compute the dependencies and load them as well
-
- allMods <- getSortedModuleGraph session
- targets' <- mapM (\(_, f) -> guessTarget f Nothing) allMods
- setTargets session targets'
-
- flag <- load session LoadAllTargets
- when (failed flag) $
- throwE "Failed to load all needed modules"
-
- -- typecheck the argument modules
-
- let argMods = filter ((`elem` files) . snd) allMods
-
- checkedMods <- forM argMods $ \(mod, file) -> do
- mbMod <- checkModule session (moduleName mod) False
- case mbMod of
- Just (CheckedModule a (Just b) (Just c) (Just d) _)
- -> return (mod, file, (a,b,c,d))
- _ -> throwE ("Failed to check module: " ++ moduleString mod)
-
- return checkedMods
-
-
--- | Dig out what we want from the typechecker output
-mkGhcModule :: CheckedMod -> GhcModule
-mkGhcModule (mod, file, checkedMod) = GhcModule {
- ghcModule = mod,
- ghcFilename = file,
- ghcMbDocOpts = mbOpts,
- ghcHaddockModInfo = info,
- ghcMbDoc = mbDoc,
- ghcGroup = group,
- ghcMbExports = mbExports,
- ghcExportedNames = modInfoExports modInfo,
- ghcNamesInScope = fromJust $ modInfoTopLevelScope modInfo,
- ghcInstances = modInfoInstances modInfo
-}
- where
- HsModule _ _ _ _ _ mbOpts _ _ = unLoc parsed
- (group, _, mbExports, mbDoc, info) = renamed
- (parsed, renamed, _, modInfo) = checkedMod
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index b1ce11f1..44e8d7fd 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -8,9 +8,11 @@
module Haddock.Types where
+import Data.Map
+import Control.Monad.Writer
+
import GHC hiding (NoLink)
import Outputable
-import Data.Map
data DocOption
@@ -75,7 +77,7 @@ data ExportItem name
type InstHead name = ([HsPred name], name, [HsType name])
type ModuleMap = Map Module HaddockModule
type DocMap = Map Name (HsDoc DocName)
-type DocEnv = Map Name Name
+type LinkEnv = Map Name Name
data DocName = Link Name | NoLink Name
@@ -86,6 +88,26 @@ instance Outputable DocName where
ppr (NoLink n) = ppr n
+-- | Information about a home package module that we get from GHC's typechecker
+data GhcModule = GhcModule {
+ ghcModule :: Module,
+ ghcFilename :: FilePath,
+ ghcMbDocOpts :: Maybe String,
+ ghcHaddockModInfo :: HaddockModInfo Name,
+ ghcMbDoc :: Maybe (HsDoc Name),
+ ghcGroup :: HsGroup Name,
+ ghcMbExports :: Maybe [LIE Name],
+ ghcExportedNames :: [Name],
+ ghcNamesInScope :: [Name],
+ ghcInstances :: [Instance]
+}
+
+
+-- | This is the data used to render a Haddock page for a module - it is the
+-- "interface" of the module. The core of Haddock lies in creating this
+-- structure (see Haddock.Interface).
+--
+-- The structure also holds intermediate data needed during its creation.
data HaddockModule = HM {
-- | A value to identify the module
@@ -151,3 +173,9 @@ data DocMarkup id a = Markup {
markupURL :: String -> a,
markupAName :: String -> a
}
+
+
+-- A monad which collects error messages
+
+type ErrMsg = String
+type ErrMsgM a = Writer [ErrMsg] a
diff --git a/src/Haddock/Utils/GHC.hs b/src/Haddock/Utils/GHC.hs
deleted file mode 100644
index 3ac90d77..00000000
--- a/src/Haddock/Utils/GHC.hs
+++ /dev/null
@@ -1,76 +0,0 @@
---
--- Haddock - A Haskell Documentation Tool
---
--- (c) Simon Marlow 2003
---
-
-
-module Haddock.Utils.GHC where
-
-
-import Debug.Trace
-import Data.Char
-
-import GHC
-import HsSyn
-import SrcLoc
-import HscTypes
-import Outputable
-import Packages
-import UniqFM
-import Name
-
-
--- names
-
-nameOccString = occNameString . nameOccName
-
-
-nameSetMod n newMod =
- mkExternalName (nameUnique n) newMod (nameOccName n) (nameSrcSpan n)
-
-
-nameSetPkg pkgId n =
- mkExternalName (nameUnique n) (mkModule pkgId (moduleName mod))
- (nameOccName n) (nameSrcSpan n)
- where mod = nameModule n
-
-
--- modules
-
-
-moduleString :: Module -> String
-moduleString = moduleNameString . moduleName
-
-
-mkModuleNoPkg :: String -> Module
-mkModuleNoPkg str = mkModule (stringToPackageId "") (mkModuleName str)
-
-
--- misc
-
-
--- 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)
-
-
-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/Main.hs b/src/Main.hs
index 8f3eda4e..c127f773 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -10,73 +10,35 @@
module Main (main) where
-import Haddock.Html
-import Haddock.Hoogle
-import Haddock.Rename
+import Haddock.Packages
+import Haddock.Backends.Html
+import Haddock.Backends.Hoogle
+import Haddock.Interface
import Haddock.Types hiding (NoLink)
-import Haddock.Utils
import Haddock.Version
import Haddock.InterfaceFile
import Haddock.Exception
import Haddock.Options
-import Haddock.Typecheck
-import Haddock.Packages
-import Haddock.Utils.GHC
+import Haddock.GHC
+import Haddock.Utils
import Paths_haddock
-
-import Prelude hiding (catch)
-import Control.Exception
import Control.Monad
-import Control.Monad.Writer
-import Control.Arrow
-import Data.Char
-import Data.IORef
-import Data.Ord
-import Data.List
-import Data.Maybe
-import Data.Typeable
-import Data.Graph hiding (flattenSCC)
+import Control.Exception
+import Control.Exception
import Data.Dynamic
-import Data.Foldable (foldlM)
-import System.Console.GetOpt
-import System.Environment
-import System.Directory
-import System.FilePath
-import System.Cmd
-import System.Exit
-import System.IO
-
+import Data.Maybe
+import Data.IORef
import qualified Data.Map as Map
-import Data.Map (Map)
-
-import Distribution.InstalledPackageInfo
-import Distribution.Simple.Utils
-
+import System.IO
+import System.Exit
+import System.Environment
import GHC
-import Outputable
-import SrcLoc
-import Name
-import Module
-import InstEnv
-import Class
-import TypeRep
-import Var hiding (varName)
-import TyCon
-import PrelNames
+import DynFlags
import Bag
-import HscTypes
import Util (handleDyn)
-import ErrUtils (printBagOfErrors)
-import UniqFM
-
-import FastString
-#define FSLIT(x) (mkFastString# (x#))
-
-import DynFlags hiding (Option)
-import Packages hiding (package)
-import StaticFlags
+import ErrUtils
--------------------------------------------------------------------------------
@@ -140,50 +102,48 @@ main = handleTopExceptions $ do
-- parse command-line flags and handle some of them initially
args <- getArgs
(flags, fileArgs) <- parseHaddockOpts args
- libDir <- handleFlags flags fileArgs
+ libDir <- handleEasyFlags flags fileArgs
-- initialize GHC
restGhcFlags <- tryParseStaticFlags flags
- (session, _) <- startGHC libDir
+ (session, _) <- startGhc libDir
- -- parse and set the ghc flags
+ -- parse and set the GHC flags
dynflags <- parseGhcFlags session restGhcFlags
setSessionDynFlags session dynflags
- -- get the -use-package packages, expose them to GHC,
- -- and try to load their installed HaddockPackages
+ -- get the -use-package packages, load them in GHC,
+ -- and try to get the corresponding installed HaddockPackages
let usePackages = [ pkg | Flag_UsePackage pkg <- flags ]
- packages <- initAndReadPackages session usePackages
+ pkgInfos <- loadPackages session usePackages
+ packages <- getHaddockPackages pkgInfos
-- typecheck argument modules using GHC
modules <- typecheckFiles session fileArgs
- -- update the html references for rendering phase (global variable)
+ -- combine the link envs of the external packages into one
+ let extLinks = combineLinkEnvs packages
+
+ -- create the interfaces -- this is the core part of Haddock
+ let (interfaces, homeLinks, messages) = createInterfaces modules extLinks flags
+ mapM_ putStrLn messages
+
+ -- render the interfaces
updateHTMLXRefs packages
+ render flags interfaces
- -- combine the doc envs of the read packages into one
- let env = combineDocEnvs packages
+ -- last but not least, dump the interface file!
+ dumpInterfaceFile homeLinks flags
- -- TODO: continue to break up the run function into parts
- run flags modules env
+-------------------------------------------------------------------------------
+-- Rendering
+-------------------------------------------------------------------------------
-startGHC :: String -> IO (Session, DynFlags)
-startGHC libDir = do
- session <- newSession (Just libDir)
- flags <- getSessionDynFlags session
- let flags' = dopt_set flags Opt_Haddock
- let flags'' = flags' {
- hscTarget = HscNothing,
- ghcMode = CompManager,
- ghcLink = NoLink
- }
- setSessionDynFlags session flags''
- return (session, flags'')
-
-run :: [Flag] -> [GhcModule] -> Map Name Name -> IO ()
-run flags modules extEnv = do
+-- | Render the interfaces with whatever backend is specified in the flags
+render :: [Flag] -> [HaddockModule] -> IO ()
+render flags interfaces = do
let
title = case [str | Flag_Heading str <- flags] of
[] -> ""
@@ -229,23 +189,9 @@ run flags modules extEnv = do
prologue <- getPrologue flags
- let
- -- run pass 1 on this data
- (modMap, messages) = runWriter (pass1 modules flags)
-
- haddockMods = catMaybes [ Map.lookup (ghcModule m) modMap | m <- modules ]
- homeEnv = buildGlobalDocEnv haddockMods
- env = homeEnv `Map.union` extEnv
- haddockMods' = attachInstances haddockMods
- (haddockMods'', messages') = runWriter $ mapM (renameModule env) haddockMods'
-
- mapM_ putStrLn messages
- mapM_ putStrLn messages'
-
let
- visibleMods = [ m | m <- haddockMods'', OptHide `notElem` (hmod_options m) ]
- packageName = (Just . packageIdString . modulePackageId .
- hmod_mod . head) visibleMods
+ visibleMods = [ m | m <- interfaces, OptHide `notElem` (hmod_options m) ]
+ packageName = (Just . modulePkgStr . hmod_mod . head) visibleMods
when (Flag_GenIndex `elem` flags) $ do
ppHtmlIndex odir title packageName maybe_html_help_format
@@ -269,23 +215,24 @@ run flags modules extEnv = do
maybe_contents_url maybe_index_url
copyHtmlBits odir libdir css_file
- let iface = InterfaceFile {
- ifDocEnv = homeEnv
--- ifModules = map hmod2interface visibleMods
- }
-
- case [str | Flag_DumpInterface str <- flags] of
- [] -> return ()
- fs -> let filename = (last fs) in
- writeInterfaceFile filename iface
-
-------------------------------------------------------------------------------
--- Flags
+-- Misc
-------------------------------------------------------------------------------
-handleFlags flags fileArgs = do
+dumpInterfaceFile :: LinkEnv -> [Flag] -> IO ()
+dumpInterfaceFile homeLinks flags =
+ case [str | Flag_DumpInterface str <- flags] of
+ [] -> return ()
+ fs -> let filename = last fs in writeInterfaceFile filename ifaceFile
+ where
+ ifaceFile = InterfaceFile {
+ ifLinkEnv = homeLinks
+ }
+
+
+handleEasyFlags flags fileArgs = do
usage <- getUsage
when (Flag_Help `elem` flags) (bye usage)
@@ -301,318 +248,12 @@ handleFlags flags fileArgs = do
throwE ("-h cannot be used with --gen-index or --gen-contents")
return ghcLibDir
-
-
--- | Filter out the GHC specific flags and try to parse and set them as static
--- flags. Return a list of flags that couldn't be parsed.
-tryParseStaticFlags flags = do
- let ghcFlags = [ str | Flag_GhcFlag str <- flags ]
- parseStaticFlags ghcFlags
-
-
--- | Try to parse dynamic GHC flags
-parseGhcFlags session ghcFlags = do
- dflags <- getSessionDynFlags session
- foldlM parseFlag dflags (map words ghcFlags)
- where
- -- try to parse a flag as either a dynamic or static GHC flag
- parseFlag dynflags ghcFlag = do
- (dynflags', rest) <- parseDynamicFlags dynflags ghcFlag
- when (rest == ghcFlag) $
- throwE ("Couldn't parse GHC flag: " ++ (unwords ghcFlag))
- return dynflags'
-
-
-byeVersion =
- bye ("Haddock version " ++ projectVersion ++
- ", (c) Simon Marlow 2003; ported to the GHC-API by David Waern 2006\n")
-
-
--------------------------------------------------------------------------------
--- Phase 1
--------------------------------------------------------------------------------
-
-
--- | Produce a map of HaddockModules with information that is close to
--- renderable. What is lacking after this pass are the renamed export items.
-pass1 :: [GhcModule] -> [Flag] -> ErrMsgM ModuleMap
-pass1 modules flags = foldM produceAndInsert Map.empty modules
- where
- produceAndInsert modMap modData = do
- resultMod <- pass1data modData flags modMap
- let key = ghcModule modData
- return (Map.insert key resultMod modMap)
-
-
--- | Massage the data in GhcModule to produce something closer to what
--- we want to render. To do this, we need access to modules before this one
--- in the topological sort, to which we have already done this conversion.
--- That's what's in the ModuleMap.
-pass1data :: GhcModule -> [Flag] -> ModuleMap -> ErrMsgM HaddockModule
-pass1data modData flags modMap = do
-
- let mod = ghcModule modData
-
- opts <- mkDocOpts (ghcMbDocOpts modData) mod
-
- let group = ghcGroup modData
- entities = (nubBy sameName . collectEntities) group
- exports = fmap (reverse . map unLoc) (ghcMbExports modData)
- entityNames_ = entityNames entities
- subNames = allSubNames group
- localNames = entityNames_ ++ subNames
- subMap = mkSubMap group
- expDeclMap = mkDeclMap (ghcExportedNames modData) group
- localDeclMap = mkDeclMap entityNames_ group
- docMap = mkDocMap group
- ignoreExps = Flag_IgnoreAllExports `elem` flags
-
- visibleNames <- mkVisibleNames mod modMap localNames (ghcNamesInScope modData)
- subMap exports opts localDeclMap
-
- exportItems <- mkExportItems modMap mod (ghcExportedNames modData)
- expDeclMap localDeclMap subMap entities
- opts exports ignoreExps docMap
-
- -- prune the export list to just those declarations that have
- -- documentation, if the 'prune' option is on.
- let
- prunedExportItems
- | OptPrune `elem` opts = pruneExportItems exportItems
- | otherwise = exportItems
-
- return HM {
- hmod_mod = mod,
- hmod_orig_filename = ghcFilename modData,
- hmod_info = ghcHaddockModInfo modData,
- hmod_doc = ghcMbDoc modData,
- hmod_rn_doc = Nothing,
- hmod_options = opts,
- hmod_locals = localNames,
- hmod_doc_map = docMap,
- hmod_rn_doc_map = Map.empty,
- hmod_sub_map = subMap,
- hmod_export_items = prunedExportItems,
- hmod_rn_export_items = [],
- hmod_exports = ghcExportedNames modData,
- hmod_visible_exports = visibleNames,
- hmod_exported_decl_map = expDeclMap,
- hmod_instances = ghcInstances modData
- }
- where
- mkDocOpts mbOpts mod = do
- opts <- case mbOpts of
- Just opts -> processOptions opts
- Nothing -> return []
- let opts' = if Flag_HideModule (moduleString mod) `elem` flags
- then OptHide : opts
- else opts
- return opts'
-
-
-sameName (DocEntity _) _ = False
-sameName (DeclEntity _) (DocEntity _) = False
-sameName (DeclEntity a) (DeclEntity b) = a == b
-
-
--- This map includes everything that can be exported separately,
--- that means: top declarations, class methods and record selectors
--- TODO: merge this with mkDeclMap and the extractXXX functions
-mkDocMap :: HsGroup Name -> Map Name (HsDoc Name)
-mkDocMap group = Map.fromList (topDeclDocs ++ classMethDocs ++ recordFieldDocs)
- where
- tyclds = map unLoc (hs_tyclds group)
- classes = filter isClassDecl tyclds
- datadecls = filter isDataDecl tyclds
- constrs = [ con | d <- datadecls, L _ con <- tcdCons d ]
- fields = concat [ fields | RecCon fields <- map con_details constrs]
-
- topDeclDocs = collectDocs (collectEntities group)
- classMethDocs = concatMap (collectDocs . collectClassEntities) classes
-
- recordFieldDocs = [ (unLoc lname, doc) |
- ConDeclField lname _ (Just (L _ doc)) <- fields ]
-
-
---------------------------------------------------------------------------------
--- Source code entities
---------------------------------------------------------------------------------
-
-
-data Entity = DocEntity (DocDecl Name) | DeclEntity Name
-data LEntity = Located Entity
-
-
-sortByLoc = map unLoc . sortBy (comparing getLoc)
-
-
--- | Collect all the entities in a class that can be documented.
--- The entities are sorted by their SrcLoc.
-collectClassEntities tcd = sortByLoc (docs ++ meths ++ sigs)
- where
- docs = [ L l (DocEntity d) | L l d <- tcdDocs tcd ]
- meths =
- let bindings = bagToList (tcdMeths tcd)
- bindingName = unLoc . fun_id
- in [ L l (DeclEntity (bindingName b)) | L l b <- bindings ]
- sigs =
- let sigName = fromJust . sigNameNoLoc
- in [ L l (DeclEntity (sigName sig)) | L l sig <- tcdSigs tcd ]
-
-
--- | Collect all the entities in the source file that can be documented.
--- The entities are sorted by their SrcLoc.
-collectEntities :: HsGroup Name -> [Entity]
-collectEntities group = sortByLoc (docs ++ declarations)
where
- docs = [ L l (DocEntity d) | L l d <- hs_docs group ]
-
- declarations = [ L l (DeclEntity n) | (l, n) <- valds ++ tyclds ++ fords ]
- where
- valds = let ValBindsOut _ sigs = hs_valds group
- -- we just use the sigs here for now.
- -- TODO: collect from the bindings as well
- -- (needed for docs to work for inferred entities)
- in [ (l, fromJust (sigNameNoLoc s)) | L l s <- sigs ]
- tyclds = [ (l, tcdName t) | L l t <- hs_tyclds group ]
- fords = [ (l, forName f) | L l f <- hs_fords group ]
- where
- forName (ForeignImport name _ _) = unLoc name
- forName (ForeignExport name _ _) = unLoc name
-
-
---------------------------------------------------------------------------------
--- Collect docs
---------------------------------------------------------------------------------
-
-
--- | Collect the docs and attach them to the right name
-collectDocs :: [Entity] -> [(Name, HsDoc Name)]
-collectDocs entities = collect Nothing DocEmpty entities
-
-
-collect :: Maybe Entity -> HsDoc Name -> [Entity] -> [(Name, HsDoc Name)]
-collect d doc_so_far [] =
- case d of
- Nothing -> []
- Just d0 -> finishedDoc d0 doc_so_far []
-
-collect d doc_so_far (e:es) =
- case e of
- DocEntity (DocCommentNext str) ->
- case d of
- Nothing -> collect d (docAppend doc_so_far str) es
- Just d0 -> finishedDoc d0 doc_so_far (collect Nothing str es)
-
- DocEntity (DocCommentPrev str) -> collect d (docAppend doc_so_far str) es
-
- _ -> case d of
- Nothing -> collect (Just e) doc_so_far es
- Just d0
- | sameName d0 e -> collect d doc_so_far es
- | otherwise -> finishedDoc d0 doc_so_far (collect (Just e) DocEmpty es)
-
-
-finishedDoc :: Entity -> HsDoc Name -> [(Name, HsDoc Name)] ->
- [(Name, HsDoc Name)]
-finishedDoc d DocEmpty rest = rest
-finishedDoc (DeclEntity name) doc rest = (name, doc) : rest
-finishedDoc _ _ rest = rest
-
-
--------------------------------------------------------------------------------
---
--------------------------------------------------------------------------------
-
-
-allSubNames :: HsGroup Name -> [Name]
-allSubNames group =
- concat [ tail (map unLoc (tyClDeclNames tycld)) | L _ tycld <- hs_tyclds group ]
-
-
-mkSubMap :: HsGroup Name -> Map Name [Name]
-mkSubMap group = Map.fromList [ (name, subs) | L _ tycld <- hs_tyclds group,
- let name:subs = map unLoc (tyClDeclNames tycld) ]
-
-
-mkDeclMap :: [Name] -> HsGroup Name -> Map Name (LHsDecl Name)
-mkDeclMap names group = Map.fromList [ (n,d) | (n,Just d) <- maybeDecls ]
- where
- maybeDecls = [ (name, getDeclFromGroup group name) | name <- names ]
+ byeVersion = bye $
+ "Haddock version " ++ projectVersion ++
+ ", (c) Simon Marlow 2003; ported to the GHC-API by David Waern 2006\n"
-entityNames :: [Entity] -> [Name]
-entityNames entities = [ name | DeclEntity name <- entities ]
-{-
-getValSig :: Name -> HsValBinds Name -> TypeEnv -> Maybe (LSig Name)
-getValSig name (ValBindsOut recsAndBinds _) typEnv = case matchingBinds of
- [bind] -> -- OK we have found a binding that matches. Now look up the
- -- type, even though it may be present in the ValBindsOut
- let tything = lookupTypeEnv typeEnv name
- _ -> Nothing
- where
- binds = snd $ unzip recsAndBinds
- matchingBinds = Bag.filter matchesName binds
- matchesName (L _ bind) = fun_id bind == name
-getValSig _ _ _ = error "getValSig"
--}
-
-
-getDeclFromGroup :: HsGroup Name -> Name -> Maybe (LHsDecl Name)
-getDeclFromGroup group name =
- case catMaybes [ getDeclFromVals (hs_valds group),
- getDeclFromTyCls (hs_tyclds group),
- getDeclFromFors (hs_fords group) ] of
- [decl] -> Just decl
- _ -> Nothing
- where
- getDeclFromVals (ValBindsOut _ lsigs) = case matching of
- [lsig] -> Just (L (getLoc lsig) (SigD (unLoc lsig)))
- _ -> Nothing
- where
- matching = [ lsig | lsig <- lsigs, let Just n = sigName lsig, n == name,
- isNormal (unLoc lsig) ]
- isNormal (TypeSig _ _) = True
- isNormal _ = False
-
- getDeclFromVals _ = error "getDeclFromVals: illegal input"
-
-{- getDeclFromVals (ValBindsOut recsAndbinds _) =
- let binds = snd $ unzip recsAndBinds
- matchingBinds = Bag.filter matchesName binds
- matchesName (L _ bind) = fun_id bind == name
- in case matchingBinds of
- [bind] -> -- OK we have found a binding that matches. Now look up the
- -- type, even though it may be present in the ValBindsOut
-
- _ -> Nothing
- where
- matching = [ lsig | lsig <- lsigs, let Just n = sigName lsig, n == name ]
- getDeclFromVals _ = error "getDeclFromVals: illegal input"
- -}
- getDeclFromTyCls ltycls = case matching of
- [ltycl] -> Just (L (getLoc ltycl) (TyClD (unLoc ltycl)))
- _ -> Nothing
- where
- matching = [ ltycl | ltycl <- ltycls,
- name `elem` map unLoc (tyClDeclNames (unLoc ltycl))]
-
- getDeclFromFors lfors = case matching of
- [for] -> Just (L (getLoc for) (ForD (unLoc for)))
- _ -> Nothing
- where
- matching = [ for | for <- lfors, forName (unLoc for) == name ]
- forName (ForeignExport n _ _) = unLoc n
- forName (ForeignImport n _ _) = unLoc n
-
-
-parseIfaceOption :: String -> (FilePath,FilePath)
-parseIfaceOption s =
- case break (==',') s of
- (fpath,',':file) -> (fpath,file)
- (file, _) -> ("", file)
-
-
updateHTMLXRefs :: [HaddockPackage] -> IO ()
updateHTMLXRefs packages = do
writeIORef html_xrefs_ref (Map.fromList mapping)
@@ -631,452 +272,3 @@ getPrologue flags
Left err -> throwE err
Right doc -> return (Just doc)
_otherwise -> throwE "multiple -p/--prologue options"
-
-
--------------------------------------------------------------------------------
--- Phase 2
--------------------------------------------------------------------------------
-
-
-renameModule :: Map Name Name -> HaddockModule -> ErrMsgM HaddockModule
-renameModule renamingEnv mod =
-
- -- first create the local env, where every name exported by this module
- -- is mapped to itself, and everything else comes from the global renaming
- -- env
- let localEnv = foldl fn renamingEnv (hmod_visible_exports mod)
- where fn env name = Map.insert name (nameSetMod name (hmod_mod mod)) env
-
- docs = Map.toList (hmod_doc_map mod)
- renameMapElem (k,d) = do d' <- renameDoc d; return (k, d')
-
- -- rename names in the exported declarations to point to things that
- -- are closer to, or maybe even exported by, the current module.
- (renamedExportItems, missingNames1)
- = runRnFM localEnv (renameExportItems (hmod_export_items mod))
-
- (rnDocMap, missingNames2)
- = runRnFM localEnv (liftM Map.fromList (mapM renameMapElem docs))
-
- (finalModuleDoc, missingNames3)
- = runRnFM localEnv (renameMaybeDoc (hmod_doc mod))
-
- -- combine the missing names and filter out the built-ins, which would
- -- otherwise allways be missing.
- missingNames = nub $ filter isExternalName
- (missingNames1 ++ missingNames2 ++ missingNames3)
-
- -- filter out certain built in type constructors using their string
- -- representation. TODO: use the Name constants from the GHC API.
- strings = filter (`notElem` ["()", "[]", "(->)"])
- (map (showSDoc . ppr) missingNames)
-
- in do
- -- report things that we couldn't link to. Only do this for non-hidden
- -- modules.
- when (OptHide `notElem` hmod_options mod && not (null strings)) $
- tell ["Warning: " ++ show (ppr (hmod_mod mod) defaultUserStyle) ++
- ": could not find link destinations for:\n"++
- " " ++ concat (map (' ':) strings) ]
-
- return $ mod { hmod_rn_doc = finalModuleDoc,
- hmod_rn_doc_map = rnDocMap,
- hmod_rn_export_items = renamedExportItems }
-
-
--- | Build the list of items that will become the documentation, from the
--- export list. At this point, the list of ExportItems is in terms of
--- original names.
-mkExportItems
- :: ModuleMap
- -> Module -- this module
- -> [Name] -- exported names (orig)
- -> Map Name (LHsDecl Name) -- maps exported names to declarations
- -> Map Name (LHsDecl Name) -- maps local names to declarations
- -> Map Name [Name] -- sub-map for this module
- -> [Entity] -- entities in the current module
- -> [DocOption]
- -> Maybe [IE Name]
- -> Bool -- --ignore-all-exports flag
- -> Map Name (HsDoc Name)
- -> ErrMsgM [ExportItem Name]
-
-mkExportItems mod_map this_mod exported_names exportedDeclMap localDeclMap sub_map entities
- opts maybe_exps ignore_all_exports docMap
- | isNothing maybe_exps || ignore_all_exports || OptIgnoreExports `elem` opts
- = everything_local_exported
- | Just specs <- maybe_exps = do
- exps <- mapM lookupExport specs
- return (concat exps)
- where
- everything_local_exported = -- everything exported
- return (fullContentsOfThisModule this_mod entities localDeclMap docMap)
-
- packageId = modulePackageId this_mod
-
- lookupExport (IEVar x) = declWith x
- lookupExport (IEThingAbs t) = declWith t
- lookupExport (IEThingAll t) = declWith t
- lookupExport (IEThingWith t cs) = declWith t
- lookupExport (IEModuleContents m) = fullContentsOf (mkModule packageId m)
- lookupExport (IEGroup lev doc) = return [ ExportGroup lev "" doc ]
- lookupExport (IEDoc doc) = return [ ExportDoc doc ]
- lookupExport (IEDocNamed str)
- = do r <- findNamedDoc str entities
- case r of
- Nothing -> return []
- Just found -> return [ ExportDoc found ]
-
- declWith :: Name -> ErrMsgM [ ExportItem Name ]
- declWith t
- | (Just decl, maybeDoc) <- findDecl t
- = return [ ExportDecl t (restrictTo subs (extractDecl t mdl decl)) maybeDoc [] ]
- | otherwise
- = return []
- where
- mdl = nameModule t
- subs = filter (`elem` exported_names) all_subs
- all_subs | mdl == this_mod = Map.findWithDefault [] t sub_map
- | otherwise = allSubsOfName mod_map t
-
- fullContentsOf m
- | m == this_mod = return (fullContentsOfThisModule this_mod entities localDeclMap docMap)
- | otherwise =
- case Map.lookup m mod_map of
- Just hmod
- | OptHide `elem` hmod_options hmod
- -> return (hmod_export_items hmod)
- | otherwise -> return [ ExportModule m ]
- Nothing -> return [] -- already emitted a warning in visibleNames
-
- findDecl :: Name -> (Maybe (LHsDecl Name), Maybe (HsDoc Name))
- findDecl n | not (isExternalName n) = error "This shouldn't happen"
- findDecl n
- | m == this_mod = (Map.lookup n exportedDeclMap, Map.lookup n docMap)
- | otherwise =
- case Map.lookup m mod_map of
- Just hmod -> (Map.lookup n (hmod_exported_decl_map hmod),
- Map.lookup n (hmod_doc_map hmod))
- Nothing -> (Nothing, Nothing)
- where
- m = nameModule n
-
-
-fullContentsOfThisModule :: Module -> [Entity] -> Map Name (LHsDecl Name) ->
- Map Name (HsDoc Name) -> [ExportItem Name]
-fullContentsOfThisModule module_ entities declMap docMap
- = catMaybes (map mkExportItem entities)
- where
- mkExportItem (DocEntity (DocGroup lev doc)) = Just (ExportGroup lev "" doc)
- mkExportItem (DeclEntity name) = fmap mkExport (Map.lookup name declMap)
- where mkExport decl = ExportDecl name decl (Map.lookup name docMap) []
- mkExportItem _ = Nothing
-
-
--- | Sometimes the declaration we want to export is not the "main" declaration:
--- it might be an individual record selector or a class method. In these
--- cases we have to extract the required declaration (and somehow cobble
--- together a type signature for it...)
-extractDecl :: Name -> Module -> LHsDecl Name -> LHsDecl Name
-extractDecl name mdl decl
- | Just n <- getMainDeclBinder (unLoc decl), n == name = decl
- | otherwise =
- case unLoc decl of
- TyClD d | isClassDecl d ->
- let matches = [ sig | sig <- tcdSigs d, sigName sig == Just name ]
- in case matches of
- [s0] -> let (n, tyvar_names) = name_and_tyvars d
- L pos sig = extractClassDecl n mdl tyvar_names s0
- in L pos (SigD sig)
- _ -> error "internal: extractDecl"
- TyClD d | isDataDecl d ->
- let (n, tyvar_names) = name_and_tyvars d
- L pos sig = extractRecSel name mdl n tyvar_names (tcdCons d)
- in L pos (SigD sig)
- _ -> error "internal: extractDecl"
- where
- name_and_tyvars d = (unLoc (tcdLName d), hsLTyVarLocNames (tcdTyVars d))
-
-
-toTypeNoLoc :: Located Name -> LHsType Name
-toTypeNoLoc lname = noLoc (HsTyVar (unLoc lname))
-
-
-rmLoc :: Located a -> Located a
-rmLoc a = noLoc (unLoc a)
-
-
-extractClassDecl :: Name -> Module -> [Located Name] -> LSig Name -> LSig Name
-extractClassDecl c mdl tvs0 (L pos (TypeSig lname ltype)) = case ltype of
- L _ (HsForAllTy exp tvs (L _ preds) ty) ->
- L pos (TypeSig lname (noLoc (HsForAllTy exp tvs (lctxt preds) ty)))
- _ -> L pos (TypeSig lname (noLoc (mkImplicitHsForAllTy (lctxt []) ltype)))
- where
- lctxt preds = noLoc (ctxt preds)
- ctxt preds = [noLoc (HsClassP c (map toTypeNoLoc tvs0))] ++ preds
-
-extractClassDecl _ _ _ d = error $ "extractClassDecl: unexpected decl"
-
-
-extractRecSel :: Name -> Module -> Name -> [Located Name] -> [LConDecl Name]
- -> LSig Name
-extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
-
-extractRecSel nm mdl t tvs (L _ con : rest) =
- case con_details con of
- RecCon fields | (ConDeclField n ty _ : _) <- matching_fields fields ->
- L (getLoc n) (TypeSig (noLoc nm) (noLoc (HsFunTy data_ty (getBangType ty))))
- _ -> extractRecSel nm mdl t tvs rest
- where
- matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, (unLoc n) == nm ]
- data_ty = foldl (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) (map toTypeNoLoc tvs)
-
-
--- Pruning
-pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
-pruneExportItems items = filter hasDoc items
- where hasDoc (ExportDecl _ _ d _) = isJust d
- hasDoc _ = True
-
-
--- | Gather a list of original names exported from this module
-mkVisibleNames :: Module
- -> ModuleMap
- -> [Name]
- -> [Name]
- -> Map Name [Name]
- -> Maybe [IE Name]
- -> [DocOption]
- -> Map Name (LHsDecl Name)
- -> ErrMsgM [Name]
-
-mkVisibleNames mdl modMap localNames scope subMap maybeExps opts declMap
- -- if no export list, just return all local names
- | Nothing <- maybeExps = return (filter hasDecl localNames)
- | OptIgnoreExports `elem` opts = return localNames
- | Just expspecs <- maybeExps = do
- visibleNames <- mapM extract expspecs
- return $ filter isNotPackageName (concat visibleNames)
- where
- hasDecl name = isJust (Map.lookup name declMap)
- isNotPackageName name = nameMod == mdl || isJust (Map.lookup nameMod modMap)
- where nameMod = nameModule name
-
- extract e =
- case e of
- IEVar x -> return [x]
- IEThingAbs t -> return [t]
- IEThingAll t -> return (t : all_subs)
- where
- all_subs | nameModule t == mdl = Map.findWithDefault [] t subMap
- | otherwise = allSubsOfName modMap t
-
- IEThingWith t cs -> return (t : cs)
-
- IEModuleContents m
- | mkModule (modulePackageId mdl) m == mdl -> return localNames
- | otherwise -> let m' = mkModule (modulePackageId mdl) m in
- case Map.lookup m' modMap of
- Just mod
- | OptHide `elem` hmod_options mod ->
- return (filter (`elem` scope) (hmod_exports mod))
- | otherwise -> return []
- Nothing
- -> tell (exportModuleMissingErr mdl m') >> return []
-
- _ -> return []
-
-
-exportModuleMissingErr this mdl
- = ["Warning: in export list of " ++ show (moduleString this)
- ++ ": module not found: " ++ show (moduleString mdl)]
-
-
--- | For a given entity, find all the names it "owns" (ie. all the
--- constructors and field names of a tycon, or all the methods of a
--- class).
-allSubsOfName :: ModuleMap -> Name -> [Name]
-allSubsOfName mod_map name
- | isExternalName name =
- case Map.lookup (nameModule name) mod_map of
- Just hmod -> Map.findWithDefault [] name (hmod_sub_map hmod)
- Nothing -> []
- | otherwise = error $ "Main.allSubsOfName: unexpected unqual'd name"
-
-
--- | Build a mapping which for each original name, points to the "best"
--- place to link to in the documentation. For the definition of
--- "best", we use "the module nearest the bottom of the dependency
--- graph which exports this name", not including hidden modules. When
--- there are multiple choices, we pick a random one.
---
--- The interfaces are passed in in topologically sorted order, but we start
--- by reversing the list so we can do a foldl.
-buildGlobalDocEnv :: [HaddockModule] -> Map Name Name
-buildGlobalDocEnv modules
- = foldl upd Map.empty (reverse modules)
- where
- upd old_env mod
- | OptHide `elem` hmod_options mod
- = old_env
- | OptNotHome `elem` hmod_options mod
- = foldl' keep_old old_env exported_names
- | otherwise
- = foldl' keep_new old_env exported_names
- where
- exported_names = hmod_visible_exports mod
- modName = hmod_mod mod
-
- keep_old env n = Map.insertWith (\new old -> old)
- n (nameSetMod n modName) env
- keep_new env n = Map.insert n (nameSetMod n modName) env
-
-
--- Named documentation
-
-findNamedDoc :: String -> [Entity] -> ErrMsgM (Maybe (HsDoc Name))
-findNamedDoc name entities = search entities
- where search [] = do
- tell ["Cannot find documentation for: $" ++ name]
- return Nothing
- search ((DocEntity (DocCommentNamed name' doc)):rest)
- | name == name' = return (Just doc)
- | otherwise = search rest
- search (_other_decl : rest) = search rest
-
-
--- Haddock options embedded in the source file
-
-processOptions_ str = let (opts, msg) = runWriter (processOptions str)
- in print msg >> return opts
-
-processOptions :: String -> ErrMsgM [DocOption]
-processOptions str = do
- case break (== ',') str of
- (this, ',':rest) -> do
- opt <- parseOption this
- opts <- processOptions rest
- return (maybeToList opt ++ opts)
- (this, _)
- | all isSpace this -> return []
- | otherwise -> do opt <- parseOption this; return (maybeToList opt)
-
-
-parseOption :: String -> ErrMsgM (Maybe DocOption)
-parseOption "hide" = return (Just OptHide)
-parseOption "prune" = return (Just OptPrune)
-parseOption "ignore-exports" = return (Just OptIgnoreExports)
-parseOption "not-home" = return (Just OptNotHome)
-parseOption other = do tell ["Unrecognised option: " ++ other]; return Nothing
-
-
--- | Simplified type for sorting types, ignoring qualification (not visible
--- in Haddock output) and unifying special tycons with normal ones.
-data SimpleType = SimpleType Name [SimpleType] deriving (Eq,Ord)
-
-
-attachInstances :: [HaddockModule] -> [HaddockModule]
-attachInstances modules = map attach modules
- where
- instMap = fmap (map toHsInstHead . sortImage instHead) $ collectInstances modules
- attach mod = mod { hmod_export_items = newItems }
- where
- newItems = map attachExport (hmod_export_items mod)
-
- attachExport (ExportDecl n decl doc _) =
- ExportDecl n decl doc (case Map.lookup n instMap of
- Nothing -> []
- Just instheads -> instheads)
- attachExport otherExport = otherExport
-
-
-collectInstances
- :: [HaddockModule]
- -> Map Name [([TyVar], [PredType], Class, [Type])] -- maps class/type names to instances
-
-collectInstances modules
- = Map.fromListWith (flip (++)) tyInstPairs `Map.union`
- Map.fromListWith (flip (++)) classInstPairs
- where
- allInstances = concat (map hmod_instances modules)
- classInstPairs = [ (is_cls inst, [instanceHead inst]) |
- inst <- allInstances ]
- tyInstPairs = [ (tycon, [instanceHead inst]) | inst <- allInstances,
- Just tycon <- nub (is_tcs inst) ]
-
-
-instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType])
-instHead (_, _, cls, args)
- = (map argCount args, className cls, map simplify args)
- where
- argCount (AppTy t _) = argCount t + 1
- argCount (TyConApp _ ts) = length ts
- argCount (FunTy _ _ ) = 2
- argCount (ForAllTy _ t) = argCount t
- argCount (NoteTy _ t) = argCount t
- argCount _ = 0
-
- simplify (ForAllTy _ t) = simplify t
- simplify (FunTy t1 t2) =
- SimpleType funTyConName [simplify t1, simplify t2]
- simplify (AppTy t1 t2) = SimpleType s (args ++ [simplify t2])
- where (SimpleType s args) = simplify t1
- simplify (TyVarTy v) = SimpleType (tyVarName v) []
- simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts)
- simplify (NoteTy _ t) = simplify t
- simplify _ = error "simplify"
-
-
--- sortImage f = sortBy (\x y -> compare (f x) (f y))
-sortImage :: Ord b => (a -> b) -> [a] -> [a]
-sortImage f xs = map snd $ sortBy cmp_fst [(f x, x) | x <- xs]
- where cmp_fst (x,_) (y,_) = compare x y
-
-
-funTyConName = mkWiredInName gHC_PRIM
- (mkOccNameFS tcName FSLIT("(->)"))
- funTyConKey
- (ATyCon funTyCon) -- Relevant TyCon
- BuiltInSyntax
-
-
-toHsInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name
-toHsInstHead (_, preds, cls, ts) = (map toHsPred preds, className cls, map toHsType ts)
-
-
---------------------------------------------------------------------------------
--- Type -> HsType conversion
---------------------------------------------------------------------------------
-
-
-toHsPred :: PredType -> HsPred Name
-toHsPred (ClassP cls ts) = HsClassP (className cls) (map toLHsType ts)
-toHsPred (IParam n t) = HsIParam n (toLHsType t)
-
-
-toLHsType = noLoc . toHsType
-
-
-toHsType :: Type -> HsType Name
-toHsType t = case t of
- TyVarTy v -> HsTyVar (tyVarName v)
- AppTy a b -> HsAppTy (toLHsType a) (toLHsType b)
- TyConApp tc ts -> case ts of
- [] -> HsTyVar (tyConName tc)
- _ -> app (tycon tc) ts
- FunTy a b -> HsFunTy (toLHsType a) (toLHsType b)
- ForAllTy v t -> cvForAll [v] t
- PredTy p -> HsPredTy (toHsPred p)
- NoteTy _ t -> toHsType t
- where
- tycon tc = HsTyVar (tyConName tc)
- app tc ts = foldl (\a b -> HsAppTy (noLoc a) (noLoc b)) tc (map toHsType ts)
- cvForAll vs (ForAllTy v t) = cvForAll (v:vs) t
- cvForAll vs t = mkExplicitHsForAllTy (tyvarbinders vs) (noLoc []) (toLHsType t)
- tyvarbinders vs = map (noLoc . UserTyVar . tyVarName) vs
-
-
--- A monad which collects error messages
-
-type ErrMsg = String
-type ErrMsgM a = Writer [ErrMsg] a
--
cgit v1.2.3