From 7e00d4646b0ab3694cee32752d2a8bac04317446 Mon Sep 17 00:00:00 2001 From: davve Date: Sun, 30 Jul 2006 21:01:57 +0000 Subject: Start porting the Html renderer --- examples/Test.hs | 3 +- examples/hide-bug/B.hs | 4 +- examples/hide-bug/D.hs | 4 +- src/HaddockDevHelp.hs | 32 ++-- src/HaddockHH.hs | 6 + src/HaddockHH2.hs | 7 + src/HaddockHtml.hs | 209 +++++++++++++---------- src/HaddockModuleTree.hs | 20 ++- src/HaddockRename.hs | 39 ++--- src/HaddockTypes.hs | 30 +++- src/HaddockUtil.hs | 79 +++++++-- src/Main.hs | 428 +++++++++-------------------------------------- 12 files changed, 352 insertions(+), 509 deletions(-) diff --git a/examples/Test.hs b/examples/Test.hs index 5e8c5d03..cfc09e53 100644 --- a/examples/Test.hs +++ b/examples/Test.hs @@ -97,6 +97,7 @@ module Test ( -} f', + hej ) where import Hidden @@ -105,7 +106,7 @@ import Data.Maybe bla = Nothing ---hej = visible +hej = visible -- | This comment applies to the /following/ declaration -- and it continues until the next non-comment line diff --git a/examples/hide-bug/B.hs b/examples/hide-bug/B.hs index f2ef544a..eeaa8290 100644 --- a/examples/hide-bug/B.hs +++ b/examples/hide-bug/B.hs @@ -1,3 +1,5 @@ -module B(Test) where +module B(Test, vis) where + +vis = id data Test = Test diff --git a/examples/hide-bug/D.hs b/examples/hide-bug/D.hs index a9203a7c..e8ce5744 100644 --- a/examples/hide-bug/D.hs +++ b/examples/hide-bug/D.hs @@ -1,5 +1,7 @@ -- The link to the type T in the doc for this module should point to -- B.T, not A.T. Bug fixed in rev 1.59 of Main.hs. -module D(Test) where +module D(Test, hej) where import B + +hej = vis 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 "" $$ (text "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 "text (escapeStr (show name))<>text"\" link=\""<>text (nameHtmlRef mdl name)<>text"\"/>" $$ + ppReference name (mod:refs) = let modName = moduleString mod in + text "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 "") $$ text "" 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

(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

..

-- 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 @@ -848,86 +671,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 @@ -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 -- cgit v1.2.3