aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authordavve <davve@dtek.chalmers.se>2006-08-09 20:04:56 +0000
committerdavve <davve@dtek.chalmers.se>2006-08-09 20:04:56 +0000
commitf04ce12191b5e95fdf944c1805ef4faccb36758d (patch)
tree15bad46e903627eab6a9a145c91788117eb3c585
parent7e00d4646b0ab3694cee32752d2a8bac04317446 (diff)
More Html rendering progress
Diffstat
-rw-r--r--examples/Test.hs5
-rw-r--r--src/HaddockHoogle.hs4
-rw-r--r--src/HaddockHtml.hs555
-rw-r--r--src/HaddockRename.hs52
-rw-r--r--src/HaddockTypes.hs211
-rw-r--r--src/HaddockUtil.hs17
-rw-r--r--src/Main.hs435
7 files changed, 654 insertions, 625 deletions
diff --git a/examples/Test.hs b/examples/Test.hs
index cfc09e53..230f32d8 100644
--- a/examples/Test.hs
+++ b/examples/Test.hs
@@ -96,8 +96,7 @@ module Test (
$ a non /literal/ line $
-}
- f',
- hej
+ f'
) where
import Hidden
@@ -106,8 +105,6 @@ import Data.Maybe
bla = Nothing
-hej = visible
-
-- | This comment applies to the /following/ declaration
-- and it continues until the next non-comment line
data T a b
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-16 00:41:38 +0000