diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/HaddockHoogle.hs | 4 | ||||
| -rw-r--r-- | src/HaddockHtml.hs | 555 | ||||
| -rw-r--r-- | src/HaddockRename.hs | 52 | ||||
| -rw-r--r-- | src/HaddockTypes.hs | 211 | ||||
| -rw-r--r-- | src/HaddockUtil.hs | 17 | ||||
| -rw-r--r-- | src/Main.hs | 435 |
6 files changed, 653 insertions, 621 deletions
diff --git a/src/HaddockHoogle.hs b/src/HaddockHoogle.hs index 3b624cd6..da43f007 100644 --- a/src/HaddockHoogle.hs +++ b/src/HaddockHoogle.hs @@ -11,6 +11,9 @@ module HaddockHoogle ( ppHoogle ) where +ppHoogle = undefined + +{- import HaddockTypes import HaddockUtil import HsSyn2 @@ -178,3 +181,4 @@ ppExport (ExportDecl name decl insts) = ppDecl decl ++ map ppInst insts ppExport _ = [] +-} diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs index e9011d57..31254702 100644 --- a/src/HaddockHtml.hs +++ b/src/HaddockHtml.hs @@ -20,7 +20,6 @@ import HaddockModuleTree import HaddockTypes import HaddockUtil import HaddockVersion -import HsSyn2 hiding ( DocMarkup(..), markup, idMarkup, Module(..) ) import Html import qualified Html import Map ( Map ) @@ -34,82 +33,83 @@ import Data.Maybe ( fromJust, isJust, mapMaybe, fromMaybe ) import Foreign.Marshal.Alloc ( allocaBytes ) import System.IO ( IOMode(..), hClose, hGetBuf, hPutBuf ) -import qualified GHC +import GHC import Name import Module import RdrName hiding ( Qual ) +import SrcLoc +import FastString ( unpackFS ) +import BasicTypes ( IPName(..), Boxity(..) ) +import Kind +--import Outputable ( ppr, defaultUserStyle ) -- 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] + -> [HaddockModule] -> FilePath -- destination directory - -> Maybe Doc -- prologue text, maybe - -> Maybe String -- the Html Help format (--html-help) + -> Maybe (GHC.HsDoc GHC.RdrName) -- prologue text, maybe + -> Maybe String -- the Html Help format (--html-help) -> SourceURLs -- the source URL (--source) -> WikiURLs -- the wiki URL (--wiki) -> Maybe String -- the contents URL (--use-contents) -> Maybe String -- the index URL (--use-index) -> IO () -ppHtml doctitle maybe_package ifaces odir prologue maybe_html_help_format +ppHtml doctitle maybe_package hmods odir prologue maybe_html_help_format maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url = do let - visible_ifaces = filter visible ifaces - visible i = OptHide `notElem` iface_options i + visible_hmods = filter visible hmods + visible i = OptHide `notElem` hmod_options i when (not (isJust maybe_contents_url)) $ ppHtmlContents odir doctitle maybe_package maybe_html_help_format maybe_index_url maybe_source_url maybe_wiki_url - [ iface{iface_package=Nothing} | iface <- visible_ifaces ] + [ hmod { hmod_package = Nothing } | hmod <- visible_hmods ] -- we don't want to display the packages in a single-package contents prologue when (not (isJust maybe_index_url)) $ ppHtmlIndex odir doctitle maybe_package maybe_html_help_format - maybe_contents_url maybe_source_url maybe_wiki_url visible_ifaces + maybe_contents_url maybe_source_url maybe_wiki_url visible_hmods when (not (isJust maybe_contents_url && isJust maybe_index_url)) $ - ppHtmlHelpFiles doctitle maybe_package ifaces odir maybe_html_help_format [] + ppHtmlHelpFiles doctitle maybe_package hmods odir maybe_html_help_format [] mapM_ (ppHtmlModule odir doctitle maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url) visible_ifaces + maybe_contents_url maybe_index_url) visible_hmods ppHtmlHelpFiles :: String -- doctitle -> Maybe String -- package - -> [Interface] + -> [HaddockModule] -> FilePath -- destination directory -> Maybe String -- the Html Help format (--html-help) -> [FilePath] -- external packages paths -> IO () -ppHtmlHelpFiles doctitle maybe_package ifaces odir maybe_html_help_format pkg_paths = do +ppHtmlHelpFiles doctitle maybe_package hmods odir maybe_html_help_format pkg_paths = do let - visible_ifaces = filter visible ifaces - visible i = OptHide `notElem` iface_options i + visible_hmods = filter visible hmods + visible i = OptHide `notElem` hmod_options i -- Generate index and contents page for Html Help if requested case maybe_html_help_format of Nothing -> return () - Just "mshelp" -> ppHHProject odir doctitle maybe_package visible_ifaces pkg_paths + Just "mshelp" -> ppHHProject odir doctitle maybe_package visible_hmods pkg_paths Just "mshelp2" -> do - ppHH2Files odir maybe_package visible_ifaces pkg_paths + ppHH2Files odir maybe_package visible_hmods pkg_paths ppHH2Collection odir doctitle maybe_package - Just "devhelp" -> ppDevHelpFile odir doctitle maybe_package visible_ifaces + Just "devhelp" -> ppDevHelpFile odir doctitle maybe_package visible_hmods Just format -> fail ("The "++format++" format is not implemented") --} + copyFile :: FilePath -> FilePath -> IO () copyFile fromFPath toFPath = (bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom -> @@ -515,40 +515,43 @@ ppHtmlIndex odir doctitle maybe_package maybe_html_help_format -- --------------------------------------------------------------------------- -- Generate the HTML page for a module -{- + ppHtmlModule :: FilePath -> String -> SourceURLs -> WikiURLs -> Maybe String -> Maybe String - -> Interface -> IO () + -> HaddockModule -> IO () ppHtmlModule odir doctitle maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url iface = do + maybe_contents_url maybe_index_url hmod = do let - Module mdl = iface_module iface + mod = hmod_mod hmod + mdl = moduleString mod html = header (documentCharacterEncoding +++ thetitle (toHtml mdl) +++ styleSheet +++ (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++ body << vanillaTable << ( - pageHeader mdl iface doctitle + pageHeader mdl hmod doctitle maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url </> s15 </> - ifaceToHtml maybe_source_url maybe_wiki_url iface </> s15 </> + hmodToHtml maybe_source_url maybe_wiki_url hmod </> s15 </> footer ) writeFile (pathJoin [odir, moduleHtmlFile mdl]) (renderHtml html) -ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> HtmlTable -ifaceToHtml maybe_source_url maybe_wiki_url iface +hmodToHtml :: SourceURLs -> WikiURLs -> HaddockModule -> HtmlTable +hmodToHtml maybe_source_url maybe_wiki_url hmod = abovesSep s15 (contents: description: synopsis: maybe_doc_hdr: bdy) - where - exports = numberSectionHeadings (iface_exports iface) + where + docMap = hmod_rn_doc_map hmod + + exports = numberSectionHeadings (hmod_rn_export_items hmod) - has_doc (ExportDecl _ d _) = isJust (declDoc d) - has_doc (ExportNoDecl _ _ _) = False - has_doc (ExportModule _) = False + has_doc (ExportDecl2 _ _ doc _) = isJust doc + has_doc (ExportNoDecl2 _ _ _) = False + has_doc (ExportModule2 _) = False has_doc _ = True no_doc_at_all = not (any has_doc exports) @@ -556,7 +559,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface contents = td << vanillaTable << ppModuleContents exports description - = case iface_doc iface of + = case hmod_rn_doc hmod of Nothing -> Html.emptyTable Just doc -> (tda [theclass "section1"] << toHtml "Description") </> docBox (docToHtml doc) @@ -568,7 +571,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface = (tda [theclass "section1"] << toHtml "Synopsis") </> s15 </> (tda [theclass "body"] << vanillaTable << - abovesSep s8 (map (processExport True linksInfo) + abovesSep s8 (map (processExport True linksInfo docMap) (filter forSummary exports)) ) @@ -577,13 +580,13 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface maybe_doc_hdr = case exports of [] -> Html.emptyTable - ExportGroup _ _ _ : _ -> Html.emptyTable + ExportGroup2 _ _ _ : _ -> Html.emptyTable _ -> tda [ theclass "section1" ] << toHtml "Documentation" - bdy = map (processExport False linksInfo) exports - linksInfo = (maybe_source_url, maybe_wiki_url, iface) + bdy = map (processExport False linksInfo docMap) exports + linksInfo = (maybe_source_url, maybe_wiki_url, hmod) -ppModuleContents :: [ExportItem] -> HtmlTable +ppModuleContents :: [ExportItem2 DocName] -> HtmlTable ppModuleContents exports | length sections == 0 = Html.emptyTable | otherwise = tda [theclass "section4"] << bold << toHtml "Contents" @@ -591,9 +594,9 @@ ppModuleContents exports where (sections, _leftovers{-should be []-}) = process 0 exports - process :: Int -> [ExportItem] -> ([Html],[ExportItem]) + process :: Int -> [ExportItem2 DocName] -> ([Html],[ExportItem2 DocName]) process _ [] = ([], []) - process n items@(ExportGroup lev id0 doc : rest) + process n items@(ExportGroup2 lev id0 doc : rest) | lev <= n = ( [], items ) | otherwise = ( html:secs, rest2 ) where @@ -608,33 +611,33 @@ ppModuleContents exports -- we need to assign a unique id to each section heading so we can hyperlink -- them from the contents: -numberSectionHeadings :: [ExportItem] -> [ExportItem] +numberSectionHeadings :: [ExportItem2 DocName] -> [ExportItem2 DocName] numberSectionHeadings exports = go 1 exports - where go :: Int -> [ExportItem] -> [ExportItem] + where go :: Int -> [ExportItem2 DocName] -> [ExportItem2 DocName] go _ [] = [] - go n (ExportGroup lev _ doc : es) - = ExportGroup lev (show n) doc : go (n+1) es + go n (ExportGroup2 lev _ doc : es) + = ExportGroup2 lev (show n) doc : go (n+1) es go n (other:es) = other : go n es -processExport :: Bool -> LinksInfo -> ExportItem -> HtmlTable -processExport _ _ (ExportGroup lev id0 doc) +processExport :: Bool -> LinksInfo -> DocMap -> (ExportItem2 DocName) -> HtmlTable +processExport _ _ _ (ExportGroup2 lev id0 doc) = ppDocGroup lev (namedAnchor id0 << docToHtml doc) -processExport summary links (ExportDecl x decl insts) - = doDecl summary links x decl insts -processExport summmary _ (ExportNoDecl _ y []) - = declBox (ppHsQName y) -processExport summmary _ (ExportNoDecl _ y subs) - = declBox (ppHsQName y <+> parenList (map ppHsQName subs)) -processExport _ _ (ExportDoc doc) +processExport summary links docMap (ExportDecl2 x decl doc insts) + = doDecl summary links x decl doc insts docMap +processExport summmary _ _ (ExportNoDecl2 _ y []) + = declBox (ppDocName y) +processExport summmary _ _ (ExportNoDecl2 _ y subs) + = declBox (ppDocName y <+> parenList (map ppDocName subs)) +processExport _ _ _ (ExportDoc2 doc) = docBox (docToHtml doc) -processExport _ _ (ExportModule (Module mdl)) - = declBox (toHtml "module" <+> ppModule mdl) +processExport _ _ _ (ExportModule2 mod) + = declBox (toHtml "module" <+> ppModule (moduleString mod)) -forSummary :: ExportItem -> Bool -forSummary (ExportGroup _ _ _) = False -forSummary (ExportDoc _) = False -forSummary _ = True +forSummary :: (ExportItem2 DocName) -> Bool +forSummary (ExportGroup2 _ _ _) = False +forSummary (ExportDoc2 _) = False +forSummary _ = True ppDocGroup :: Int -> Html -> HtmlTable ppDocGroup lev doc @@ -643,6 +646,191 @@ ppDocGroup lev doc | lev == 3 = tda [ theclass "section3" ] << doc | otherwise = tda [ theclass "section4" ] << doc +declWithDoc :: Bool -> LinksInfo -> SrcSpan -> Name -> Maybe (HsDoc DocName) -> Html -> HtmlTable +declWithDoc True _ _ _ _ html_decl = declBox html_decl +declWithDoc False links loc nm Nothing html_decl = topDeclBox links loc nm html_decl +declWithDoc False links loc nm (Just doc) html_decl = + topDeclBox links loc nm html_decl </> docBox (docToHtml doc) + +doDecl :: Bool -> LinksInfo -> Name -> LHsDecl DocName -> + Maybe (HsDoc DocName) -> [InstHead2 DocName] -> DocMap -> HtmlTable +doDecl summary links x (L loc d) mbDoc instances docMap = doDecl d + where + doDecl (TyClD d) = doTyClD d + doDecl (SigD s) = ppSig summary links loc mbDoc s + doDecl (ForD d) = ppFor summary links loc mbDoc d + + doTyClD d0@(TyData {}) = ppDataDecl summary links instances x mbDoc d0 + doTyClD d0@(TySynonym {}) = ppTySyn summary links loc mbDoc d0 + doTyClD d0@(ClassDecl {}) = ppClassDecl summary links instances x loc mbDoc docMap d0 + +ppSig :: Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) -> Sig DocName -> HtmlTable +ppSig summary links loc mbDoc (TypeSig lname ltype) + | summary || noArgDocs t = + declWithDoc summary links loc n mbDoc (ppTypeSig summary n t) + | otherwise = topDeclBox links loc n (ppHsBinder False n) </> + (tda [theclass "body"] << vanillaTable << ( + do_args dcolon t </> + (case mbDoc of + Just doc -> ndocBox (docToHtml doc) + Nothing -> Html.emptyTable) + )) + + where + t = unLoc ltype + NoLink n = unLoc lname + + noLArgDocs (L _ t) = noArgDocs t + noArgDocs (HsForAllTy _ _ _ t) = noLArgDocs t + noArgDocs (HsFunTy (L _ (HsDocTy _ _)) _) = False + noArgDocs (HsFunTy _ r) = noLArgDocs r + noArgDocs (HsDocTy _ _) = False + noArgDocs _ = True + + do_largs leader (L _ t) = do_args leader t + do_args :: Html -> (HsType DocName) -> HtmlTable + do_args leader (HsForAllTy Explicit tvs lctxt ltype) + = (argBox ( + leader <+> + hsep (keyword "forall" : ppTyVars tvs ++ [toHtml "."]) <+> + ppLContext lctxt) + <-> rdocBox noHtml) </> + do_largs darrow ltype + do_args leader (HsForAllTy Implicit _ lctxt ltype) + = (argBox (leader <+> ppLContext lctxt) + <-> rdocBox noHtml) </> + do_largs darrow ltype + do_args leader (HsFunTy (L _ (HsDocTy lt ldoc)) r) + = (argBox (leader <+> ppLType lt) <-> rdocBox (docToHtml (unLoc ldoc))) + </> do_largs arrow r + do_args leader (HsFunTy lt r) + = (argBox (leader <+> ppLType lt) <-> rdocBox noHtml) </> do_largs arrow r + do_args leader (HsDocTy lt ldoc) + = (argBox (leader <+> ppLType lt) <-> rdocBox (docToHtml (unLoc ldoc))) + do_args leader t + = argBox (leader <+> ppType t) <-> rdocBox (noHtml) + +ppTyVars tvs = map ppName (tyvarNames tvs) + +tyvarNames = map f + where f x = let NoLink n = hsTyVarName (unLoc x) in n + +ppFor = undefined +ppDataDecl = undefined + +ppTySyn summary links loc mbDoc (TySynonym lname ltyvars ltype) + = declWithDoc summary links loc n mbDoc ( + hsep ([keyword "type", ppHsBinder summary n] + ++ ppTyVars ltyvars) <+> equals <+> ppLType ltype) + where NoLink n = unLoc lname + +ppLType (L _ t) = ppType t + +ppLContext (L _ c) = ppContext c + +ppContext = ppPreds . (map unLoc) + +ppPreds [] = empty +ppPreds [pred] = ppPred pred +ppPreds preds = parenList (map ppPred preds) + +ppPred (HsClassP n ts) = ppDocName n <+> hsep (map ppLType ts) +ppPred (HsIParam (Dupable n) t) + = toHtml "?" +++ ppDocName n <+> dcolon <+> ppLType t +ppPred (HsIParam (Linear n) t) + = toHtml "%" +++ ppDocName n <+> dcolon <+> ppLType t + +ppTypeSig :: Bool -> Name -> (HsType DocName) -> Html +ppTypeSig summary nm ty = ppHsBinder summary nm <+> dcolon <+> ppType ty + +-- ----------------------------------------------------------------------------- +-- Class declarations + +--ppClassHdr :: Bool -> HsContext -> HsName -> [HsName] -> [HsFunDep] -> Html +ppClassHdr summ (L _ []) n tvs fds = + keyword "class" + <+> ppHsBinder summ n <+> hsep (ppTyVars tvs) + <+> ppFds fds +ppClassHdr summ lctxt n tvs fds = + keyword "class" <+> ppLContext lctxt <+> darrow + <+> ppHsBinder summ n <+> hsep (ppTyVars tvs) + <+> ppFds fds + +--ppFds :: [HsFunDep] -> Html +ppFds fds = + if null fds then noHtml else + char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) + where + fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> toHtml "->" <+> + hsep (map ppDocName vars2) + +ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> DocMap -> HtmlTable +ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ _) loc docMap = + if null sigs + then (if summary then declBox else topDeclBox links loc nm) hdr + else (if summary then declBox else topDeclBox links loc nm) (hdr <+> keyword "where") + </> + (tda [theclass "body"] << + vanillaTable << + aboves [ ppSig summary links loc mbDoc sig + | L _ sig@(TypeSig (L _ (NoLink n)) ty) <- sigs, let mbDoc = Map.lookup n docMap ] + ) + where + hdr = ppClassHdr summary lctxt nm tvs fds + NoLink nm = unLoc lname + +ppClassDecl :: Ord key => Bool -> LinksInfo -> [InstHead2 DocName] -> key -> SrcSpan -> + Maybe (HsDoc DocName) -> DocMap -> TyClDecl DocName -> + HtmlTable +ppClassDecl summary links instances orig_c loc mbDoc docMap + decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ _) + | summary = ppShortClassDecl summary links decl loc docMap + | otherwise + = classheader </> + tda [theclass "body"] << vanillaTable << ( + classdoc </> methods_bit </> instances_bit + ) + where + classheader + | null lsigs = topDeclBox links loc nm hdr + | otherwise = topDeclBox links loc nm (hdr <+> keyword "where") + + NoLink nm = unLoc lname + ctxt = unLoc lctxt + + hdr = ppClassHdr summary lctxt nm ltyvars lfds + + classdoc = case mbDoc of + Nothing -> Html.emptyTable + Just d -> ndocBox (docToHtml d) + + methods_bit + | null lsigs = Html.emptyTable + | otherwise = + s8 </> meth_hdr </> + tda [theclass "body"] << vanillaTable << ( + abovesSep s8 [ ppSig summary links loc mbDoc sig + | L _ sig@(TypeSig (L _ (NoLink n)) t) <- lsigs, let mbDoc = Map.lookup n docMap ] + ) + + inst_id = collapseId nm + instances_bit + | null instances = Html.emptyTable + | otherwise + = s8 </> inst_hdr inst_id </> + tda [theclass "body"] << + collapsed thediv inst_id ( + spacedTable1 << ( + aboves (map (declBox.ppInstHead) instances) + )) + +ppInstHead :: InstHead2 DocName -> Html +ppInstHead ([], n, ts) = ppAsst n ts +ppInstHead (ctxt, n, ts) = ppPreds ctxt <+> ppAsst n ts + +ppAsst n ts = ppDocName n <+> hsep (map ppType ts) + +{- -- ----------------------------------------------------------------------------- -- Converting declarations to HTML @@ -684,9 +872,6 @@ doDecl summary links x d instances = do_decl d do_decl _ = nrror ("do_decl: " ++ show d) -ppTypeSig :: Bool -> HsName -> HsType -> Html -ppTypeSig summary nm ty = ppHsBinder summary nm <+> dcolon <+> ppHsType ty - -- ----------------------------------------------------------------------------- -- Data & newtype declarations @@ -777,7 +962,7 @@ ppHsConstrHdr tvs ctxt hsep (map ppHsName tvs) <+> toHtml ". ") +++ - (if null ctxt then noHtml else ppHsContext ctxt <+> toHtml "=> ") + (if null ctxt then noHtml else ppContext ctxt <+> toHtml "=> ") ppSideBySideConstr :: HsConDecl -> HtmlTable ppSideBySideConstr (HsConDecl _ nm tvs ctxt typeList doc) = @@ -851,96 +1036,6 @@ ppHsBangType :: HsBangType -> Html ppHsBangType (HsBangedTy ty) = char '!' +++ ppHsAType ty ppHsBangType (HsUnBangedTy ty) = ppHsAType ty --- ----------------------------------------------------------------------------- --- Class declarations - -ppClassHdr :: Bool -> HsContext -> HsName -> [HsName] -> [HsFunDep] -> Html -ppClassHdr summ [] n tvs fds = - keyword "class" - <+> ppHsBinder summ n <+> hsep (map ppHsName tvs) - <+> ppFds fds -ppClassHdr summ ctxt n tvs fds = - keyword "class" <+> ppHsContext ctxt <+> darrow - <+> ppHsBinder summ n <+> hsep (map ppHsName tvs) - <+> ppFds fds - -ppFds :: [HsFunDep] -> Html -ppFds fds = - if null fds then noHtml else - char '|' <+> hsep (punctuate comma (map fundep fds)) - where - fundep (vars1,vars2) = hsep (map ppHsName vars1) <+> toHtml "->" <+> - hsep (map ppHsName vars2) - -ppShortClassDecl :: Bool -> LinksInfo -> HsDecl -> HtmlTable -ppShortClassDecl summary links (HsClassDecl loc ctxt nm tvs fds decls _) = - if null decls - then (if summary then declBox else topDeclBox links loc nm) hdr - else (if summary then declBox else topDeclBox links loc nm) (hdr <+> keyword "where") - </> - (tda [theclass "body"] << - vanillaTable << - aboves [ ppFunSig summary links loc n ty doc - | HsTypeSig _ [n] ty doc <- decls - ] - ) - - where - hdr = ppClassHdr summary ctxt nm tvs fds -ppShortClassDecl _ _ d = - error $ "HaddockHtml.ppShortClassDecl: unexpected decl: " ++ show d - -ppHsClassDecl :: Ord key => Bool -> LinksInfo -> [InstHead] -> key -> HsDecl -> HtmlTable -ppHsClassDecl summary links instances orig_c - decl@(HsClassDecl loc ctxt nm tvs fds decls doc) - | summary = ppShortClassDecl summary links decl - - | otherwise - = classheader </> - tda [theclass "body"] << vanillaTable << ( - classdoc </> methods_bit </> instances_bit - ) - - where - classheader - | null decls = topDeclBox links loc nm hdr - | otherwise = topDeclBox links loc nm (hdr <+> keyword "where") - - hdr = ppClassHdr summary ctxt nm tvs fds - - classdoc = case doc of - Nothing -> Html.emptyTable - Just d -> ndocBox (docToHtml d) - - methods_bit - | null decls = Html.emptyTable - | otherwise = - s8 </> meth_hdr </> - tda [theclass "body"] << vanillaTable << ( - abovesSep s8 [ ppFunSig summary links loc n ty doc0 - | HsTypeSig _ [n] ty doc0 <- decls - ] - ) - - inst_id = collapseId nm - instances_bit - | null instances = Html.emptyTable - | otherwise - = s8 </> inst_hdr inst_id </> - tda [theclass "body"] << - collapsed thediv inst_id ( - spacedTable1 << ( - aboves (map (declBox.ppInstHead) instances) - )) - -ppHsClassDecl _ _ _ _ d = - error $ "HaddockHtml.ppHsClassDecl: unexpected decl: " ++ show d - - -ppInstHead :: InstHead -> Html -ppInstHead ([],asst) = ppHsAsst asst -ppInstHead (ctxt,asst) = ppHsContext ctxt <+> darrow <+> ppHsAsst asst - -- ---------------------------------------------------------------------------- -- Type signatures @@ -987,97 +1082,80 @@ ppFunSig summary links loc nm ty0 doc do_args leader ty = argBox (leader <+> ppHsBType ty) <-> rdocBox (noHtml) +-} + -- ---------------------------------------------------------------------------- -- Types and contexts -ppHsAsst :: HsAsst -> Html -ppHsAsst (c,args) = ppHsQName c <+> hsep (map ppHsAType args) - -ppHsContext :: HsContext -> Html -ppHsContext [] = empty -ppHsContext [ctxt] = ppHsAsst ctxt -ppHsContext context = parenList (map ppHsAsst context) - -ppHsCtxt :: HsCtxt -> Html -ppHsCtxt (HsAssump asst) = ppHsAsst asst -ppHsCtxt (HsIP n t) = toHtml "?" +++ ppHsName n <+> dcolon <+> ppHsType t - -ppHsIPContext :: HsIPContext -> Html -ppHsIPContext [] = empty -ppHsIPContext [ctxt] = ppHsCtxt ctxt -ppHsIPContext context = parenList (map ppHsCtxt context) - -ppHsForAll :: Maybe [HsName] -> HsIPContext -> Html -ppHsForAll Nothing context = - hsep [ ppHsIPContext context, darrow ] -ppHsForAll (Just tvs) [] = - hsep (keyword "forall" : map ppHsName tvs ++ [toHtml "."]) -ppHsForAll (Just tvs) context = - hsep (keyword "forall" : map ppHsName tvs ++ - [toHtml ".", ppHsIPContext context, darrow]) - -ppHsType :: HsType -> Html -ppHsType (HsForAllType maybe_tvs context htype) = - ppHsForAll maybe_tvs context <+> ppHsType htype -ppHsType (HsTyFun a b) = hsep [ppHsBType a, toHtml "->", ppHsType b] -ppHsType (HsTyIP n t) = toHtml "?" +++ ppHsName n <+> dcolon <+> ppHsType t -ppHsType t = ppHsBType t - -ppHsBType :: HsType -> Html -ppHsBType (HsTyDoc ty _) = ppHsBType ty -ppHsBType (HsTyApp (HsTyCon (Qual _ (HsTyClsName (HsSpecial "[]")))) b ) - = brackets $ ppHsType b -ppHsBType (HsTyApp a b) = ppHsBType a <+> ppHsAType b -ppHsBType t = ppHsAType t - -ppHsAType :: HsType -> Html -ppHsAType (HsTyTuple True l) = parenList . map ppHsType $ l -ppHsAType (HsTyTuple False l) = ubxParenList . map ppHsType $ l -ppHsAType (HsTyVar nm) = ppHsName nm -ppHsAType (HsTyCon nm) - | nm == fun_tycon_qname = parens $ ppHsQName nm - | otherwise = ppHsQName nm -ppHsAType (HsTyApp (HsTyCon (Qual _ (HsTyClsName (HsSpecial "[]")))) b ) - = brackets $ ppHsType b -ppHsAType t = parens $ ppHsType t --} +ppKind kind = case kind of + LiftedTypeKind -> char '*' + OpenTypeKind -> char '?' + UnboxedTypeKind -> char '#' + UnliftedTypeKind -> char '!' + UbxTupleKind -> toHtml "(##)" + ArgTypeKind -> toHtml "??" + FunKind k1 k2 -> hsep [ppKind k1, toHtml "->", ppKind k2] + KindVar v -> ppOccName (kindVarOcc v) + +ppCtxtPart (L _ ctxt) + | null ctxt = empty + | otherwise = hsep [ppContext ctxt, darrow] + +ppForAll (HsForAllTy Implicit _ lctxt _) = ppCtxtPart lctxt +ppForAll (HsForAllTy Explicit ltvs lctxt _) = + hsep (keyword "forall" : ppTyVars ltvs ++ [toHtml "."]) <+> ppCtxtPart lctxt + +ppType :: HsType DocName -> Html +ppType t = case t of + t@(HsForAllTy expl ltvs lcontext ltype) -> ppForAll t <+> ppLType ltype + HsTyVar n -> ppDocName n + HsBangTy HsStrict lt -> toHtml "!" <+> ppLType lt + HsBangTy HsUnbox lt -> toHtml "!!" <+> ppLType lt + HsAppTy a b -> ppLType a <+> ppLType b + HsFunTy a b -> hsep [ppLType a, toHtml "->", ppLType b] + HsListTy t -> brackets $ ppLType t + HsPArrTy t -> toHtml "[:" +++ ppLType t +++ toHtml ":]" + HsTupleTy Boxed ts -> parenList $ map ppLType ts + HsTupleTy Unboxed ts -> ubxParenList $ map ppLType ts + HsOpTy a n b -> ppLType a <+> ppLDocName n <+> ppLType b + HsParTy t -> parens $ ppLType t + HsNumTy n -> toHtml (show n) + HsPredTy p -> ppPred p + HsKindSig t k -> hsep [ppLType t, dcolon, ppKind k] + HsSpliceTy _ -> error "ppType" + HsDocTy t _ -> ppLType t + -- ---------------------------------------------------------------------------- -- Names -ppRdrName :: GHC.RdrName -> Html -ppRdrName = toHtml . occNameString . rdrNameOcc +ppOccName :: OccName -> Html +ppOccName name = toHtml $ occNameString name + +ppRdrName :: RdrName -> Html +ppRdrName = ppOccName . rdrNameOcc + +ppLDocName (L _ d) = ppDocName d ppDocName :: DocName -> Html ppDocName (Link name) = linkId (nameModule name) (Just name) << ppName name ppDocName (NoLink name) = toHtml (getOccString name) -linkTarget :: 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 +linkTarget :: Name -> Html +linkTarget name = namedAnchor (anchorNameStr name) << toHtml "" -ppName :: GHC.Name -> Html +ppName :: Name -> Html ppName name = toHtml (getOccString name) -ppHsName :: HsName -> Html -ppHsName nm = toHtml (hsNameStr nm) - -ppHsBinder :: Bool -> HsName -> Html +ppHsBinder :: Bool -> Name -> Html -- The Bool indicates whether we are generating the summary, in which case -- the binder will be a link to the full definition. -ppHsBinder True nm = linkedAnchor (hsAnchorNameStr nm) << ppHsBinder' nm +ppHsBinder True nm = linkedAnchor (anchorNameStr nm) << ppHsBinder' nm ppHsBinder False nm = linkTarget nm +++ bold << ppHsBinder' nm +ppHsBinder' :: Name -> Html +ppHsBinder' name = toHtml (getOccString name) + +{- ppHsBinder' :: HsName -> Html ppHsBinder' (HsTyClsName id0) = ppHsBindIdent id0 ppHsBinder' (HsVarName id0) = ppHsBindIdent id0 @@ -1086,8 +1164,8 @@ ppHsBindIdent :: HsIdentifier -> Html ppHsBindIdent (HsIdent str) = toHtml str ppHsBindIdent (HsSymbol str) = parens (toHtml str) ppHsBindIdent (HsSpecial str) = toHtml str - -linkId :: GHC.Module -> Maybe GHC.Name -> Html -> Html +-} +linkId :: GHC.Module -> Maybe Name -> Html -> Html linkId mod mbName = anchor ! [href hr] where hr = case mbName of @@ -1219,10 +1297,10 @@ 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 -> GHC.Name -> Html -> HtmlTable +topDeclBox :: LinksInfo -> SrcSpan -> Name -> Html -> HtmlTable topDeclBox ((_,_,Nothing), (_,_,Nothing), _) _ _ html = declBox html topDeclBox ((_,_,maybe_source_url), (_,_,maybe_wiki_url), hmod) - (SrcLoc _ _ fname) name html = + loc name html = tda [theclass "topdecl"] << ( table ! [theclass "declbar"] << ((tda [theclass "declname"] << html) @@ -1245,6 +1323,7 @@ topDeclBox ((_,_,maybe_source_url), (_,_,maybe_wiki_url), hmod) in anchor ! [href url'] << toHtml "Comments" mod = hmod_mod hmod + fname = unpackFS (srcSpanFile loc) -- a box for displaying an 'argument' (some code which has text to the -- right of it). Wrapping is not allowed in these boxes, whereas it is @@ -1322,8 +1401,8 @@ collapsed fn id html = -- A quote is a valid part of a Haskell identifier, but it would interfere with -- the ECMA script string delimiter used in collapsebutton above. -collapseId :: HsName -> String -collapseId nm = "i:" ++ escapeStr (hsNameStr nm) +collapseId :: Name -> String +collapseId nm = "i:" ++ escapeStr (getOccString nm) linkedAnchor :: String -> Html -> Html linkedAnchor frag = anchor ! [href hr] diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs index 1953a23c..fa3df77c 100644 --- a/src/HaddockRename.hs +++ b/src/HaddockRename.hs @@ -6,7 +6,7 @@ module HaddockRename ( runRnFM, -- the monad (instance of Monad) - renameMaybeDoc, renameExportItems, + renameDoc, renameMaybeDoc, renameExportItems, ) where import HaddockTypes @@ -70,6 +70,12 @@ runRn lkp rn = unRn rn lkp -- ----------------------------------------------------------------------------- -- Renaming +keep n = NoLink n +keepL (L loc n) = L loc (NoLink n) + +rename = lookupRn id +renameL (L loc name) = return . L loc =<< rename name + renameExportItems :: [ExportItem2 Name] -> RnM [ExportItem2 DocName] renameExportItems items = mapM renameExportItem items @@ -119,9 +125,6 @@ renameDoc doc = case doc of DocURL str -> return (DocURL str) DocAName str -> return (DocAName str) -rename = lookupRn id -renameL (L loc name) = return . L loc =<< rename name - renameLPred (L loc p) = return . L loc =<< renamePred p renamePred :: HsPred Name -> RnM (HsPred DocName) @@ -218,43 +221,40 @@ renameDecl d = case d of _ -> error "renameDecl" renameTyClD d = case d of - ForeignType name a b -> do - name' <- renameL name - return (ForeignType name' a b) + ForeignType _ _ _ -> error "renameTyClD" -- I'm guessing these can't be exported + -- ForeignType name a b -> do + -- name' <- renameL name + -- return (ForeignType name' a b) TyData x lcontext lname ltyvars k cons _ -> do lcontext' <- renameLContext lcontext - lname' <- renameL lname ltyvars' <- mapM renameLTyVarBndr ltyvars cons' <- mapM renameLCon cons -- we don't need the derivings - return (TyData x lcontext' lname' ltyvars' k cons' Nothing) + return (TyData x lcontext' (keepL lname) ltyvars' k cons' Nothing) TySynonym lname ltyvars ltype -> do - lname' <- renameL lname ltyvars' <- mapM renameLTyVarBndr ltyvars ltype' <- renameLType ltype - return (TySynonym lname' ltyvars' ltype') + return (TySynonym (keepL lname) ltyvars' ltype') ClassDecl lcontext lname ltyvars lfundeps lsigs _ _ -> do lcontext' <- renameLContext lcontext - lname' <- renameL lname ltyvars' <- mapM renameLTyVarBndr ltyvars lfundeps' <- mapM renameLFunDep lfundeps lsigs' <- mapM renameLSig lsigs -- we don't need the default methods or the already collected doc entities - return (ClassDecl lcontext' lname' ltyvars' lfundeps' lsigs' emptyBag []) + return (ClassDecl lcontext' (keepL lname) ltyvars' lfundeps' lsigs' emptyBag []) where renameLCon (L loc con) = return . L loc =<< renameCon con renameCon (ConDecl lname expl ltyvars lcontext details restype mbldoc) = do - lname' <- renameL lname ltyvars' <- mapM renameLTyVarBndr ltyvars lcontext' <- renameLContext lcontext details' <- renameDetails details restype' <- renameResType restype mbldoc' <- mapM renameLDoc mbldoc - return (ConDecl lname' expl ltyvars' lcontext' details' restype' mbldoc') + return (ConDecl (keepL lname) expl ltyvars' lcontext' details' restype' mbldoc') renameDetails (RecCon fields) = return . RecCon =<< mapM renameField fields renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps @@ -264,27 +264,22 @@ renameTyClD d = case d of return (InfixCon a' b') renameField (HsRecField id arg doc) = do - id' <- renameL id arg' <- renameLType arg doc' <- mapM renameLDoc doc - return (HsRecField id' arg' doc') + return (HsRecField (keepL id) arg' doc') renameResType (ResTyH98) = return ResTyH98 renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t - renameLFunDep (L loc (xs, ys)) = do - xs' <- mapM rename xs - ys' <- mapM rename ys - return (L loc (xs', ys')) + renameLFunDep (L loc (xs, ys)) = return (L loc (map keep xs, map keep ys)) renameLSig (L loc sig) = return . L loc =<< renameSig sig renameSig sig = case sig of - TypeSig lname ltype -> do - lname' <- renameL lname + TypeSig (L loc name) ltype -> do ltype' <- renameLType ltype - return (TypeSig lname' ltype') - SpecSig lname ltype x -> do + return (TypeSig (L loc (keep name)) ltype') +{- SpecSig lname ltype x -> do lname' <- renameL lname ltype' <- renameLType ltype return (SpecSig lname' ltype' x) @@ -297,15 +292,14 @@ renameSig sig = case sig of renameFixitySig (FixitySig lname x) = do lname' <- renameL lname return (FixitySig lname' x) +-} renameForD (ForeignImport lname ltype x y) = do - lname' <- renameL lname ltype' <- renameLType ltype - return (ForeignImport lname' ltype' x y) + return (ForeignImport (keepL lname) ltype' x y) renameForD (ForeignExport lname ltype x y) = do - lname' <- renameL lname ltype' <- renameLType ltype - return (ForeignExport lname' ltype' x y) + return (ForeignExport (keepL lname) ltype' x y) renameExportItem :: ExportItem2 Name -> RnM (ExportItem2 DocName) renameExportItem item = case item of diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs index 0c5fd428..ae9c3d8b 100644 --- a/src/HaddockTypes.hs +++ b/src/HaddockTypes.hs @@ -3,186 +3,123 @@ -- -- (c) Simon Marlow 2003 -- +-- Ported to use the GHC API by David Waern 2006 +-- module HaddockTypes ( - -- * Module interfaces - NameEnv, Interface(..), ExportItem(..), ExportItem2(..), ModuleMap, ModuleMap2, + ExportItem2(..), + ModuleMap2, + DocMap, HaddockModule(..), - -- * Misc types - DocOption(..), InstHead, InstHead2, + DocOption(..), + InstHead2, DocName(..), DocMarkup(..) ) where -import HsSyn2 hiding ( DocMarkup ) - -import qualified GHC as GHC +import GHC +import Outputable import Data.Map --- --------------------------------------------------------------------------- --- Describing a module interface - -type NameEnv = Map HsName HsQName - -data Interface - = Interface { - iface_filename :: FilePath, - -- ^ the filename that contains the source code for this module - - iface_orig_filename :: FilePath, - -- ^ the original filename for this module, which may be - -- different to the 'iface_filename' (for example the original - -- file may have had a .lhs or .hs.pp extension). - - iface_module :: Module, - - iface_package :: Maybe String, - - iface_env :: NameEnv, - -- ^ environment mapping exported names to *original* names - - iface_reexported :: [HsName], - -- ^ For names exported by this module, but not - -- actually documented in this module's documentation - -- (perhaps because they are reexported via 'module M' - -- in the export list), this mapping gives the - -- location of documentation for the name in another - -- module. - - iface_sub :: Map HsName [HsName], - -- ^ maps names to "subordinate" names - -- (eg. tycon to constrs & fields, class to methods) - - iface_exports :: [ExportItem], - -- ^ the exports used to construct the documentation - - iface_orig_exports :: [ExportItem], - -- ^ the exports used to construct the documentation - -- (with orig names, not import names) - - iface_decls :: Map HsName HsDecl, - -- ^ decls from this module (only) - -- restricted to only those bits exported. - -- the map key is the "main name" of the decl. - - iface_insts :: [HsDecl], - -- ^ instances from this module - - iface_info :: ModuleInfo, - -- ^ information from the module header - - iface_doc :: Maybe Doc, - -- ^ documentation from the module header - - iface_options :: [DocOption] - -- ^ module-wide doc options - } - data DocOption - = OptHide -- this module should not appear in the docs + = OptHide -- ^ This module should not appear in the docs | OptPrune - | OptIgnoreExports -- pretend everything is exported - | OptNotHome -- not the best place to get docs for things - -- exported by this module. + | OptIgnoreExports -- ^ Pretend everything is exported + | OptNotHome -- ^ Not the best place to get docs for things + -- exported by this module. deriving (Eq, Show) -data ExportItem - = ExportDecl - HsQName -- the original name - HsDecl -- a declaration (with doc annotations) - [InstHead] -- instances relevant to this declaration - - | ExportNoDecl -- an exported entity for which we have no documentation - -- (perhaps becuase it resides in another package) - HsQName -- the original name - HsQName -- where to link to - [HsQName] -- subordinate names - - | ExportGroup -- a section heading - Int -- section level (1, 2, 3, ... ) - String -- section "id" (for hyperlinks) - Doc -- section heading text - - | ExportDoc -- some documentation - Doc - - | ExportModule -- a cross-reference to another module - Module - data ExportItem2 name = ExportDecl2 - GHC.Name -- the original name - (GHC.LHsDecl name) -- a declaration - (Maybe (GHC.HsDoc name)) -- maybe a doc comment - [InstHead2 name] -- instances relevant to this declaration - - | ExportNoDecl2 -- an exported entity for which we have no documentation - -- (perhaps becuase it resides in another package) - GHC.Name -- the original name - name -- where to link to - [name] -- subordinate names - - | ExportGroup2 -- a section heading - Int -- section level (1, 2, 3, ... ) - String -- section "id" (for hyperlinks) - (GHC.HsDoc name) -- section heading text - - | ExportDoc2 -- some documentation - (GHC.HsDoc name) - - | ExportModule2 -- a cross-reference to another module - GHC.Module - -type InstHead = (HsContext,HsAsst) - -type InstHead2 name = ([GHC.HsPred name], name, [GHC.HsType name]) - -type ModuleMap = Map Module Interface -type ModuleMap2 = Map GHC.Module HaddockModule - -data DocName = Link GHC.Name | NoLink GHC.Name + Name -- ^ The original name + (LHsDecl name) -- ^ A declaration + (Maybe (HsDoc name)) -- ^ Maybe a doc comment + [InstHead2 name] -- ^ Instances relevant to this declaration + + | ExportNoDecl2 -- ^ An exported entity for which we have no + -- documentation (perhaps because it resides in + -- another package) + Name -- ^ The original name + name -- ^ Where to link to + [name] -- ^ Subordinate names + + | ExportGroup2 -- ^ A section heading + Int -- ^ section level (1, 2, 3, ... ) + String -- ^ Section "id" (for hyperlinks) + (HsDoc name) -- ^ Section heading text + + | ExportDoc2 -- ^ Some documentation + (HsDoc name) + + | ExportModule2 -- ^ A cross-reference to another module + Module + +type InstHead2 name = ([HsPred name], name, [HsType name]) +type ModuleMap2 = Map Module HaddockModule +type DocMap = Map Name (HsDoc DocName) +data DocName = Link Name | NoLink Name + +instance Outputable DocName where + ppr (Link n) = ppr n + ppr (NoLink n) = ppr n data HaddockModule = HM { -- | A value to identify the module - hmod_mod :: GHC.Module, + + hmod_mod :: Module, -- | The original filename for this module + hmod_orig_filename :: FilePath, -- | Textual information about the module - hmod_info :: GHC.HaddockModInfo GHC.Name, + + hmod_info :: HaddockModInfo Name, -- | The documentation header for this module - hmod_doc :: Maybe (GHC.HsDoc GHC.Name), + + hmod_doc :: Maybe (HsDoc Name), + +-- | The renamed documentation header for this module + + hmod_rn_doc :: Maybe (HsDoc DocName), -- | The Haddock options for this module (prune, ignore-exports, etc) + hmod_options :: [DocOption], - hmod_exported_decl_map :: Map GHC.Name (GHC.LHsDecl GHC.Name), - hmod_doc_map :: Map GHC.Name (GHC.HsDoc GHC.Name), - hmod_export_items :: [ExportItem2 GHC.Name], + hmod_exported_decl_map :: Map Name (LHsDecl Name), + hmod_doc_map :: Map Name (HsDoc Name), + hmod_rn_doc_map :: Map Name (HsDoc DocName), + + hmod_export_items :: [ExportItem2 Name], + hmod_rn_export_items :: [ExportItem2 DocName], -- | All the names that are defined in this module - hmod_locals :: [GHC.Name], + + hmod_locals :: [Name], -- | All the names that are exported by this module - hmod_exports :: [GHC.Name], + + hmod_exports :: [Name], -- | All the visible names exported by this module -- For a name to be visible, it has to: -- - be exported normally, and not via a full module re-exportation. -- - have a declaration in this module or any of it's imports, with the exception -- that it can't be from another package. --- Basically, a visible name is a name that will show up in the documentation. +-- Basically, a visible name is a name that will show up in the documentation -- for this module. - hmod_visible_exports :: [GHC.Name], - hmod_sub_map :: Map GHC.Name [GHC.Name], + hmod_visible_exports :: [Name], + + hmod_sub_map :: Map Name [Name], -- | The instances exported by this module - hmod_instances :: [GHC.Instance], + + hmod_instances :: [Instance], hmod_package :: Maybe String } @@ -200,6 +137,6 @@ data DocMarkup id a = Markup { markupOrderedList :: [a] -> a, markupDefList :: [(a,a)] -> a, markupCodeBlock :: a -> a, - markupURL :: String -> a, - markupAName :: String -> a + markupURL :: String -> a, + markupAName :: String -> a } diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs index 99c814f4..b4121752 100644 --- a/src/HaddockUtil.hs +++ b/src/HaddockUtil.hs @@ -16,6 +16,7 @@ module HaddockUtil ( basename, dirname, splitFilename3, moduleHtmlFile, nameHtmlRef, contentsHtmlFile, indexHtmlFile, subIndexHtmlFile, pathJoin, + anchorNameStr, cssFile, iconFile, jsFile, plusFile, minusFile, -- * Miscellaneous utilities @@ -279,7 +280,7 @@ isPathSeparator ch = moduleHtmlFile :: String -> FilePath moduleHtmlFile mdl = - case Map.lookup (Module mdl) html_xrefs of + case Map.lookup (GHC.mkModule mdl) html_xrefs of Nothing -> mdl' ++ ".html" Just fp0 -> pathJoin [fp0, mdl' ++ ".html"] where @@ -288,11 +289,6 @@ moduleHtmlFile mdl = 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" indexHtmlFile = "doc-index.html" @@ -302,6 +298,11 @@ subIndexHtmlFile a = "doc-index-" ++ b ++ ".html" where b | isAlpha a = [a] | otherwise = show (ord a) +anchorNameStr :: Name -> String +anchorNameStr name | isValOcc occName = "v:" ++ getOccString name + | otherwise = "t:" ++ getOccString name + where occName = nameOccName name + pathJoin :: [FilePath] -> FilePath pathJoin = foldr join [] where join :: FilePath -> FilePath -> FilePath @@ -368,11 +369,11 @@ escapeStr = escapeURIString isUnreserved -- being I'm going to use a write-once global variable. {-# NOINLINE html_xrefs_ref #-} -html_xrefs_ref :: IORef (Map Module FilePath) +html_xrefs_ref :: IORef (Map GHC.Module FilePath) html_xrefs_ref = unsafePerformIO (newIORef (error "module_map")) {-# NOINLINE html_xrefs #-} -html_xrefs :: Map Module FilePath +html_xrefs :: Map GHC.Module FilePath html_xrefs = unsafePerformIO (readIORef html_xrefs_ref) ----------------------------------------------------------------------------- diff --git a/src/Main.hs b/src/Main.hs index 009f8f03..73f31581 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -7,7 +7,7 @@ module Main (main) where -import HsSyn2 +--import HsSyn2 import HaddockHtml import HaddockHoogle import HaddockRename @@ -15,10 +15,9 @@ import HaddockTypes import HaddockUtil import HaddockVersion import Paths_haddock ( getDataDir ) -import Binary2 import Control.Exception ( bracket ) -import Control.Monad ( when ) +import Control.Monad ( when, liftM ) import Control.Monad.Writer ( Writer, runWriter, tell ) import Data.Char ( isSpace ) import Data.IORef ( writeIORef ) @@ -36,17 +35,10 @@ import qualified Data.Map as Map import Data.Map (Map) import Data.Maybe import Data.List ( nubBy ) - -#if __GLASGOW_HASKELL__ >= 603 -import System.Process -import System.Exit -import Control.Exception ( Exception(..), throwIO, catch ) -import Prelude hiding (catch) -import System.Directory ( doesDirectoryExist, doesFileExist ) -import Control.Concurrent -#endif +import Data.FunctorM ( fmapM ) import qualified GHC as GHC +import GHC import Outputable import SrcLoc import qualified Digraph as Digraph @@ -246,29 +238,29 @@ run flags files = do die ("-h cannot be used with --gen-index or --gen-contents") GHC.init (Just "/home/davve/dev/local/lib/ghc-6.5") - let ghcMode = GHC.JustTypecheck - session <- GHC.newSession ghcMode - ghcFlags <- GHC.getSessionDynFlags session - ghcFlags' <- GHC.initPackages ghcFlags + let ghcMode = JustTypecheck + session <- newSession ghcMode + ghcFlags <- getSessionDynFlags session + ghcFlags' <- initPackages ghcFlags let haddockGhcFlags = [ f | Flag_GHCFlag f <- flags ] - (ghcFlags'', rest) <- GHC.parseDynamicFlags ghcFlags' haddockGhcFlags + (ghcFlags'', rest) <- parseDynamicFlags ghcFlags' haddockGhcFlags when (not (null rest)) (die $ "The following flags are not GHC flags: " ++ pprList rest ++ "\n") let ghcFlags''' = DynFlags.dopt_set ghcFlags'' DynFlags.Opt_Haddock - sorted_checked_modules <- GHC.defaultErrorHandler ghcFlags''' $ do - GHC.setSessionDynFlags session ghcFlags''' - targets <- mapM (\s -> GHC.guessTarget s Nothing) files - GHC.setTargets session targets - maybe_module_graph <- GHC.depanal session [] True + sorted_checked_modules <- defaultErrorHandler ghcFlags''' $ do + setSessionDynFlags session ghcFlags''' + targets <- mapM (\s -> guessTarget s Nothing) files + setTargets session targets + maybe_module_graph <- 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, 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 ] + let sorted_modules = concatMap Digraph.flattenSCC (topSortModuleGraph False module_graph Nothing) + let (modules, filenames) = unzip [ (ms_mod modsum, fromJust $ ml_hs_file (ms_location modsum)) | modsum <- sorted_modules, + fromJust (ml_hs_file (ms_location modsum)) `elem` files ] - mb_checked_modules <- mapM (GHC.checkModule session) modules + mb_checked_modules <- mapM (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" @@ -286,8 +278,8 @@ run flags files = do let haddockModules' = attachInstances haddockModules - let (renamedModules, messages') = runWriter $ mapM (renameModule env) haddockModules' - + let (haddockModules'', messages') = runWriter $ mapM (renameModule env) haddockModules' + putStrLn "pass 1 messages:" print messages putStrLn "pass 1 export items:" @@ -297,7 +289,7 @@ run flags files = do printSDoc (ppr (Map.toList env)) defaultUserStyle putStrLn "pass 2 export items:" - printSDoc (ppr renamedModules) defaultUserStyle + printSDoc (ppr (map hmod_rn_export_items haddockModules'')) defaultUserStyle mapM_ putStrLn messages' let visibleModules = [ m | m <- haddockModules', OptHide `notElem` (hmod_options m) ] @@ -319,25 +311,14 @@ run flags files = do visibleModules prologue copyHtmlBits odir libdir css_file - - --let Just (group, imports, exports) = GHC.renamedSource (head sorted_checked_modules) - --printSDoc (ppr group) defaultUserStyle - --- let exports = GHC.modInfoExports $ fromJust $ GHC.checkedModuleInfo $ snd $ (head sorted_checked_modules) ---- printSDoc (ppr exports) defaultUserStyle - - - - -{- let parsed_source = unLoc $ GHC.parsedSource (head checked_modules) - printSDoc (ppr parsed_source) defaultUserStyle --} + when (Flag_Html `elem` flags) $ do + ppHtml title package visibleModules odir + prologue maybe_html_help_format + maybe_source_urls maybe_wiki_urls + maybe_contents_url maybe_index_url + copyHtmlBits odir libdir css_file return () - -- case successFlag of - -- GHC.Succeeded -> bye "Succeeded" - -- GHC.Failed -> bye "Could not load all targets" - {- parsed_mods <- mapM parse_file files sorted_mod_files <- sortModules (zip parsed_mods files) @@ -414,7 +395,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), f) | (mod, GHC.CheckedModule a (Just b) (Just c) (Just d), f) <- modules ] + where modules' = [ (mod, (a,b,c,d), f) | (mod, CheckedModule a (Just b) (Just c) (Just d), f) <- modules ] print_ x = printSDoc (ppr x) defaultUserStyle @@ -425,26 +406,26 @@ instance (Outputable a, OutputableBndr a) => Outputable (ExportItem2 a) where ppr (ExportDoc2 doc) = text "ExportDoc" <+> ppr doc ppr (ExportModule2 mod) = text "ExportModule" <+> ppr mod -instance Outputable DocName where - ppr (Link name) = ppr name - ppr (NoLink name) = ppr name +--instance Outputable DocName where +-- ppr (Link name) = ppr name +-- ppr (NoLink name) = ppr name instance OutputableBndr DocName where pprBndr _ d = ppr d -instance Outputable (GHC.DocEntity GHC.Name) where - ppr (GHC.DocEntity d) = ppr d - ppr (GHC.DeclEntity name) = ppr name +instance Outputable (DocEntity Name) where + ppr (DocEntity d) = ppr d + ppr (DeclEntity name) = ppr name -type FullyCheckedModule = (GHC.ParsedSource, - GHC.RenamedSource, - GHC.TypecheckedSource, - GHC.ModuleInfo) +type FullyCheckedModule = (ParsedSource, + RenamedSource, + TypecheckedSource, + ModuleInfo) -pass1 :: [(GHC.Module, FullyCheckedModule, FilePath)] -> [Flag] -> Maybe String-> ErrMsgM ModuleMap2 +pass1 :: [(Module, FullyCheckedModule, FilePath)] -> [Flag] -> Maybe String-> ErrMsgM ModuleMap2 pass1 modules flags package = worker modules (Map.empty) flags where - worker :: [(GHC.Module, FullyCheckedModule, FilePath)] -> ModuleMap2 -> [Flag] -> ErrMsgM ModuleMap2 + worker :: [(Module, FullyCheckedModule, FilePath)] -> ModuleMap2 -> [Flag] -> ErrMsgM ModuleMap2 worker [] moduleMap _ = return moduleMap worker ((mod, checked_mod, filename):rest_modules) moduleMap flags = do @@ -454,16 +435,16 @@ pass1 modules flags package = worker modules (Map.empty) flags opts <- mk_doc_opts mb_doc_opts let (group, _, mb_exports, mbModDoc, haddockModInfo) = renamed_source - entities = nubBy sameName (GHC.hs_docs group) + entities = nubBy sameName (hs_docs group) exports = fmap (map unLoc) mb_exports -- lots of names - exportedNames = GHC.modInfoExports moduleInfo + exportedNames = modInfoExports moduleInfo theseEntityNames = entityNames entities subNames = allSubnamesInGroup group localNames = theseEntityNames ++ subNames -- guaranteed to be Just, since the module has been compiled from scratch - scopeNames = fromJust $ GHC.modInfoTopLevelScope moduleInfo + scopeNames = fromJust $ modInfoTopLevelScope moduleInfo subMap = mk_sub_map_from_group group @@ -485,18 +466,21 @@ pass1 modules flags package = worker modules (Map.empty) flags | OptPrune `elem` opts = pruneExportItems exportItems | otherwise = exportItems - instances = GHC.modInfoInstances moduleInfo + instances = modInfoInstances moduleInfo haddock_module = HM { hmod_mod = mod, hmod_orig_filename = filename, hmod_info = haddockModInfo, hmod_doc = mbModDoc, + hmod_rn_doc = Nothing, hmod_options = opts, hmod_locals = localNames, hmod_doc_map = docMap, + hmod_rn_doc_map = Map.empty, hmod_sub_map = subMap, hmod_export_items = prunedExportItems, + hmod_rn_export_items = [], hmod_exports = exportedNames, hmod_visible_exports = theseVisibleNames, hmod_exported_decl_map = exportedDeclMap, @@ -510,7 +494,7 @@ pass1 modules flags package = worker modules (Map.empty) flags where get_module_stuff source = - let GHC.HsModule _ _ _ _ _ mb_opts info mb_doc = unLoc source + let HsModule _ _ _ _ _ mb_opts info mb_doc = unLoc source in (mb_opts, info, mb_doc) mk_doc_opts mb_opts = do @@ -522,21 +506,21 @@ pass1 modules flags package = worker modules (Map.empty) flags else opts return opts' -sameName (GHC.DocEntity _) _ = False -sameName (GHC.DeclEntity _) (GHC.DocEntity _) = False -sameName (GHC.DeclEntity a) (GHC.DeclEntity b) = a == b +sameName (DocEntity _) _ = False +sameName (DeclEntity _) (DocEntity _) = False +sameName (DeclEntity a) (DeclEntity b) = a == b -mkDocMap :: GHC.HsGroup GHC.Name -> Map GHC.Name (GHC.HsDoc GHC.Name) +mkDocMap :: HsGroup Name -> Map Name (HsDoc Name) mkDocMap group = Map.fromList $ - collectDocs (GHC.hs_docs group) ++ collectDocsFromClassMeths (getClasses group) + collectDocs (hs_docs group) ++ collectDocsFromClassMeths (getClasses group) where - getClasses group = filter GHC.isClassDecl (map unLoc (GHC.hs_tyclds group)) - collectDocsFromClassMeths classes = concatMap (collectDocs . GHC.tcdDocs) classes + getClasses group = filter isClassDecl (map unLoc (hs_tyclds group)) + collectDocsFromClassMeths classes = concatMap (collectDocs . tcdDocs) classes -collectDocs :: [GHC.DocEntity GHC.Name] -> [(GHC.Name, GHC.HsDoc GHC.Name)] -collectDocs entities = collect Nothing GHC.DocEmpty entities +collectDocs :: [DocEntity Name] -> [(Name, HsDoc Name)] +collectDocs entities = collect Nothing DocEmpty entities -collect :: Maybe (GHC.DocEntity GHC.Name) -> GHC.HsDoc GHC.Name -> [GHC.DocEntity GHC.Name] -> [(GHC.Name, GHC.HsDoc GHC.Name)] +collect :: Maybe (DocEntity Name) -> HsDoc Name -> [DocEntity Name] -> [(Name, HsDoc Name)] collect d doc_so_far [] = case d of Nothing -> [] @@ -544,69 +528,99 @@ collect d doc_so_far [] = collect d doc_so_far (e:es) = case e of - GHC.DocEntity (GHC.DocCommentNext str) -> + DocEntity (DocCommentNext str) -> case d of - Nothing -> collect d (GHC.docAppend doc_so_far str) es + Nothing -> collect d (docAppend doc_so_far str) es Just d0 -> finishedDoc d0 doc_so_far (collect Nothing str es) - GHC.DocEntity (GHC.DocCommentPrev str) -> collect d (GHC.docAppend doc_so_far str) es + DocEntity (DocCommentPrev str) -> collect d (docAppend doc_so_far str) es _other -> case d of Nothing -> collect (Just e) doc_so_far es Just d0 -> finishedDoc d0 doc_so_far - (collect (Just e) GHC.DocEmpty es) + (collect (Just e) DocEmpty es) -finishedDoc :: GHC.DocEntity GHC.Name -> GHC.HsDoc GHC.Name -> [(GHC.Name, GHC.HsDoc GHC.Name)] -> [(GHC.Name, GHC.HsDoc GHC.Name)] -finishedDoc d GHC.DocEmpty rest = rest -finishedDoc (GHC.DeclEntity name) doc rest = (name, doc) : rest +finishedDoc :: DocEntity Name -> HsDoc Name -> [(Name, HsDoc Name)] -> [(Name, HsDoc Name)] +finishedDoc d DocEmpty rest = rest +finishedDoc (DeclEntity name) doc rest = (name, doc) : rest finishedDoc _ _ rest = rest -allSubnamesInGroup :: GHC.HsGroup GHC.Name -> [GHC.Name] +allSubnamesInGroup :: HsGroup Name -> [Name] allSubnamesInGroup group = - concat [ tail (map unLoc (GHC.tyClDeclNames tycld)) | L _ tycld <- GHC.hs_tyclds group ] + concat [ tail (map unLoc (tyClDeclNames tycld)) | L _ tycld <- hs_tyclds group ] -mk_sub_map_from_group :: GHC.HsGroup GHC.Name -> Map GHC.Name [GHC.Name] +mk_sub_map_from_group :: HsGroup Name -> Map Name [Name] mk_sub_map_from_group group = - Map.fromList [ (name, subs) | L _ tycld <- GHC.hs_tyclds group, - let name:subs = map unLoc (GHC.tyClDeclNames tycld) ] + Map.fromList [ (name, subs) | L _ tycld <- hs_tyclds group, + let name:subs = map unLoc (tyClDeclNames tycld) ] -mkDeclMap :: [GHC.Name] -> GHC.HsGroup GHC.Name -> Map GHC.Name (GHC.LHsDecl GHC.Name) +mkDeclMap :: [Name] -> HsGroup Name -> Map Name (LHsDecl Name) mkDeclMap names group = Map.fromList [ (n,d) | (n,Just d) <- maybeDecls ] where maybeDecls = [ (name, getDeclFromGroup group name) | name <- names ] -entityNames :: [GHC.DocEntity GHC.Name] -> [GHC.Name] -entityNames entities = [ name | GHC.DeclEntity name <- entities ] - -getDeclFromGroup :: GHC.HsGroup GHC.Name -> GHC.Name -> Maybe (GHC.LHsDecl GHC.Name) -getDeclFromGroup group name = case catMaybes [getDeclFromVals (GHC.hs_valds group), - getDeclFromTyCls (GHC.hs_tyclds group), - getDeclFromFors (GHC.hs_fords group)] of - [decl] -> Just decl +entityNames :: [DocEntity Name] -> [Name] +entityNames entities = [ name | DeclEntity name <- entities ] +{- +getValSig :: Name -> HsValBinds Name -> TypeEnv -> Maybe (LSig Name) +getValSig name (ValBindsOut recsAndBinds _) typEnv = case matchingBinds of + [bind] -> -- OK we have found a binding that matches. Now look up the + -- type, even though it may be present in the ValBindsOut + let tything = lookupTypeEnv typeEnv name _ -> Nothing where - getDeclFromVals (GHC.ValBindsOut _ lsigs) = case matching of - [lsig] -> Just (L (getLoc lsig) (GHC.SigD (unLoc lsig))) + binds = snd $ unzip recsAndBinds + matchingBinds = Bag.filter matchesName binds + matchesName (L _ bind) = fun_id bind == name +getValSig _ _ _ = error "getValSig" +-} +getDeclFromGroup :: HsGroup Name -> Name -> Maybe (LHsDecl Name) +getDeclFromGroup group name = + case catMaybes [ getDeclFromVals (hs_valds group), + getDeclFromTyCls (hs_tyclds group), + getDeclFromFors (hs_fords group) ] of + [decl] -> Just decl + _ -> Nothing + where + getDeclFromVals (ValBindsOut _ lsigs) = case matching of + [lsig] -> Just (L (getLoc lsig) (SigD (unLoc lsig))) _ -> Nothing where - matching = [ lsig | lsig <- lsigs, let Just n = GHC.sigName lsig, n == name ] + matching = [ lsig | lsig <- lsigs, let Just n = sigName lsig, n == name, + isNormal (unLoc lsig) ] + isNormal (TypeSig _ _) = True + isNormal _ = False + getDeclFromVals _ = error "getDeclFromVals: illegal input" - + +{- getDeclFromVals (ValBindsOut recsAndbinds _) = + let binds = snd $ unzip recsAndBinds + matchingBinds = Bag.filter matchesName binds + matchesName (L _ bind) = fun_id bind == name + in case matchingBinds of + [bind] -> -- OK we have found a binding that matches. Now look up the + -- type, even though it may be present in the ValBindsOut + + _ -> Nothing + where + matching = [ lsig | lsig <- lsigs, let Just n = sigName lsig, n == name ] + getDeclFromVals _ = error "getDeclFromVals: illegal input" + -} getDeclFromTyCls ltycls = case matching of - [ltycl] -> Just (L (getLoc ltycl) (GHC.TyClD (unLoc ltycl))) + [ltycl] -> Just (L (getLoc ltycl) (TyClD (unLoc ltycl))) _ -> Nothing where matching = [ ltycl | ltycl <- ltycls, - name `elem` map unLoc (GHC.tyClDeclNames (unLoc ltycl))] + name `elem` map unLoc (tyClDeclNames (unLoc ltycl))] getDeclFromFors lfors = case matching of - [for] -> Just (L (getLoc for) (GHC.ForD (unLoc for))) + [for] -> Just (L (getLoc for) (ForD (unLoc for))) _ -> Nothing where matching = [ for | for <- lfors, forName (unLoc for) == name ] - forName (GHC.ForeignExport n _ _ _) = unLoc n - forName (GHC.ForeignImport n _ _ _) = unLoc n + forName (ForeignExport n _ _ _) = unLoc n + forName (ForeignImport n _ _ _) = unLoc n parseIfaceOption :: String -> (FilePath,FilePath) parseIfaceOption s = @@ -614,22 +628,22 @@ parseIfaceOption s = (fpath,',':file) -> (fpath,file) (file, _) -> ("", file) -updateHTMLXRefs :: [FilePath] -> [[Interface]] -> IO () -updateHTMLXRefs paths ifaces_s = +updateHTMLXRefs :: [FilePath] -> [[HaddockModule]] -> IO () +updateHTMLXRefs paths hmods_s = writeIORef html_xrefs_ref (Map.fromList mapping) where - mapping = [ (iface_module iface, fpath) - | (fpath, ifaces) <- zip paths ifaces_s, - iface <- ifaces + mapping = [ (hmod_mod hmod, fpath) + | (fpath, hmods) <- zip paths hmods_s, + hmod <- hmods ] -getPrologue :: [Flag] -> IO (Maybe (GHC.HsDoc GHC.RdrName)) +getPrologue :: [Flag] -> IO (Maybe (HsDoc RdrName)) getPrologue flags = case [filename | Flag_Prologue filename <- flags ] of [] -> return Nothing [filename] -> do str <- readFile filename - case GHC.parseHaddockComment str of + case parseHaddockComment str of Left err -> dieMsg err Right doc -> return (Just doc) _otherwise -> dieMsg "multiple -p/--prologue options" @@ -637,7 +651,7 @@ getPrologue flags -- ----------------------------------------------------------------------------- -- Phase 2 -renameModule :: Map GHC.Name GHC.Name -> HaddockModule -> ErrMsgM ([ExportItem2 DocName], Maybe (GHC.HsDoc DocName)) +renameModule :: Map Name Name -> HaddockModule -> ErrMsgM HaddockModule renameModule renamingEnv mod = -- first create the local env, where every name exported by this module @@ -645,31 +659,35 @@ renameModule renamingEnv mod = -- env let localEnv = foldl fn renamingEnv (hmod_visible_exports mod) where fn env name = Map.insert name (nameSetMod name (hmod_mod mod)) env + + docs = Map.toList (hmod_doc_map mod) + renameMapElem (k,d) = do d' <- renameDoc d; return (k, d') -- rename names in the exported declarations to point to things that - -- are closer, or maybe even exported by, the current module. + -- are closer to, or maybe even exported by, the current module. (renamedExportItems, missingNames1) = runRnFM localEnv (renameExportItems (hmod_export_items mod)) - (finalModuleDoc, missingNames2) + (rnDocMap, missingNames2) + = runRnFM localEnv (liftM Map.fromList (mapM renameMapElem docs)) + + (finalModuleDoc, missingNames3) = runRnFM localEnv (renameMaybeDoc (hmod_doc mod)) - missingNames = nub $ filter isExternalName (missingNames1 ++ missingNames2) + missingNames = nub $ filter isExternalName + (missingNames1 ++ missingNames2 ++ missingNames3) strings = map (showSDoc . ppr) missingNames in do - -- report things that we couldn't link to. Only do this - -- for non-hidden modules. - when (OptHide `notElem` hmod_options mod && - not (null strings)) $ + -- report things that we couldn't link to. Only do this for non-hidden modules. + when (OptHide `notElem` hmod_options mod && not (null strings)) $ tell ["Warning: " ++ show (ppr (hmod_mod mod) defaultUserStyle) ++ ": could not find link destinations for:\n"++ - " " ++ concat (map (' ':) strings) - ] - - -- trace (show (Map.toAscList import_env)) $ do + " " ++ concat (map (' ':) strings) ] - return (renamedExportItems, finalModuleDoc) + return $ mod { hmod_rn_doc = finalModuleDoc, + hmod_rn_doc_map = rnDocMap, + hmod_rn_export_items = renamedExportItems } -- ----------------------------------------------------------------------------- -- Build the list of items that will become the documentation, from the @@ -678,17 +696,17 @@ renameModule renamingEnv mod = mkExportItems :: ModuleMap2 - -> GHC.Module -- this module - -> [GHC.Name] -- exported names (orig) - -> Map GHC.Name (GHC.LHsDecl GHC.Name) -- maps exported names to declarations - -> Map GHC.Name (GHC.LHsDecl GHC.Name) -- maps local names to declarations - -> Map GHC.Name [GHC.Name] -- sub-map for this module - -> [GHC.DocEntity GHC.Name] -- entities in the current module + -> Module -- this module + -> [Name] -- exported names (orig) + -> Map Name (LHsDecl Name) -- maps exported names to declarations + -> Map Name (LHsDecl Name) -- maps local names to declarations + -> Map Name [Name] -- sub-map for this module + -> [DocEntity Name] -- entities in the current module -> [DocOption] - -> Maybe [GHC.IE GHC.Name] + -> Maybe [IE Name] -> Bool -- --ignore-all-exports flag - -> Map GHC.Name (GHC.HsDoc GHC.Name) - -> ErrMsgM [ExportItem2 GHC.Name] + -> Map Name (HsDoc Name) + -> ErrMsgM [ExportItem2 Name] mkExportItems mod_map this_mod exported_names exportedDeclMap localDeclMap sub_map entities opts maybe_exps ignore_all_exports docMap @@ -701,21 +719,21 @@ mkExportItems mod_map this_mod exported_names exportedDeclMap localDeclMap sub_m everything_local_exported = -- everything exported return (fullContentsOfThisModule this_mod entities localDeclMap docMap) - lookupExport (GHC.IEVar x) = declWith x - lookupExport (GHC.IEThingAbs t) = declWith t - lookupExport (GHC.IEThingAll t) = declWith t - lookupExport (GHC.IEThingWith t cs) = declWith t - lookupExport (GHC.IEModuleContents m) = fullContentsOf m - lookupExport (GHC.IEGroup lev doc) = return [ ExportGroup2 lev "" doc ] - lookupExport (GHC.IEDoc doc) = return [ ExportDoc2 doc ] - lookupExport (GHC.IEDocNamed str) + lookupExport (IEVar x) = declWith x + lookupExport (IEThingAbs t) = declWith t + lookupExport (IEThingAll t) = declWith t + lookupExport (IEThingWith t cs) = declWith t + lookupExport (IEModuleContents m) = fullContentsOf m + lookupExport (IEGroup lev doc) = return [ ExportGroup2 lev "" doc ] + lookupExport (IEDoc doc) = return [ ExportDoc2 doc ] + lookupExport (IEDocNamed str) = do r <- findNamedDoc str entities case r of Nothing -> return [] Just found -> return [ ExportDoc2 found ] -- NOTE: I'm unsure about this. Currently only "External" names are considered. - declWith :: GHC.Name -> ErrMsgM [ ExportItem2 GHC.Name ] + declWith :: Name -> ErrMsgM [ ExportItem2 Name ] declWith t | not (isExternalName t) = return [] declWith t | (Just decl, maybeDoc) <- findDecl t @@ -742,7 +760,7 @@ mkExportItems mod_map this_mod exported_names exportedDeclMap localDeclMap sub_m | otherwise -> return [ ExportModule2 m ] Nothing -> return [] -- already emitted a warning in exportedNames - findDecl :: GHC.Name -> (Maybe (GHC.LHsDecl GHC.Name), Maybe (GHC.HsDoc GHC.Name)) + findDecl :: Name -> (Maybe (LHsDecl Name), Maybe (HsDoc Name)) findDecl n | not (isExternalName n) = error "This shouldn't happen" findDecl n | m == this_mod = (Map.lookup n exportedDeclMap, Map.lookup n docMap) @@ -754,76 +772,77 @@ mkExportItems mod_map this_mod exported_names exportedDeclMap localDeclMap sub_m where m = nameModule n -fullContentsOfThisModule :: GHC.Module -> [GHC.DocEntity GHC.Name] -> Map GHC.Name (GHC.LHsDecl GHC.Name) -> - Map GHC.Name (GHC.HsDoc GHC.Name) -> [ExportItem2 GHC.Name] +fullContentsOfThisModule :: Module -> [DocEntity Name] -> Map Name (LHsDecl Name) -> + Map Name (HsDoc Name) -> [ExportItem2 Name] fullContentsOfThisModule module_ entities declMap docMap = map mkExportItem entities where - mkExportItem (GHC.DocEntity (GHC.DocGroup lev doc)) = ExportGroup2 lev "" doc - mkExportItem (GHC.DeclEntity name) = case Map.lookup name declMap of - Just decl -> let maybe_doc = Map.lookup name docMap in ExportDecl2 name decl maybe_doc [] - Nothing -> error "fullContentsOfThisModule: This shouldn't happen" + mkExportItem (DocEntity (DocGroup lev doc)) = ExportGroup2 lev "" doc + mkExportItem (DeclEntity name) = trace (show (ppr name defaultUserStyle)) $ case Map.lookup name declMap of + Just decl -> let maybeDoc = Map.lookup name docMap in ExportDecl2 name decl maybeDoc [] + -- this can happen if there was no type signature for a value binding + Nothing -> ExportNoDecl2 name name [] -- Sometimes the declaration we want to export is not the "main" declaration: -- it might be an individual record selector or a class method. In these -- cases we have to extract the required declaration (and somehow cobble -- together a type signature for it...) -extractDecl :: GHC.Name -> GHC.Module -> GHC.LHsDecl GHC.Name -> GHC.LHsDecl GHC.Name +extractDecl :: Name -> Module -> LHsDecl Name -> LHsDecl Name extractDecl name mdl decl - | Just n <- GHC.getMainDeclBinder (unLoc decl), n == name = decl + | Just n <- getMainDeclBinder (unLoc decl), n == name = decl | otherwise = case unLoc decl of - GHC.TyClD d | GHC.isClassDecl d -> - let matches = [ sig | sig <- GHC.tcdSigs d, GHC.sigName sig == Just name ] + TyClD d | isClassDecl d -> + let matches = [ sig | sig <- tcdSigs d, sigName sig == Just name ] in case matches of [s0] -> let (n, tyvar_names) = name_and_tyvars d L pos sig = extractClassDecl n mdl tyvar_names s0 - in L pos (GHC.SigD sig) + in L pos (SigD sig) _ -> error "internal: extractDecl" - GHC.TyClD d | GHC.isDataDecl d -> + TyClD d | 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) + L pos sig = extractRecSel name mdl n tyvar_names (tcdCons d) + in L pos (SigD sig) _ -> error "internal: extractDecl" where - name_and_tyvars d = (unLoc (GHC.tcdLName d), GHC.hsLTyVarLocNames (GHC.tcdTyVars d)) + name_and_tyvars d = (unLoc (tcdLName d), hsLTyVarLocNames (tcdTyVars d)) -toTypeNoLoc :: Located GHC.Name -> GHC.LHsType GHC.Name -toTypeNoLoc lname = noLoc (GHC.HsTyVar (unLoc lname)) +toTypeNoLoc :: Located Name -> LHsType Name +toTypeNoLoc lname = noLoc (HsTyVar (unLoc lname)) rmLoc :: Located a -> Located 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 (noLoc (GHC.HsForAllTy exp tvs (lctxt preds) ty))) - _ -> L pos (GHC.TypeSig lname (noLoc (GHC.mkImplicitHsForAllTy (lctxt []) ltype))) +extractClassDecl :: Name -> Module -> [Located Name] -> LSig Name -> LSig Name +extractClassDecl c mdl tvs0 (L pos (TypeSig lname ltype)) = case ltype of + L _ (HsForAllTy exp tvs (L _ preds) ty) -> + L pos (TypeSig lname (noLoc (HsForAllTy exp tvs (lctxt preds) ty))) + _ -> L pos (TypeSig lname (noLoc (mkImplicitHsForAllTy (lctxt []) ltype))) where lctxt preds = noLoc (ctxt preds) - ctxt preds = [noLoc (GHC.HsClassP c (map toTypeNoLoc tvs0))] ++ preds + ctxt preds = [noLoc (HsClassP c (map toTypeNoLoc tvs0))] ++ preds extractClassDecl _ _ _ d = error $ "extractClassDecl: unexpected decl" -extractRecSel :: GHC.Name -> GHC.Module -> GHC.Name -> [Located GHC.Name] -> [GHC.LConDecl GHC.Name] - -> GHC.LSig GHC.Name +extractRecSel :: Name -> Module -> Name -> [Located Name] -> [LConDecl Name] + -> LSig Name extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" -- originally expected unqualified 3:rd name, now it doesn't 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 (noLoc nm) (noLoc (GHC.HsFunTy data_ty (GHC.getBangType ty)))) + case con_details con of + RecCon fields | (HsRecField n ty _ : _) <- matching_fields fields -> + L (getLoc n) (TypeSig (noLoc nm) (noLoc (HsFunTy data_ty (getBangType ty)))) _ -> extractRecSel nm mdl t tvs rest where - matching_fields flds = [ f | f@(GHC.HsRecField n _ _) <- flds, (unLoc n) == nm ] - data_ty = foldl (\x y -> noLoc (GHC.HsAppTy x y)) (noLoc (GHC.HsTyVar t)) (map toTypeNoLoc tvs) + matching_fields flds = [ f | f@(HsRecField n _ _) <- flds, (unLoc n) == nm ] + data_ty = foldl (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) (map toTypeNoLoc tvs) -- ----------------------------------------------------------------------------- -- Pruning -pruneExportItems :: [ExportItem2 GHC.Name] -> [ExportItem2 GHC.Name] +pruneExportItems :: [ExportItem2 Name] -> [ExportItem2 Name] pruneExportItems items = filter hasDoc items where hasDoc (ExportDecl2 _ _ d _) = isJust d hasDoc _ = True @@ -832,14 +851,14 @@ pruneExportItems items = filter hasDoc items -- ----------------------------------------------------------------------------- -- Gather a list of original names exported from this module -visibleNames :: GHC.Module +visibleNames :: Module -> ModuleMap2 - -> [GHC.Name] - -> [GHC.Name] - -> Map GHC.Name [GHC.Name] - -> Maybe [GHC.IE GHC.Name] + -> [Name] + -> [Name] + -> Map Name [Name] + -> Maybe [IE Name] -> [DocOption] - -> ErrMsgM [GHC.Name] + -> ErrMsgM [Name] visibleNames mdl modMap localNames scope subMap maybeExps opts -- if no export list, just return all local names @@ -854,16 +873,16 @@ visibleNames mdl modMap localNames scope subMap maybeExps opts extract e = case e of - GHC.IEVar x -> return [x] - GHC.IEThingAbs t -> return [t] - GHC.IEThingAll t -> return (t : all_subs) + IEVar x -> return [x] + IEThingAbs t -> return [t] + IEThingAll t -> return (t : all_subs) where all_subs | nameModule t == mdl = Map.findWithDefault [] t subMap | otherwise = allSubsOfName modMap t - GHC.IEThingWith t cs -> return (t : cs) + IEThingWith t cs -> return (t : cs) - GHC.IEModuleContents m + IEModuleContents m | m == mdl -> return localNames | otherwise -> case Map.lookup m modMap of @@ -879,7 +898,7 @@ visibleNames mdl modMap localNames scope subMap maybeExps opts -- for a given entity, find all the names it "owns" (ie. all the -- constructors and field names of a tycon, or all the methods of a -- class). -allSubsOfName :: ModuleMap2 -> GHC.Name -> [GHC.Name] +allSubsOfName :: ModuleMap2 -> Name -> [Name] allSubsOfName mod_map name | isExternalName name = case Map.lookup (nameModule name) mod_map of @@ -897,7 +916,7 @@ allSubsOfName mod_map name -- by reversing the list so we can do a foldl. -- -buildGlobalDocEnv :: [HaddockModule] -> Map GHC.Name GHC.Name +buildGlobalDocEnv :: [HaddockModule] -> Map Name Name buildGlobalDocEnv modules = foldl upd Map.empty (reverse modules) where @@ -921,12 +940,12 @@ nameSetMod n newMod = mkExternalName (nameUnique n) newMod (nameOccName n) Nothi -- ----------------------------------------------------------------------------- -- Named documentation -findNamedDoc :: String -> [GHC.DocEntity GHC.Name] -> ErrMsgM (Maybe (GHC.HsDoc GHC.Name)) +findNamedDoc :: String -> [DocEntity Name] -> ErrMsgM (Maybe (HsDoc Name)) findNamedDoc name entities = search entities where search [] = do tell ["Cannot find documentation for: $" ++ name] return Nothing - search ((GHC.DocEntity (GHC.DocCommentNamed name' doc)):rest) + search ((DocEntity (DocCommentNamed name' doc)):rest) | name == name' = return (Just doc) | otherwise = search rest search (_other_decl : rest) = search rest @@ -957,7 +976,7 @@ parseOption other = do tell ["Unrecognised option: " ++ other]; return Nothing -- simplified type for sorting types, ignoring qualification (not visible -- in Haddock output) and unifying special tycons with normal ones. -data SimpleType = SimpleType GHC.Name [SimpleType] deriving (Eq,Ord) +data SimpleType = SimpleType Name [SimpleType] deriving (Eq,Ord) attachInstances :: [HaddockModule] -> [HaddockModule] attachInstances modules = map attach modules @@ -975,7 +994,7 @@ attachInstances modules = map attach modules collectInstances :: [HaddockModule] - -> Map GHC.Name [([GHC.TyVar], [GHC.PredType], Class, [Type])] -- maps class/type names to instances + -> Map Name [([TyVar], [PredType], Class, [Type])] -- maps class/type names to instances collectInstances modules = Map.fromListWith (flip (++)) tyInstPairs `Map.union` @@ -987,7 +1006,7 @@ collectInstances modules tyInstPairs = [ (tycon, [instanceHead inst]) | inst <- allInstances, Just tycon <- nub (is_tcs inst) ] -instHead :: ([GHC.TyVar], [GHC.PredType], Class, [Type]) -> ([Int], GHC.Name, [SimpleType]) +instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType]) instHead (_, _, cls, args) = (map argCount args, className cls, map simplify args) where @@ -1020,34 +1039,32 @@ funTyConName = mkWiredInName gHC_PRIM (ATyCon funTyCon) -- Relevant TyCon BuiltInSyntax -toHsInstHead :: ([GHC.TyVar], [GHC.PredType], Class, [Type]) -> InstHead2 GHC.Name +toHsInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead2 Name toHsInstHead (_, preds, cls, ts) = (map toHsPred preds, className cls, map toHsType ts) -toHsPred :: PredType -> GHC.HsPred GHC.Name -toHsPred (ClassP cls ts) = GHC.HsClassP (className cls) (map toLHsType ts) -toHsPred (IParam n t) = GHC.HsIParam n (toLHsType t) +toHsPred :: PredType -> HsPred Name +toHsPred (ClassP cls ts) = HsClassP (className cls) (map toLHsType ts) +toHsPred (IParam n t) = HsIParam n (toLHsType t) toLHsType = noLoc . toHsType -toHsType :: Type -> GHC.HsType GHC.Name +toHsType :: Type -> HsType Name toHsType t = case t of - TyVarTy v -> GHC.HsTyVar (tyVarName v) - AppTy a b -> GHC.HsAppTy (toLHsType a) (toLHsType b) + TyVarTy v -> HsTyVar (tyVarName v) + AppTy a b -> HsAppTy (toLHsType a) (toLHsType b) TyConApp tc ts -> case ts of - [] -> GHC.HsTyVar (tyConName tc) - _ -> GHC.HsAppTy (tycon tc) (args ts) - FunTy a b -> GHC.HsFunTy (toLHsType a) (toLHsType b) + [] -> HsTyVar (tyConName tc) + _ -> HsAppTy (tycon tc) (args ts) + FunTy a b -> HsFunTy (toLHsType a) (toLHsType b) ForAllTy v t -> cvForAll [v] t - PredTy p -> GHC.HsPredTy (toHsPred p) + PredTy p -> HsPredTy (toHsPred p) NoteTy _ t -> toHsType t where - - tycon tc = noLoc (GHC.HsTyVar (tyConName tc)) - args ts = foldl1 (\a b -> noLoc $ GHC.HsAppTy a b) (map toLHsType ts) - + tycon tc = noLoc (HsTyVar (tyConName tc)) + args ts = foldl1 (\a b -> noLoc $ HsAppTy a b) (map toLHsType ts) cvForAll vs (ForAllTy v t) = cvForAll (v:vs) t - cvForAll vs t = GHC.mkExplicitHsForAllTy (tyvarbinders vs) (noLoc []) (toLHsType t) - tyvarbinders vs = map (noLoc . GHC.UserTyVar . tyVarName) vs + cvForAll vs t = mkExplicitHsForAllTy (tyvarbinders vs) (noLoc []) (toLHsType t) + tyvarbinders vs = map (noLoc . UserTyVar . tyVarName) vs -- ----------------------------------------------------------------------------- -- A monad which collects error messages |