aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authordavve <davve@dtek.chalmers.se>2006-07-30 21:01:57 +0000
committerdavve <davve@dtek.chalmers.se>2006-07-30 21:01:57 +0000
commit7e00d4646b0ab3694cee32752d2a8bac04317446 (patch)
tree51aa4eaf5dede3de999e1ac6c63c53c1a1587bfe /src
parentc3f8f4f1ab6ef0e0ba46e838055c938c061b6161 (diff)
Start porting the Html renderer
Diffstat (limited to 'src')
-rw-r--r--src/HaddockDevHelp.hs32
-rw-r--r--src/HaddockHH.hs6
-rw-r--r--src/HaddockHH2.hs7
-rw-r--r--src/HaddockHtml.hs209
-rw-r--r--src/HaddockModuleTree.hs20
-rw-r--r--src/HaddockRename.hs39
-rw-r--r--src/HaddockTypes.hs30
-rw-r--r--src/HaddockUtil.hs79
-rw-r--r--src/Main.hs428
9 files changed, 344 insertions, 506 deletions
diff --git a/src/HaddockDevHelp.hs b/src/HaddockDevHelp.hs
index c16e474c..511cfe90 100644
--- a/src/HaddockDevHelp.hs
+++ b/src/HaddockDevHelp.hs
@@ -3,20 +3,22 @@ module HaddockDevHelp(ppDevHelpFile) where
import HaddockModuleTree
import HaddockTypes
import HaddockUtil
-import HsSyn2 hiding(Doc)
+import HsSyn2 hiding (Doc, Module)
import qualified Map
+import Module ( moduleString, Module )
+import Name ( Name, nameModule, getOccString )
+
+
import Data.Maybe ( fromMaybe )
import Text.PrettyPrint
-ppDevHelpFile :: FilePath -> String -> Maybe String -> [Interface] -> IO ()
-ppDevHelpFile odir doctitle maybe_package ifaces = do
+ppDevHelpFile :: FilePath -> String -> Maybe String -> [HaddockModule] -> IO ()
+ppDevHelpFile odir doctitle maybe_package modules = do
let devHelpFile = package++".devhelp"
- tree = mkModuleTree [ (iface_module iface,
- iface_package iface,
- toDescription iface)
- | iface <- ifaces ]
+ tree = mkModuleTree [ (hmod_mod mod, hmod_package 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<>
@@ -55,19 +57,21 @@ ppDevHelpFile odir doctitle maybe_package ifaces = do
(s':ss') = reverse (s:ss)
-- reconstruct the module name
- index :: [(HsName, [Module])]
- index = Map.toAscList (foldr getIfaceIndex Map.empty ifaces)
+ index :: [(Name, [Module])]
+ index = Map.toAscList (foldr getModuleIndex Map.empty modules)
- 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
+ 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 (Module mdl:refs) =
- text "<function name=\""<>text (escapeStr (show name))<>text"\" link=\""<>text (nameHtmlRef mdl name)<>text"\"/>" $$
+ ppReference name (mod:refs) = let modName = moduleString mod in
+ text "<function name=\""<>text (escapeStr (getOccString name))<>text"\" link=\""<>text (nameHtmlRef modName name)<>text"\"/>" $$
ppReference name refs
diff --git a/src/HaddockHH.hs b/src/HaddockHH.hs
index 937d382f..7e6ef394 100644
--- a/src/HaddockHH.hs
+++ b/src/HaddockHH.hs
@@ -1,5 +1,10 @@
module HaddockHH(ppHHContents, ppHHIndex, ppHHProject) where
+ppHHContents = error "not yet"
+ppHHIndex = error "not yet"
+ppHHProject = error "not yet"
+
+{-
import HaddockModuleTree
import HaddockTypes
import HaddockUtil
@@ -166,3 +171,4 @@ ppHHProject odir doctitle maybe_package ifaces pkg_paths = do
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/HaddockHH2.hs b/src/HaddockHH2.hs
index c4804190..c329e254 100644
--- a/src/HaddockHH2.hs
+++ b/src/HaddockHH2.hs
@@ -1,5 +1,11 @@
module HaddockHH2(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
@@ -173,3 +179,4 @@ ppHH2Collection odir doctitle maybe_package = do
text "<ItemMoniker Name=\"!SampleInfo\" ProgId=\"HxDs.HxSampleCollection\" InitData=\"\"/>") $$
text "</HelpCollection>"
writeFile (pathJoin [odir, collectionHH2File]) (render doc)
+-}
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index a383c85c..e9011d57 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -20,7 +20,7 @@ import HaddockModuleTree
import HaddockTypes
import HaddockUtil
import HaddockVersion
-import HsSyn2
+import HsSyn2 hiding ( DocMarkup(..), markup, idMarkup, Module(..) )
import Html
import qualified Html
import Map ( Map )
@@ -34,13 +34,22 @@ import Data.Maybe ( fromJust, isJust, mapMaybe, fromMaybe )
import Foreign.Marshal.Alloc ( allocaBytes )
import System.IO ( IOMode(..), hClose, hGetBuf, hPutBuf )
+import qualified GHC
+import Name
+import Module
+import RdrName hiding ( Qual )
+
-- 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)
+ppHtml = undefined
+ppHtmlHelpFiles = undefined
+
+
-- -----------------------------------------------------------------------------
-- Generating HTML documentation
-
+{-
ppHtml :: String
-> Maybe String -- package
-> [Interface]
@@ -100,7 +109,7 @@ ppHtmlHelpFiles doctitle maybe_package ifaces odir maybe_html_help_format pkg_pa
ppHH2Collection odir doctitle maybe_package
Just "devhelp" -> ppDevHelpFile odir doctitle maybe_package visible_ifaces
Just format -> fail ("The "++format++" format is not implemented")
-
+-}
copyFile :: FilePath -> FilePath -> IO ()
copyFile fromFPath toFPath =
(bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
@@ -139,32 +148,31 @@ footer =
toHtml ("version " ++ projectVersion)
)
-
-srcButton :: SourceURLs -> Maybe Interface -> HtmlTable
+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 iface) =
- let url = spliceURL (Just $ iface_orig_filename iface)
- (Just $ iface_module iface) Nothing src_module_url
+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 HsName -> String -> String
+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 (Module mod) -> mod
+ Just mod -> moduleString mod
(name, kind) =
case maybe_name of
- Nothing -> ("","")
- Just (n@(HsTyClsName _)) -> (escapeStr (hsNameStr n), "t")
- Just (n@(HsVarName _)) -> (escapeStr (hsNameStr n), "v")
+ Nothing -> ("","")
+ Just n | isValOcc (nameOccName n) -> (escapeStr (getOccString n), "v")
+ | otherwise -> (escapeStr (getOccString n), "t")
run "" = ""
run ('%':'M':rest) = mod ++ run rest
@@ -193,7 +201,6 @@ wikiButton (_, Just wiki_module_url, _) (Just mod) =
wikiButton _ _ =
Html.emptyTable
-
contentsButton :: Maybe String -> HtmlTable
contentsButton maybe_contents_url
= topButBox (anchor ! [href url] << toHtml "Contents")
@@ -223,10 +230,10 @@ simpleHeader doctitle maybe_contents_url maybe_index_url
contentsButton maybe_contents_url <-> indexButton maybe_index_url
))
-pageHeader :: String -> Interface -> String
+pageHeader :: String -> HaddockModule -> String
-> SourceURLs -> WikiURLs
-> Maybe String -> Maybe String -> HtmlTable
-pageHeader mdl iface doctitle
+pageHeader mdl hmod doctitle
maybe_source_url maybe_wiki_url
maybe_contents_url maybe_index_url =
(tda [theclass "topbar"] <<
@@ -235,8 +242,8 @@ pageHeader mdl iface doctitle
image ! [src "haskell_icon.gif", width "16", height 16, alt " "]
) <->
(tda [theclass "title"] << toHtml doctitle) <->
- srcButton maybe_source_url (Just iface) <->
- wikiButton maybe_wiki_url (Just $ iface_module iface) <->
+ srcButton maybe_source_url (Just hmod) <->
+ wikiButton maybe_wiki_url (Just $ hmod_mod hmod) <->
contentsButton maybe_contents_url <->
indexButton maybe_index_url
)
@@ -244,16 +251,16 @@ pageHeader mdl iface doctitle
tda [theclass "modulebar"] <<
(vanillaTable << (
(td << font ! [size "6"] << toHtml mdl) <->
- moduleInfo iface
+ moduleInfo hmod
)
)
-moduleInfo :: Interface -> HtmlTable
-moduleInfo iface =
+moduleInfo :: HaddockModule -> HtmlTable
+moduleInfo hmod =
let
- info = iface_info iface
+ info = hmod_info hmod
- doOneEntry :: (String,ModuleInfo -> Maybe String) -> Maybe HtmlTable
+ doOneEntry :: (String, (GHC.HaddockModInfo GHC.Name) -> Maybe String) -> Maybe HtmlTable
doOneEntry (fieldName,field) = case field info of
Nothing -> Nothing
Just fieldValue ->
@@ -262,9 +269,9 @@ moduleInfo iface =
entries :: [HtmlTable]
entries = mapMaybe doOneEntry [
- ("Portability",portability),
- ("Stability",stability),
- ("Maintainer",maintainer)
+ ("Portability",GHC.hmi_portability),
+ ("Stability",GHC.hmi_stability),
+ ("Maintainer",GHC.hmi_maintainer)
]
in
case entries of
@@ -282,15 +289,13 @@ ppHtmlContents
-> Maybe String
-> SourceURLs
-> WikiURLs
- -> [Interface] -> Maybe Doc
+ -> [HaddockModule] -> Maybe (GHC.HsDoc GHC.RdrName)
-> IO ()
ppHtmlContents odir doctitle
maybe_package maybe_html_help_format maybe_index_url
- maybe_source_url maybe_wiki_url mdls prologue = do
+ maybe_source_url maybe_wiki_url modules prologue = do
let tree = mkModuleTree
- [(iface_module iface,
- iface_package iface,
- toDescription iface) | iface <- mdls]
+ [(hmod_mod mod, hmod_package mod, toDescription mod) | mod <- modules]
html =
header
(documentCharacterEncoding +++
@@ -315,11 +320,11 @@ ppHtmlContents odir doctitle
Just "devhelp" -> return ()
Just format -> fail ("The "++format++" format is not implemented")
-ppPrologue :: String -> Maybe Doc -> HtmlTable
+ppPrologue :: String -> Maybe (GHC.HsDoc GHC.RdrName) -> HtmlTable
ppPrologue title Nothing = Html.emptyTable
ppPrologue title (Just doc) =
(tda [theclass "section1"] << toHtml title) </>
- docBox (docToHtml doc)
+ docBox (rdrDocToHtml doc)
ppModuleTree :: String -> [ModuleTree] -> HtmlTable
ppModuleTree _ ts =
@@ -356,10 +361,10 @@ mkNode ss (Node s leaf pkg short ts) depth id = htmlNode
shortDescr :: HtmlTable
shortDescr = case short of
Nothing -> td empty
- Just doc -> tda [theclass "rdoc"] (docToHtml doc)
+ Just doc -> tda [theclass "rdoc"] (origDocToHtml doc)
htmlModule
- | leaf = ppHsModule mdl
+ | leaf = ppModule mdl
| otherwise = toHtml s
htmlPkg = case pkg of
@@ -382,6 +387,10 @@ mkNode ss (Node s leaf pkg short ts) depth id = htmlNode
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
@@ -392,10 +401,10 @@ ppHtmlIndex :: FilePath
-> Maybe String
-> SourceURLs
-> WikiURLs
- -> [Interface]
+ -> [HaddockModule]
-> IO ()
ppHtmlIndex odir doctitle maybe_package maybe_html_help_format
- maybe_contents_url maybe_source_url maybe_wiki_url ifaces = do
+ maybe_contents_url maybe_source_url maybe_wiki_url modules = do
let html =
header (documentCharacterEncoding +++
thetitle (toHtml (doctitle ++ " (Index)")) +++
@@ -414,8 +423,8 @@ ppHtmlIndex odir doctitle maybe_package maybe_html_help_format
-- Generate index and contents page for Html Help if requested
case maybe_html_help_format of
Nothing -> return ()
- Just "mshelp" -> ppHHIndex odir maybe_package ifaces
- Just "mshelp2" -> ppHH2Index odir maybe_package ifaces
+ 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
@@ -456,7 +465,7 @@ ppHtmlIndex odir doctitle maybe_package maybe_html_help_format
index_part = [(n,stuff) | (n,stuff) <- this_ix, toUpper (head n) == c]
- index :: [(String, Map HsQName [(Module,Bool)])]
+ index :: [(String, Map GHC.Name [(Module,Bool)])]
index = sortBy cmp (Map.toAscList full_index)
where cmp (n1,_) (n2,_) = n1 `compare` n2
@@ -464,56 +473,49 @@ ppHtmlIndex odir doctitle maybe_package maybe_html_help_format
-- 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 HsQName [(Module,Bool)])
+ full_index :: Map String (Map GHC.Name [(Module,Bool)])
full_index = Map.fromListWith (flip (Map.unionWith (++)))
- (concat (map getIfaceIndex ifaces))
+ (concat (map getHModIndex modules))
- getIfaceIndex iface =
- [ (hsNameStr nm,
- Map.fromList [(orig, [(mdl, not (nm `elem` iface_reexported iface))])])
- | (nm, orig) <- Map.toAscList (iface_env iface) ]
- where mdl = iface_module iface
+ 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 HsQName [(Module,Bool)]) -> HtmlTable
+ indexElt :: (String, Map GHC.Name [(Module,Bool)]) -> HtmlTable
indexElt (str, entities) =
case Map.toAscList entities of
[(nm,entries)] ->
tda [ theclass "indexentry" ] << toHtml str <->
- indexLinks (unQual nm) entries
+ indexLinks nm entries
many_entities ->
tda [ theclass "indexentry" ] << toHtml str </>
aboves (map doAnnotatedEntity (zip [1..] many_entities))
- unQual (Qual _ nm) = nm
- unQual (UnQual nm) = nm
-
- doAnnotatedEntity (j,(qnm,entries))
+ doAnnotatedEntity (j,(nm,entries))
= tda [ theclass "indexannot" ] <<
- toHtml (show j) <+> parens (ppAnnot nm) <->
+ toHtml (show j) <+> parens (ppAnnot (nameOccName nm)) <->
indexLinks nm entries
- where nm = unQual qnm
- ppAnnot (HsTyClsName n)
- = toHtml "Type/Class"
- ppAnnot (HsVarName n)
- | isUpper c || c == ':' = toHtml "Data Constructor"
- | otherwise = toHtml "Function"
- where c = head (hsIdentifierStr n)
+ 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 (Module mdl) (Just nm) << toHtml mdl
+ linkId mod (Just nm) << toHtml (moduleString mod)
else
- toHtml mdl
- | (Module mdl, visible) <- entries ])
+ toHtml (moduleString mod)
+ | (mod, visible) <- entries ])
initialChars = [ 'A'..'Z' ] ++ ":!#$%&*+./<=>?@\\^|-~"
-- ---------------------------------------------------------------------------
-- Generate the HTML page for a module
-
+{-
ppHtmlModule
:: FilePath -> String
-> SourceURLs -> WikiURLs
@@ -615,9 +617,6 @@ numberSectionHeadings exports = go 1 exports
go n (other:es)
= other : go n es
--- The URL for source and wiki links, and the current module
-type LinksInfo = (SourceURLs, WikiURLs, Interface)
-
processExport :: Bool -> LinksInfo -> ExportItem -> HtmlTable
processExport _ _ (ExportGroup lev id0 doc)
= ppDocGroup lev (namedAnchor id0 << docToHtml doc)
@@ -630,7 +629,7 @@ processExport summmary _ (ExportNoDecl _ y subs)
processExport _ _ (ExportDoc doc)
= docBox (docToHtml doc)
processExport _ _ (ExportModule (Module mdl))
- = declBox (toHtml "module" <+> ppHsModule mdl)
+ = declBox (toHtml "module" <+> ppModule mdl)
forSummary :: ExportItem -> Bool
forSummary (ExportGroup _ _ _) = False
@@ -682,7 +681,7 @@ doDecl summary links x d instances = do_decl d
= if summary then Html.emptyTable
else ppDocGroup lev (docToHtml str)
- do_decl _ = error ("do_decl: " ++ show d)
+ do_decl _ = nrror ("do_decl: " ++ show d)
ppTypeSig :: Bool -> HsName -> HsType -> Html
@@ -1041,25 +1040,35 @@ ppHsAType (HsTyCon nm)
ppHsAType (HsTyApp (HsTyCon (Qual _ (HsTyClsName (HsSpecial "[]")))) b )
= brackets $ ppHsType b
ppHsAType t = parens $ ppHsType t
-
+-}
-- ----------------------------------------------------------------------------
-- Names
+ppRdrName :: GHC.RdrName -> Html
+ppRdrName = toHtml . occNameString . rdrNameOcc
+
+ppDocName :: DocName -> Html
+ppDocName (Link name) = linkId (nameModule name) (Just name) << ppName name
+ppDocName (NoLink name) = toHtml (getOccString name)
+
linkTarget :: HsName -> Html
linkTarget nm = namedAnchor (hsAnchorNameStr nm) << toHtml ""
-
+{-
ppHsQName :: HsQName -> Html
ppHsQName (UnQual str) = ppHsName str
ppHsQName n@(Qual mdl str)
| n == unit_con_name = ppHsName str
| isSpecial str = ppHsName str
| otherwise = linkId mdl (Just str) << ppHsName str
-
+-}
isSpecial :: HsName -> Bool
isSpecial (HsTyClsName (HsSpecial _)) = True
isSpecial (HsVarName (HsSpecial _)) = True
isSpecial _ = False
+ppName :: GHC.Name -> Html
+ppName name = toHtml (getOccString name)
+
ppHsName :: HsName -> Html
ppHsName nm = toHtml (hsNameStr nm)
@@ -1078,28 +1087,30 @@ ppHsBindIdent (HsIdent str) = toHtml str
ppHsBindIdent (HsSymbol str) = parens (toHtml str)
ppHsBindIdent (HsSpecial str) = toHtml str
-linkId :: Module -> Maybe HsName -> Html -> Html
-linkId (Module mdl) mbName = anchor ! [href hr]
- where hr = case mbName of
- Nothing -> moduleHtmlFile mdl
- Just name -> nameHtmlRef mdl name
+linkId :: GHC.Module -> Maybe GHC.Name -> Html -> Html
+linkId mod mbName = anchor ! [href hr]
+ where
+ hr = case mbName of
+ Nothing -> moduleHtmlFile modName
+ Just name -> nameHtmlRef modName name
+ modName = moduleString mod
-ppHsModule :: String -> Html
-ppHsModule mdl = anchor ! [href ((moduleHtmlFile modname) ++ ref)] << toHtml mdl
+ppModule :: String -> Html
+ppModule mdl = anchor ! [href ((moduleHtmlFile modname) ++ ref)] << toHtml mdl
where
(modname,ref) = break (== '#') mdl
-- -----------------------------------------------------------------------------
-- * Doc Markup
-htmlMarkup :: DocMarkup [HsQName] Html
-htmlMarkup = Markup {
+parHtmlMarkup :: (a -> Html) -> DocMarkup a Html
+parHtmlMarkup ppId = Markup {
markupParagraph = paragraph,
markupEmpty = toHtml "",
markupString = toHtml,
markupAppend = (+++),
- markupIdentifier = tt . ppHsQName . head,
- markupModule = ppHsModule,
+ markupIdentifier = tt . ppId . head,
+ markupModule = ppModule,
markupEmphasis = emphasize . toHtml,
markupMonospaced = tt . toHtml,
markupUnorderedList = ulist . concatHtml . map (li <<),
@@ -1112,25 +1123,37 @@ htmlMarkup = Markup {
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 :: Doc -> Html
+{-docToHtml :: Doc -> Html
docToHtml doc = markup htmlMarkup (unParagraph (markup htmlCleanup doc))
+-}
+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 (DocParagraph d) = d
+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 [HsQName] Doc
+htmlCleanup :: DocMarkup a (GHC.HsDoc a)
htmlCleanup = idMarkup {
- markupUnorderedList = DocUnorderedList . map unParagraph,
- markupOrderedList = DocOrderedList . map unParagraph
+ markupUnorderedList = GHC.DocUnorderedList . map unParagraph,
+ markupOrderedList = GHC.DocOrderedList . map unParagraph
}
-- -----------------------------------------------------------------------------
@@ -1196,9 +1219,9 @@ 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 -> SrcLoc -> HsName -> Html -> HtmlTable
+topDeclBox :: LinksInfo -> SrcLoc -> GHC.Name -> Html -> HtmlTable
topDeclBox ((_,_,Nothing), (_,_,Nothing), _) _ _ html = declBox html
-topDeclBox ((_,_,maybe_source_url), (_,_,maybe_wiki_url), iface)
+topDeclBox ((_,_,maybe_source_url), (_,_,maybe_wiki_url), hmod)
(SrcLoc _ _ fname) name html =
tda [theclass "topdecl"] <<
( table ! [theclass "declbar"] <<
@@ -1221,7 +1244,7 @@ topDeclBox ((_,_,maybe_source_url), (_,_,maybe_wiki_url), iface)
(Just name) url
in anchor ! [href url'] << toHtml "Comments"
- mod = iface_module iface
+ mod = hmod_mod hmod
-- 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
@@ -1242,7 +1265,7 @@ ndocBox html = tda [theclass "ndoc"] << html
rdocBox :: Html -> HtmlTable
rdocBox html = tda [theclass "rdoc"] << html
-maybeRDocBox :: Maybe Doc -> HtmlTable
+maybeRDocBox :: Maybe (GHC.HsDoc DocName) -> HtmlTable
maybeRDocBox Nothing = rdocBox (noHtml)
maybeRDocBox (Just doc) = rdocBox (docToHtml doc)
diff --git a/src/HaddockModuleTree.hs b/src/HaddockModuleTree.hs
index 51c0fa17..ffc8b98e 100644
--- a/src/HaddockModuleTree.hs
+++ b/src/HaddockModuleTree.hs
@@ -1,16 +1,18 @@
-module HaddockModuleTree(ModuleTree(..), mkModuleTree) where
+module HaddockModuleTree ( ModuleTree(..), mkModuleTree ) where
-import HsSyn2
+import HaddockTypes ( DocName )
+import GHC ( HsDoc, Name )
+import Module ( Module, moduleString )
-data ModuleTree = Node String Bool (Maybe String) (Maybe Doc) [ModuleTree]
+data ModuleTree = Node String Bool (Maybe String) (Maybe (HsDoc Name)) [ModuleTree]
-mkModuleTree :: [(Module,Maybe String,Maybe Doc)] -> [ModuleTree]
+mkModuleTree :: [(Module, Maybe String, Maybe (HsDoc Name))] -> [ModuleTree]
mkModuleTree mods =
- foldr fn [] [ (splitModule mod, pkg,short) | (mod,pkg,short) <- mods ]
+ foldr fn [] [ (splitModule mod, pkg, short) | (mod,pkg,short) <- mods ]
where
fn (mod,pkg,short) trees = addToTrees mod pkg short trees
-addToTrees :: [String] -> Maybe String -> Maybe Doc -> [ModuleTree] -> [ModuleTree]
+addToTrees :: [String] -> Maybe String -> Maybe (HsDoc Name) -> [ModuleTree] -> [ModuleTree]
addToTrees [] pkg short ts = ts
addToTrees ss pkg short [] = mkSubTree ss pkg short
addToTrees (s1:ss) pkg short (t@(Node s2 leaf node_pkg node_short subs) : ts)
@@ -21,13 +23,13 @@ addToTrees (s1:ss) pkg short (t@(Node s2 leaf node_pkg node_short subs) : ts)
this_pkg = if null ss then pkg else node_pkg
this_short = if null ss then short else node_short
-mkSubTree :: [String] -> Maybe String -> Maybe Doc -> [ModuleTree]
+mkSubTree :: [String] -> Maybe String -> Maybe (HsDoc Name) -> [ModuleTree]
mkSubTree [] pkg short = []
mkSubTree [s] pkg short = [Node s True pkg short []]
mkSubTree (s:ss) pkg short = [Node s (null ss) Nothing Nothing (mkSubTree ss pkg short)]
splitModule :: Module -> [String]
-splitModule (Module mdl) = split mdl
- where split mdl0 = case break (== '.') mdl0 of
+splitModule mod = split (moduleString mod)
+ where split mod0 = case break (== '.') mod0 of
(s1, '.':s2) -> s1 : split s2
(s1, _) -> [s1]
diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs
index 45db4433..1953a23c 100644
--- a/src/HaddockRename.hs
+++ b/src/HaddockRename.hs
@@ -5,29 +5,21 @@
--
module HaddockRename (
- RnM, runRn, runRnFM, -- the monad (instance of Monad)
-
- --renameExportList,
- --renameDecl,
- --renameExportItems, renameInstHead,
- --renameDoc, renameMaybeDoc,
+ runRnFM, -- the monad (instance of Monad)
renameMaybeDoc, renameExportItems,
- ) where
+) where
import HaddockTypes
-import HaddockUtil ( unQual )
---import HsSyn2
-import Map ( Map )
-import qualified Map hiding ( Map )
-
-import Prelude hiding ( mapM )
-import Control.Monad hiding ( mapM )
-import Data.Traversable
import GHC
import BasicTypes
import SrcLoc
-import Bag
+import Bag ( emptyBag )
+
+import Data.Map ( Map )
+import qualified Data.Map as Map hiding ( Map )
+import Prelude hiding ( mapM )
+import Data.Traversable ( mapM )
-- -----------------------------------------------------------------------------
-- Monad for renaming
@@ -214,18 +206,15 @@ renameInstHead (preds, className, types) = do
renameLDecl (L loc d) = return . L loc =<< renameDecl d
renameDecl d = case d of
- TyClD d doc -> do
+ TyClD d -> do
d' <- renameTyClD d
- doc' <- renameMaybeDoc doc
- return (TyClD d' doc')
- SigD s doc -> do
+ return (TyClD d')
+ SigD s -> do
s' <- renameSig s
- doc' <- renameMaybeDoc doc
- return (SigD s' doc')
- ForD d doc -> do
+ return (SigD s')
+ ForD d -> do
d' <- renameForD d
- doc' <- renameMaybeDoc doc
- return (ForD d' doc')
+ return (ForD d')
_ -> error "renameDecl"
renameTyClD d = case d of
diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs
index cd9d4fff..0c5fd428 100644
--- a/src/HaddockTypes.hs
+++ b/src/HaddockTypes.hs
@@ -11,9 +11,10 @@ module HaddockTypes (
-- * Misc types
DocOption(..), InstHead, InstHead2,
DocName(..),
+ DocMarkup(..)
) where
-import HsSyn2
+import HsSyn2 hiding ( DocMarkup )
import qualified GHC as GHC
@@ -147,6 +148,12 @@ data HaddockModule = HM {
-- | A value to identify the module
hmod_mod :: GHC.Module,
+-- | The original filename for this module
+ hmod_orig_filename :: FilePath,
+
+-- | Textual information about the module
+ hmod_info :: GHC.HaddockModInfo GHC.Name,
+
-- | The documentation header for this module
hmod_doc :: Maybe (GHC.HsDoc GHC.Name),
@@ -175,5 +182,24 @@ data HaddockModule = HM {
hmod_sub_map :: Map GHC.Name [GHC.Name],
-- | The instances exported by this module
- hmod_instances :: [GHC.Instance]
+ hmod_instances :: [GHC.Instance],
+
+ hmod_package :: Maybe String
+}
+
+data DocMarkup id a = Markup {
+ markupEmpty :: a,
+ markupString :: String -> a,
+ markupParagraph :: a -> a,
+ markupAppend :: a -> a -> a,
+ markupIdentifier :: [id] -> a,
+ markupModule :: String -> a,
+ markupEmphasis :: a -> a,
+ markupMonospaced :: a -> a,
+ markupUnorderedList :: [a] -> a,
+ markupOrderedList :: [a] -> a,
+ markupDefList :: [(a,a)] -> a,
+ markupCodeBlock :: a -> a,
+ markupURL :: String -> a,
+ markupAName :: String -> a
}
diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs
index 7ce16cd3..99c814f4 100644
--- a/src/HaddockUtil.hs
+++ b/src/HaddockUtil.hs
@@ -23,16 +23,22 @@ module HaddockUtil (
-- * HTML cross reference mapping
html_xrefs_ref,
+
+ -- * HsDoc markup
+ markup,
+ idMarkup,
) where
import Binary2
import HaddockTypes
-import HsSyn2
+import HsSyn2 hiding ( DocMarkup(..), markup, idMarkup )
import Map ( Map )
import qualified Map hiding ( Map )
import qualified GHC as GHC
import SrcLoc
+import Name
+import OccName
import Control.Monad ( liftM, MonadPlus(..) )
import Data.Char ( isAlpha, isSpace, toUpper, ord )
@@ -116,8 +122,8 @@ freeTyCons ty = go ty []
go (HsTyDoc t _) r = go t r
-- | extract a module's short description.
-toDescription :: Interface -> Maybe Doc
-toDescription = description. iface_info
+toDescription :: HaddockModule -> Maybe (GHC.HsDoc GHC.Name)
+toDescription = GHC.hmi_description . hmod_info
-- -----------------------------------------------------------------------------
-- Adding documentation to record fields (used in parsing).
@@ -145,14 +151,14 @@ addConDocs (x:xs) doc = addConDoc x doc : xs
restrictTo :: [GHC.Name] -> (GHC.LHsDecl GHC.Name) -> (GHC.LHsDecl GHC.Name)
restrictTo names (L loc decl) = L loc $ case decl of
- GHC.TyClD d doc | GHC.isDataDecl d && GHC.tcdND d == GHC.DataType ->
- GHC.TyClD (d { GHC.tcdCons = restrictCons names (GHC.tcdCons d) }) doc
- GHC.TyClD d doc | GHC.isDataDecl d && GHC.tcdND d == GHC.NewType ->
+ GHC.TyClD d | GHC.isDataDecl d && GHC.tcdND d == GHC.DataType ->
+ GHC.TyClD (d { GHC.tcdCons = restrictCons names (GHC.tcdCons d) })
+ GHC.TyClD d | GHC.isDataDecl d && GHC.tcdND d == GHC.NewType ->
case restrictCons names (GHC.tcdCons d) of
- [] -> GHC.TyClD (d { GHC.tcdND = GHC.DataType, GHC.tcdCons = [] }) doc
- [con] -> GHC.TyClD (d { GHC.tcdCons = [con] }) doc
- GHC.TyClD d doc | GHC.isClassDecl d ->
- GHC.TyClD (d { GHC.tcdSigs = restrictDecls names (GHC.tcdSigs d) }) doc
+ [] -> GHC.TyClD (d { GHC.tcdND = GHC.DataType, GHC.tcdCons = [] })
+ [con] -> GHC.TyClD (d { GHC.tcdCons = [con] })
+ GHC.TyClD d | GHC.isClassDecl d ->
+ GHC.TyClD (d { GHC.tcdSigs = restrictDecls names (GHC.tcdSigs d) })
_ -> decl
restrictCons :: [GHC.Name] -> [GHC.LConDecl GHC.Name] -> [GHC.LConDecl GHC.Name]
@@ -279,8 +285,13 @@ moduleHtmlFile mdl =
where
mdl' = map (\c -> if c == '.' then '-' else c) mdl
-nameHtmlRef :: String -> HsName -> String
-nameHtmlRef mdl str = moduleHtmlFile mdl ++ '#':escapeStr (hsAnchorNameStr str)
+nameHtmlRef :: String -> GHC.Name -> String
+nameHtmlRef mdl str = moduleHtmlFile mdl ++ '#':escapeStr (anchorNameStr str)
+
+anchorNameStr :: GHC.Name -> String
+anchorNameStr name | isValOcc occName = "v:" ++ getOccString name
+ | otherwise = "t:" ++ getOccString name
+ where occName = nameOccName name
contentsHtmlFile, indexHtmlFile :: String
contentsHtmlFile = "index.html"
@@ -431,4 +442,46 @@ instance Binary id => Binary (GenDoc id) where
_ -> error ("Mysterious byte in document in interface"
++ show b)
-
+markup :: DocMarkup id a -> GHC.HsDoc id -> a
+markup m GHC.DocEmpty = markupEmpty m
+markup m (GHC.DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2)
+markup m (GHC.DocString s) = markupString m s
+markup m (GHC.DocParagraph d) = markupParagraph m (markup m d)
+markup m (GHC.DocIdentifier ids) = markupIdentifier m ids
+markup m (GHC.DocModule mod0) = markupModule m mod0
+markup m (GHC.DocEmphasis d) = markupEmphasis m (markup m d)
+markup m (GHC.DocMonospaced d) = markupMonospaced m (markup m d)
+markup m (GHC.DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds)
+markup m (GHC.DocOrderedList ds) = markupOrderedList m (map (markup m) ds)
+markup m (GHC.DocDefList ds) = markupDefList m (map (markupPair m) ds)
+markup m (GHC.DocCodeBlock d) = markupCodeBlock m (markup m d)
+markup m (GHC.DocURL url) = markupURL m url
+markup m (GHC.DocAName ref) = markupAName m ref
+
+markupPair :: DocMarkup id a -> (GHC.HsDoc id, GHC.HsDoc id) -> (a, a)
+markupPair m (a,b) = (markup m a, markup m b)
+
+-- | The identity markup
+idMarkup :: DocMarkup a (GHC.HsDoc a)
+idMarkup = Markup {
+ markupEmpty = GHC.DocEmpty,
+ markupString = GHC.DocString,
+ markupParagraph = GHC.DocParagraph,
+ markupAppend = GHC.DocAppend,
+ markupIdentifier = GHC.DocIdentifier,
+ markupModule = GHC.DocModule,
+ markupEmphasis = GHC.DocEmphasis,
+ markupMonospaced = GHC.DocMonospaced,
+ markupUnorderedList = GHC.DocUnorderedList,
+ markupOrderedList = GHC.DocOrderedList,
+ markupDefList = GHC.DocDefList,
+ markupCodeBlock = GHC.DocCodeBlock,
+ markupURL = GHC.DocURL,
+ markupAName = GHC.DocAName
+ }
+
+-- | Since marking up is just a matter of mapping 'Doc' into some
+-- other type, we can \'rename\' documentation by marking up 'Doc' into
+-- the same thing, modifying only the identifiers embedded in it.
+mapIdent :: ([a] -> GHC.HsDoc b) -> DocMarkup a (GHC.HsDoc b)
+mapIdent f = idMarkup { markupIdentifier = f }
diff --git a/src/Main.hs b/src/Main.hs
index ac33796d..009f8f03 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -14,11 +14,8 @@ import HaddockRename
import HaddockTypes
import HaddockUtil
import HaddockVersion
-import Set
import Paths_haddock ( getDataDir )
import Binary2
-import Digraph2
-import HsParseMonad
import Control.Exception ( bracket )
import Control.Monad ( when )
@@ -244,27 +241,10 @@ run flags files = do
prologue <- getPrologue flags
--- updateHTMLXRefs pkg_paths read_ifacess
-
when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags)
&& Flag_Html `elem` flags) $
die ("-h cannot be used with --gen-index or --gen-contents")
-{- when (Flag_GenContents `elem` flags) $ do
- ppHtmlContents odir title package maybe_html_help_format
- maybe_index_url maybe_source_urls maybe_wiki_urls
- visible_read_ifaces prologue
- copyHtmlBits odir libdir css_file
--}
-{- when (Flag_GenIndex `elem` flags) $ do
- ppHtmlIndex odir title package maybe_html_help_format
- maybe_contents_url maybe_source_urls maybe_wiki_urls
- visible_read_ifaces
- copyHtmlBits odir libdir css_file
-
- when (Flag_GenContents `elem` flags && Flag_GenIndex `elem` flags) $ do
- ppHtmlHelpFiles title package visible_read_ifaces odir maybe_html_help_format pkg_paths
--}
GHC.init (Just "/home/davve/dev/local/lib/ghc-6.5")
let ghcMode = GHC.JustTypecheck
session <- GHC.newSession ghcMode
@@ -279,57 +259,28 @@ run flags files = do
sorted_checked_modules <- GHC.defaultErrorHandler ghcFlags''' $ do
GHC.setSessionDynFlags session ghcFlags'''
targets <- mapM (\s -> GHC.guessTarget s Nothing) files
- GHC.setTargets session targets
-
+ GHC.setTargets session targets
maybe_module_graph <- GHC.depanal session [] True
module_graph <- case maybe_module_graph of
Just module_graph -> return module_graph
Nothing -> die "Failed to load modules\n"
let sorted_modules = concatMap Digraph.flattenSCC (GHC.topSortModuleGraph False module_graph Nothing)
- let modules = [ GHC.ms_mod modsum | modsum <- sorted_modules ]
+ let (modules, filenames) = unzip [ (GHC.ms_mod modsum, fromJust $ GHC.ml_hs_file (GHC.ms_location modsum)) | modsum <- sorted_modules,
+ fromJust (GHC.ml_hs_file (GHC.ms_location modsum)) `elem` files ]
+
mb_checked_modules <- mapM (GHC.checkModule session) modules
let checked_modules = catMaybes mb_checked_modules
if length checked_modules /= length mb_checked_modules
then die "Failed to load all modules\n"
- else return (zip modules checked_modules)
+ else return (zip3 modules checked_modules filenames)
sorted_checked_modules' <- remove_maybes sorted_checked_modules
-{- let Just (group,_,_,_) = GHC.renamedSource (snd (head sorted_checked_modules))
- let Just mi = GHC.checkedModuleInfo (snd (head sorted_checked_modules))
- let exported_names = GHC.modInfoExports mi
-
- let exported_decl_map = mk_exported_decl_map exported_names group
- let exported_decls = Map.elems exported_decl_map
-
- putStrLn "Printing all exported names:"
- putStrLn "----------------------------"
+ let (modMap, messages) = runWriter (pass1 sorted_checked_modules' flags package)
- printSDoc (ppr exported_names) defaultUserStyle
-
- if length exported_decls /= length exported_names
- then putStrLn "-----------\nWARNING: Not all names found\n-----------\n"
- else return ()
-
- putStrLn "Printing all corresponding decls:"
- putStrLn "---------------------------------"
- printSDoc (ppr exported_decls) defaultUserStyle
-
- let not_found = exported_names \\ (Map.keys exported_decl_map)
-
- putStrLn "Printing all names not found:"
- putStrLn "---------------------------------"
- printSDoc (ppr not_found) defaultUserStyle
-
- let sub_names = mk_sub_map_from_group group
- putStrLn "Printing the submap:"
- putStrLn "---------------------------------"
- printSDoc (ppr (Map.toList sub_names)) defaultUserStyle -}
-
-
- let (modMap, messages) = runWriter (pass1 sorted_checked_modules' flags)
-
- haddockModules = catMaybes [ Map.lookup mod modMap | (mod, _) <- sorted_checked_modules' ]
+ haddockModules = catMaybes [ Map.lookup mod modMap |
+ (mod, _, file) <- sorted_checked_modules',
+ file `elem` files ]
let env = buildGlobalDocEnv haddockModules
@@ -348,6 +299,26 @@ run flags files = do
putStrLn "pass 2 export items:"
printSDoc (ppr renamedModules) defaultUserStyle
mapM_ putStrLn messages'
+
+ let visibleModules = [ m | m <- haddockModules', OptHide `notElem` (hmod_options m) ]
+
+ updateHTMLXRefs [] []
+
+ when (Flag_GenIndex `elem` flags) $ do
+ ppHtmlIndex odir title package maybe_html_help_format
+ maybe_contents_url maybe_source_urls maybe_wiki_urls
+ visibleModules
+ copyHtmlBits odir libdir css_file
+
+ when (Flag_GenContents `elem` flags && Flag_GenIndex `elem` flags) $ do
+ ppHtmlHelpFiles title package visibleModules odir maybe_html_help_format []
+
+ when (Flag_GenContents `elem` flags) $ do
+ ppHtmlContents odir title package maybe_html_help_format
+ maybe_index_url maybe_source_urls maybe_wiki_urls
+ visibleModules prologue
+ copyHtmlBits odir libdir css_file
+
--let Just (group, imports, exports) = GHC.renamedSource (head sorted_checked_modules)
--printSDoc (ppr group) defaultUserStyle
@@ -443,7 +414,7 @@ run flags files = do
remove_maybes modules | length modules' == length modules = return modules'
| otherwise = die "Missing checked module phase information\n"
- where modules' = [ (mod, (a,b,c,d)) | (mod, GHC.CheckedModule a (Just b) (Just c) (Just d)) <- modules ]
+ where modules' = [ (mod, (a,b,c,d), f) | (mod, GHC.CheckedModule a (Just b) (Just c) (Just d), f) <- modules ]
print_ x = printSDoc (ppr x) defaultUserStyle
@@ -470,25 +441,19 @@ type FullyCheckedModule = (GHC.ParsedSource,
GHC.TypecheckedSource,
GHC.ModuleInfo)
-getDocumentedExports :: [ExportItem2 GHC.Name] -> [GHC.Name]
-getDocumentedExports exports = concatMap getName exports
+pass1 :: [(GHC.Module, FullyCheckedModule, FilePath)] -> [Flag] -> Maybe String-> ErrMsgM ModuleMap2
+pass1 modules flags package = worker modules (Map.empty) flags
where
- getName (ExportDecl2 name _ _ _) = [name]
- getName _ = []
-
-pass1 :: [(GHC.Module, FullyCheckedModule)] -> [Flag] -> ErrMsgM ModuleMap2
-pass1 modules flags = worker modules (Map.empty) flags
- where
- worker :: [(GHC.Module, FullyCheckedModule)] -> ModuleMap2 -> [Flag] -> ErrMsgM ModuleMap2
+ worker :: [(GHC.Module, FullyCheckedModule, FilePath)] -> ModuleMap2 -> [Flag] -> ErrMsgM ModuleMap2
worker [] moduleMap _ = return moduleMap
- worker ((mod, checked_mod):rest_modules) moduleMap flags = do
+ worker ((mod, checked_mod, filename):rest_modules) moduleMap flags = do
let (parsed_source, renamed_source, _, moduleInfo) = checked_mod
- (mb_doc_opts, haddock_mod_info, _) = get_module_stuff parsed_source
+ (mb_doc_opts, _, _) = get_module_stuff parsed_source
opts <- mk_doc_opts mb_doc_opts
- let (group, _, mb_exports, mbModDoc) = renamed_source
+ let (group, _, mb_exports, mbModDoc, haddockModInfo) = renamed_source
entities = nubBy sameName (GHC.hs_docs group)
exports = fmap (map unLoc) mb_exports
@@ -508,29 +473,39 @@ pass1 modules flags = worker modules (Map.empty) flags
localDeclMap = mkDeclMap theseEntityNames group
docMap = mkDocMap group
- ignore_all_exports = Flag_IgnoreAllExports `elem` flags
+ ignoreAllExports = Flag_IgnoreAllExports `elem` flags
exportItems <- mkExportItems moduleMap mod exportedNames
exportedDeclMap localDeclMap subMap entities opts
- exports ignore_all_exports docMap
+ exports ignoreAllExports docMap
- let instances = GHC.modInfoInstances moduleInfo
+ -- 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
+
+ instances = GHC.modInfoInstances moduleInfo
- let haddock_module = HM {
+ haddock_module = HM {
hmod_mod = mod,
+ hmod_orig_filename = filename,
+ hmod_info = haddockModInfo,
hmod_doc = mbModDoc,
hmod_options = opts,
hmod_locals = localNames,
hmod_doc_map = docMap,
hmod_sub_map = subMap,
- hmod_export_items = exportItems,
+ hmod_export_items = prunedExportItems,
hmod_exports = exportedNames,
hmod_visible_exports = theseVisibleNames,
hmod_exported_decl_map = exportedDeclMap,
- hmod_instances = instances
+ hmod_instances = instances,
+ hmod_package = package
}
- let moduleMap' = Map.insert mod haddock_module moduleMap
+ moduleMap' = Map.insert mod haddock_module moduleMap
+
worker rest_modules moduleMap' flags
where
@@ -612,21 +587,21 @@ getDeclFromGroup group name = case catMaybes [getDeclFromVals (GHC.hs_valds gr
_ -> Nothing
where
getDeclFromVals (GHC.ValBindsOut _ lsigs) = case matching of
- [lsig] -> Just (L (getLoc lsig) (GHC.SigD (unLoc lsig) Nothing))
+ [lsig] -> Just (L (getLoc lsig) (GHC.SigD (unLoc lsig)))
_ -> Nothing
where
matching = [ lsig | lsig <- lsigs, let Just n = GHC.sigName lsig, n == name ]
getDeclFromVals _ = error "getDeclFromVals: illegal input"
getDeclFromTyCls ltycls = case matching of
- [ltycl] -> Just (L (getLoc ltycl) (GHC.TyClD (unLoc ltycl) Nothing))
+ [ltycl] -> Just (L (getLoc ltycl) (GHC.TyClD (unLoc ltycl)))
_ -> Nothing
where
matching = [ ltycl | ltycl <- ltycls,
name `elem` map unLoc (GHC.tyClDeclNames (unLoc ltycl))]
getDeclFromFors lfors = case matching of
- [for] -> Just (L (getLoc for) (GHC.ForD (unLoc for) Nothing))
+ [for] -> Just (L (getLoc for) (GHC.ForD (unLoc for)))
_ -> Nothing
where
matching = [ for | for <- lfors, forName (unLoc for) == name ]
@@ -659,158 +634,6 @@ getPrologue flags
Right doc -> return (Just doc)
_otherwise -> dieMsg "multiple -p/--prologue options"
------------------------------------------------------------------------------
--- Figuring out the definitions that are exported from a module
-
--- We're going to make interfaces in two passes:
---
--- 1. Rename the code. This basically involves resolving all
--- the names to "original names".
---
--- 2. Convert all the entity references to "doc names". These are
--- the names we want to link to in the documentation.
-{-
-mkInterfacePhase1
- :: [Flag]
- -> Bool -- verbose
- -> ModuleMap -> FilePath -> Maybe String -> HsModule
- -> ErrMsgM Interface -- the "interface" of the module
-
-mkInterfacePhase1 flags verbose mod_map filename package
- (HsModule (SrcLoc _ _ orig_filename) mdl exps imps decls
- maybe_opts maybe_info maybe_doc) = do
-
- let
- no_implicit_prelude = Flag_NoImplicitPrelude `elem` flags
- ignore_all_exports = Flag_IgnoreAllExports `elem` flags
-
- -- Process the options, if available
- opts0 <- case maybe_opts of
- Just opt_str -> processOptions opt_str
- Nothing -> return []
- let
- -- check for a --hide option
- Module mod_str = mdl
- opts
- | Flag_HideModule mod_str `elem` flags = OptHide : opts0
- | otherwise = opts0
-
- let
- -- expand type signatures with multiple variables into multiple
- -- type signatures
- expanded_decls = concat (map expandDecl decls)
-
- sub_map = mkSubNames expanded_decls
-
- -- first, attach documentation to declarations
- annotated_decls = collectDoc expanded_decls
-
- -- now find the defined names
- locally_defined_names = collectNames annotated_decls
-
- qual_local_names = map (Qual mdl) locally_defined_names
- unqual_local_names = map UnQual locally_defined_names
-
- local_orig_env = Map.fromList (zip unqual_local_names qual_local_names ++
- zip qual_local_names qual_local_names)
- -- both qualified and unqualifed names are in scope for local things
-
- implicit_imps
- | no_implicit_prelude || any is_prel_import imps = imps
- | otherwise = HsImportDecl loc prelude_mod False Nothing Nothing : imps
- where
- loc = SrcLoc 0 0 ""
- is_prel_import (HsImportDecl _ mdl0 _ _ _ ) = mdl0 == prelude_mod
- -- in
-
- -- build the orig_env, which maps names to *original* names (so we can
- -- find the original declarations & docs for things).
- imported_orig_env <- buildOrigEnv mdl verbose mod_map implicit_imps
-
- let
- orig_env = local_orig_env `Map.union` imported_orig_env
-
- -- convert names in source code to original, fully qualified, names
- (orig_exports, missing_names1)
- = runRnFM orig_env (mapMaybeM renameExportList exps)
-
- (orig_decls, missing_names2)
- = runRnFM orig_env (mapM renameDecl annotated_decls)
-
- (orig_module_doc, missing_names3)
- = runRnFM orig_env (renameMaybeDoc maybe_doc)
-
- decl_map :: Map HsName HsDecl
- decl_map = Map.fromList [ (n,d) | d <- orig_decls, n <- declBinders d ]
-
- instances = [ d | d@HsInstDecl{} <- orig_decls ] ++
- [ d | decl <- orig_decls, d <- derivedInstances mdl decl]
-
- -- trace (show (Map.toAscList orig_env)) $ do
-
- -- gather up a list of entities that are exported (original names)
- (exported_names, exported_visible_names)
- <- exportedNames mdl mod_map
- locally_defined_names orig_env sub_map
- orig_exports opts
-
- let
- -- maps exported HsNames to orig HsQNames
- name_env = Map.fromList [ (nameOfQName n, n) | n <- exported_names ]
-
- -- find the names exported by this module that other modules should *not*
- -- link to.
- reexports = [ nm | n@(Qual _ nm) <- exported_names,
- n `notElem` exported_visible_names ]
-
- -- in
-
- -- make the "export items", which will be converted into docs later
- orig_export_items <- mkExportItems mod_map mdl exported_names decl_map sub_map
- orig_decls opts orig_exports
- ignore_all_exports
- let
- -- prune the export list to just those declarations that have
- -- documentation, if the 'prune' option is on.
- pruned_export_list
- | OptPrune `elem` opts = pruneExportItems orig_export_items
- | otherwise = orig_export_items
- -- in
-
- -- report any names we couldn't find/resolve
- let
- missing_names = missing_names1 ++ missing_names2 ++ missing_names3
- --ignore missing_names3 & missing_names5 for now
- filtered_missing_names = filter (`notElem` builtinNames) missing_names
-
- name_strings = nub (map show filtered_missing_names)
- -- in
-
- when (OptHide `notElem` opts &&
- not (null name_strings)) $
- tell ["Warning: " ++ show mdl ++
- ": the following names could not be resolved:\n"++
- " " ++ concat (map (' ':) name_strings)
- ]
-
- return (Interface {
- iface_filename = filename,
- iface_orig_filename= orig_filename,
- iface_module = mdl,
- iface_package = package,
- iface_env = name_env,
- iface_reexported = reexports,
- iface_sub = sub_map,
- iface_orig_exports = pruned_export_list,
- iface_decls = decl_map,
- iface_info = maybe_info,
- iface_doc = orig_module_doc,
- iface_options = opts,
- iface_exports = error "iface_exports",
- iface_insts = instances
- }
- )
--}
-- -----------------------------------------------------------------------------
-- Phase 2
@@ -818,7 +641,7 @@ renameModule :: Map GHC.Name GHC.Name -> HaddockModule -> ErrMsgM ([ExportItem2
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 renameing
+ -- 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
@@ -849,86 +672,6 @@ renameModule renamingEnv mod =
return (renamedExportItems, finalModuleDoc)
-- -----------------------------------------------------------------------------
-{-
--- Try to generate instance declarations for derived instances.
--- We can't do this properly without instance inference, but if a type
--- variable occurs as a constructor argument, then we can just
--- propagate the derived class to the variable. But we know nothing of
--- the constraints on any type variables that occur elsewhere.
--- Note that a type variable may be in both categories: then we know a
--- constraint, but there may be more, or a stronger constraint.
-derivedInstances :: Module -> HsDecl -> [HsDecl]
-derivedInstances mdl decl = case decl of
- HsDataDecl srcloc ctxt n tvs cons drv@(_:_) _ ->
- derived srcloc ctxt n tvs cons drv
- HsNewTypeDecl srcloc ctxt n tvs con drv@(_:_) _ ->
- derived srcloc ctxt n tvs [con] drv
- _ -> []
- where
- derived srcloc ctxt n tvs cons drv =
- [HsInstDecl srcloc
- (ctxt ++ [(cls,[t]) | t <- simple_args] ++ extra_constraint)
- (cls,[lhs]) [] |
- cls <- drv]
- where
- targs = map stripDocs (targsConstrs cons)
- -- an argument of a data constructor is simple if it has a variable head
- simple_args = nub $ filter varHead targs
- -- a type variable is complex if it occurs inside a data constructor
- -- argument, except where the argument is identical to the lhs.
- complex_tvars = map HsTyVar $ Set.elems $ Set.unions $ map tvarsType $
- filter (/= lhs) $ filter (not . varHead) targs
- varHead (HsTyVar _) = True
- varHead (HsTyApp t _) = varHead t
- varHead (HsTyDoc t _) = varHead t
- varHead _ = False
- extra_constraint
- | null complex_tvars = []
- | otherwise = [(unknownConstraint,complex_tvars)]
- lhs
- | n == tuple_tycon_name (length tvs - 1) =
- HsTyTuple True (map HsTyVar tvs)
- | otherwise = foldl HsTyApp (HsTyCon (Qual mdl n)) (map HsTyVar tvs)
-
- -- collect type arguments of constructors
- targsConstrs :: [HsConDecl] -> [HsType]
- targsConstrs = foldr targsConstr []
-
- targsConstr :: HsConDecl -> [HsType] -> [HsType]
- targsConstr (HsConDecl _ _ _ _ bts _) ts = foldr targsBangType ts bts
- targsConstr (HsRecDecl _ _ _ _ fs _) ts = foldr targsField ts fs
-
- targsField (HsFieldDecl _ bt _) = targsBangType bt
-
- targsBangType (HsBangedTy t) ts = t : ts
- targsBangType (HsUnBangedTy t) ts = t : ts
-
- -- remove documentation comments from a type
- stripDocs :: HsType -> HsType
- stripDocs (HsForAllType n ctxt t) = HsForAllType n ctxt (stripDocs t)
- stripDocs (HsTyFun t1 t2) = HsTyFun (stripDocs t1) (stripDocs t2)
- stripDocs (HsTyTuple boxed ts) = HsTyTuple boxed (map stripDocs ts)
- stripDocs (HsTyApp t1 t2) = HsTyApp (stripDocs t1) (stripDocs t2)
- stripDocs (HsTyDoc t _) = stripDocs t
- stripDocs (HsTyIP n t) = HsTyIP n (stripDocs t)
- stripDocs t = t
-
- -- collect the type variables occurring free in a type
- tvarsType (HsForAllType (Just tvs) _ t) = foldl (flip Set.delete) (tvarsType t) tvs
- tvarsType (HsForAllType Nothing _ t) = tvarsType t
- tvarsType (HsTyFun t1 t2) = tvarsType t1 `Set.union` tvarsType t2
- tvarsType (HsTyTuple _ ts) = Set.unions (map tvarsType ts)
- tvarsType (HsTyApp t1 t2) = tvarsType t1 `Set.union` tvarsType t2
- tvarsType (HsTyVar tv) = Set.singleton tv
- tvarsType (HsTyCon _) = Set.empty
- tvarsType (HsTyDoc t _) = tvarsType t
- tvarsType (HsTyIP _ t) = tvarsType t
-
-unknownConstraint :: HsQName
-unknownConstraint = UnQual (HsTyClsName (HsIdent "???"))
-
--}
--- -----------------------------------------------------------------------------
-- 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.
@@ -987,7 +730,7 @@ mkExportItems mod_map this_mod exported_names exportedDeclMap localDeclMap sub_m
mdl = nameModule t
subs = filter (`elem` exported_names) all_subs
all_subs | mdl == this_mod = Map.findWithDefault [] t sub_map
- | otherwise = all_subs_of_qname mod_map t
+ | otherwise = allSubsOfName mod_map t
fullContentsOf m
| m == this_mod = return (fullContentsOfThisModule this_mod entities localDeclMap docMap)
@@ -1030,39 +773,36 @@ extractDecl name mdl decl
| Just n <- GHC.getMainDeclBinder (unLoc decl), n == name = decl
| otherwise =
case unLoc decl of
- GHC.TyClD d _ | GHC.isClassDecl d ->
+ GHC.TyClD d | GHC.isClassDecl d ->
let matches = [ sig | sig <- GHC.tcdSigs d, GHC.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 (GHC.SigD sig Nothing)
+ in L pos (GHC.SigD sig)
_ -> error "internal: extractDecl"
- GHC.TyClD d _ | GHC.isDataDecl d ->
+ GHC.TyClD d | GHC.isDataDecl d ->
let (n, tyvar_names) = name_and_tyvars d
L pos sig = extractRecSel name mdl n tyvar_names (GHC.tcdCons d)
- in L pos (GHC.SigD sig Nothing)
+ in L pos (GHC.SigD sig)
_ -> error "internal: extractDecl"
where
name_and_tyvars d = (unLoc (GHC.tcdLName d), GHC.hsLTyVarLocNames (GHC.tcdTyVars d))
toTypeNoLoc :: Located GHC.Name -> GHC.LHsType GHC.Name
-toTypeNoLoc lname = mkNoLoc (GHC.HsTyVar (unLoc lname))
-
-mkNoLoc :: a -> Located a
-mkNoLoc a = L noSrcSpan a
+toTypeNoLoc lname = noLoc (GHC.HsTyVar (unLoc lname))
rmLoc :: Located a -> Located a
-rmLoc a = mkNoLoc (unLoc a)
+rmLoc a = noLoc (unLoc a)
-- originally expected unqualified 1:st name, now it doesn't
extractClassDecl :: GHC.Name -> GHC.Module -> [Located GHC.Name] -> GHC.LSig GHC.Name -> GHC.LSig GHC.Name
extractClassDecl c mdl tvs0 (L pos (GHC.TypeSig lname ltype)) = case ltype of
L _ (GHC.HsForAllTy exp tvs (L _ preds) ty) ->
- L pos (GHC.TypeSig lname (mkNoLoc (GHC.HsForAllTy exp tvs (lctxt preds) ty)))
- _ -> L pos (GHC.TypeSig lname (mkNoLoc (GHC.mkImplicitHsForAllTy (lctxt []) ltype)))
+ L pos (GHC.TypeSig lname (noLoc (GHC.HsForAllTy exp tvs (lctxt preds) ty)))
+ _ -> L pos (GHC.TypeSig lname (noLoc (GHC.mkImplicitHsForAllTy (lctxt []) ltype)))
where
- lctxt preds = mkNoLoc (ctxt preds)
- ctxt preds = [mkNoLoc (GHC.HsClassP c (map toTypeNoLoc tvs0))] ++ preds
+ lctxt preds = noLoc (ctxt preds)
+ ctxt preds = [noLoc (GHC.HsClassP c (map toTypeNoLoc tvs0))] ++ preds
extractClassDecl _ _ _ d = error $ "extractClassDecl: unexpected decl"
@@ -1074,19 +814,19 @@ extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
extractRecSel nm mdl t tvs (L _ con : rest) =
case GHC.con_details con of
GHC.RecCon fields | (GHC.HsRecField n ty _ : _) <- matching_fields fields ->
- L (getLoc n) (GHC.TypeSig (mkNoLoc nm) (mkNoLoc (GHC.HsFunTy data_ty (GHC.getBangType ty))))
+ L (getLoc n) (GHC.TypeSig (noLoc nm) (noLoc (GHC.HsFunTy data_ty (GHC.getBangType ty))))
_ -> extractRecSel nm mdl t tvs rest
where
matching_fields flds = [ f | f@(GHC.HsRecField n _ _) <- flds, (unLoc n) == nm ]
- data_ty = foldl (\x y -> mkNoLoc (GHC.HsAppTy x y)) (mkNoLoc (GHC.HsTyVar t)) (map toTypeNoLoc tvs)
+ data_ty = foldl (\x y -> noLoc (GHC.HsAppTy x y)) (noLoc (GHC.HsTyVar t)) (map toTypeNoLoc tvs)
-- -----------------------------------------------------------------------------
-- Pruning
-pruneExportItems :: [ExportItem] -> [ExportItem]
-pruneExportItems items = filter has_doc items
- where has_doc (ExportDecl _ d _) = isJust (declDoc d)
- has_doc _ = True
+pruneExportItems :: [ExportItem2 GHC.Name] -> [ExportItem2 GHC.Name]
+pruneExportItems items = filter hasDoc items
+ where hasDoc (ExportDecl2 _ _ d _) = isJust d
+ hasDoc _ = True
-- -----------------------------------------------------------------------------
@@ -1119,7 +859,7 @@ visibleNames mdl modMap localNames scope subMap maybeExps opts
GHC.IEThingAll t -> return (t : all_subs)
where
all_subs | nameModule t == mdl = Map.findWithDefault [] t subMap
- | otherwise = all_subs_of_qname modMap t
+ | otherwise = allSubsOfName modMap t
GHC.IEThingWith t cs -> return (t : cs)
@@ -1136,20 +876,16 @@ visibleNames mdl modMap localNames scope subMap maybeExps opts
_ -> return []
-exportModuleMissingErr this mdl
- = ["Warning: in export list of " ++ show this
- ++ ": module not found: " ++ show 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).
-all_subs_of_qname :: ModuleMap2 -> GHC.Name -> [GHC.Name]
-all_subs_of_qname mod_map name
+allSubsOfName :: ModuleMap2 -> GHC.Name -> [GHC.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.all_subs_of_qname: unexpected unqual'd name"
+ | 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
@@ -1182,14 +918,6 @@ buildGlobalDocEnv modules
nameSetMod n newMod = mkExternalName (nameUnique n) newMod (nameOccName n) Nothing (nameSrcLoc n)
-builtinDocEnv = Map.fromList (map (\a -> (a,a)) builtinNames)
-
--- These names cannot be explicitly exported, so we need to treat
--- them specially.
-builtinNames =
- [unit_tycon_qname, fun_tycon_qname, list_tycon_qname,
- unit_con_name, nil_con_name]
-
-- -----------------------------------------------------------------------------
-- Named documentation
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-24 18:45:22 +0000