haddock 2.2.2 → 2.4.0
raw patch · 24 files changed
+1065/−487 lines, 24 filesdep +Cabaldep ~ghc
Dependencies added: Cabal
Dependency ranges changed: ghc
Files
- CHANGES +30/−0
- doc/haddock.xml +11/−1
- haddock.cabal +26/−6
- haddock.spec +1/−1
- html/frames.html +27/−0
- html/haddock-util.js +6/−0
- html/haddock.css +30/−0
- src/Haddock/Backends/DevHelp.hs +5/−3
- src/Haddock/Backends/Hoogle.hs +32/−22
- src/Haddock/Backends/Html.hs +184/−76
- src/Haddock/DocName.hs +8/−11
- src/Haddock/Exception.hs +9/−1
- src/Haddock/GHC.hs +35/−13
- src/Haddock/GHC/Typecheck.hs +2/−32
- src/Haddock/GHC/Utils.hs +14/−3
- src/Haddock/Interface.hs +128/−30
- src/Haddock/Interface/AttachInstances.hs +3/−5
- src/Haddock/Interface/Create.hs +87/−115
- src/Haddock/Interface/Rename.hs +26/−14
- src/Haddock/InterfaceFile.hs +202/−74
- src/Haddock/ModuleTree.hs +5/−1
- src/Haddock/Types.hs +26/−23
- src/Haddock/Utils.hs +45/−20
- src/Main.hs +123/−36
CHANGES view
@@ -1,6 +1,36 @@+Changed in version 2.4.0:++ * Add framed view of the HTML documentation++ * Build with GHC 6.8.2 and 6.8.3 again++ * Support images in documentation comments again++ * Small improvements to the Hoogle output++ * A few bugs has been fixed++-----------------------------------------------------------------------------++Changed in version 2.3.0:++ * Support for GHC 6.10.1++ * Slightly improved space usage++ * Fix a bug that made hidden modules show up in the contents & index pages++ * Fix a bug that made Haddock load modules twice++ * Improvements to the Hoogle output++-----------------------------------------------------------------------------+ Changed in version 2.2.2: * Relax version dependency on ghc-paths++----------------------------------------------------------------------------- Changes in version 2.2.1:
doc/haddock.xml view
@@ -16,7 +16,7 @@ <holder>Simon Marlow</holder> </copyright> <abstract>- <para>This document describes Haddock version 2.2.2, a Haskell+ <para>This document describes Haddock version 2.4.0, a Haskell documentation tool.</para> </abstract> </bookinfo>@@ -219,6 +219,16 @@ <para>The modules should <emphasis>not</emphasis> be mutually recursive, as Haddock don't like swimming in circles.</para>++ <para>You must also specify an option for the output format.+ Currently only the <option>-h</option> option for HTML and the+ <option>--hoogle</option> option for outputting Hoogle data are+ functional.</para>++ <para>The packaging+ tool <ulink url="http://www.haskell.org/ghc/docs/latest/html/Cabal/index.html">Cabal</ulink>+ has Haddock support, and is often used instead of invoking Haddock+ directly.</para> <para>The following options are available:</para>
haddock.cabal view
@@ -1,5 +1,5 @@ name: haddock-version: 2.2.2+version: 2.4.0 cabal-version: >= 1.2 license: BSD3 build-type: Simple@@ -56,24 +56,37 @@ html/haskell_icon.gif html/minus.gif html/plus.gif-+ html/frames.html +flag in-ghc-tree+ description: Are we in a GHC tree?+ default: False+ manual: True executable haddock build-depends: base, haskell98,- ghc == 6.8.2 || == 6.8.3,- ghc-paths,+ ghc >= 6.8.2 && < 6.13, filepath, directory, pretty, containers, array++ if flag(in-ghc-tree)+ cpp-options: -DIN_GHC_TREE+ extensions: ForeignFunctionInterface+ else+ build-depends: ghc-paths++ if impl(ghc >= 6.9)+ build-depends: Cabal >= 1.5+ main-is: Main.hs hs-source-dirs: src extensions: CPP, PatternGuards, DeriveDataTypeable,- PatternSignatures, MagicHash+ ScopedTypeVariables, MagicHash ghc-options: -funbox-strict-fields -O2 other-modules:@@ -113,9 +126,16 @@ library hs-source-dirs: src extensions: CPP, PatternGuards, DeriveDataTypeable,- PatternSignatures, MagicHash+ ScopedTypeVariables, MagicHash exposed-modules: Distribution.Haddock other-modules: Haddock.Types Haddock.InterfaceFile Haddock.Exception+ Haddock.Utils+ + -- Cabal doesn't define __GHC_PATCHLEVEL__+ if impl(ghc == 6.8.3)+ cpp-options: -D__GHC_PATCHLEVEL__=3+ if impl(ghc == 6.8.2)+ cpp-options: -D__GHC_PATCHLEVEL__=2
haddock.spec view
@@ -17,7 +17,7 @@ # version label of your release tarball. %define name haddock-%define version 2.2.2+%define version 2.4.0 %define release 1 Name: %{name}
+ html/frames.html view
@@ -0,0 +1,27 @@+<html> +<head> +<script type="text/javascript"><!-- +/* + + The synopsis frame needs to be updated using javascript, so we hide + it by default and only show it if javascript is enabled. + + TODO: provide some means to disable it. +*/ +function load() { + var d = document.getElementById("inner-fs"); + d.rows = "50%,50%"; +} +--></script> +<frameset id="outer-fs" cols="25%,75%" onload="load()"> + <frameset id="inner-fs" rows="100%,0%"> + + <frame src="index-frames.html" name="modules"> + <frame src="" name="synopsis"> + + </frameset> + <frame src="index.html" name="main"> + +</frameset> + +</html>
html/haddock-util.js view
@@ -131,3 +131,9 @@ return ""; // should never be reached } }++function setSynopsis(filename) {+ if (parent.window.synopsis) {+ parent.window.synopsis.location = filename;+ }+}
html/haddock.css view
@@ -4,6 +4,7 @@ background-color: #ffffff; color: #000000; font-family: sans-serif;+ padding: 0 0; } A:link { color: #0000e0; text-decoration: none }@@ -264,4 +265,33 @@ TD.botbar A:hover { background-color: #6060ff }++/* --------- Mini Synopsis for Frame View --------- */++.outer {+ margin: 0 0;+ padding: 0 0;+}++.mini-synopsis {+ padding: 0.25em 0.25em;+}++.mini-synopsis H1 { font-size: 130%; }+.mini-synopsis H2 { font-size: 110%; }+.mini-synopsis H3 { font-size: 100%; }+.mini-synopsis H1, .mini-synopsis H2, .mini-synopsis H3 {+ margin-top: 0.5em;+ margin-bottom: 0.25em;+ padding: 0 0;+}++.mini-synopsis H1 { border-bottom: 1px solid #ccc; }++.mini-topbar {+ font-size: 130%;+ background: #0077dd;+ padding: 0.25em;+}+
src/Haddock/Backends/DevHelp.hs view
@@ -7,12 +7,14 @@ module Haddock.Backends.DevHelp (ppDevHelpFile) where import Haddock.ModuleTree-import Haddock.Types+import Haddock.Types hiding (Doc) import Haddock.Utils -import Module ( moduleName, moduleNameString, Module, mkModule, mkModuleName )-import PackageConfig ( stringToPackageId )+import Module import Name ( Name, nameModule, getOccString, nameOccName )+#if __GLASGOW_HASKELL__ < 609+import PackageConfig (stringToPackageId)+#endif import Data.Maybe ( fromMaybe ) import qualified Data.Map as Map
src/Haddock/Backends/Hoogle.hs view
@@ -16,7 +16,7 @@ import Haddock.GHC.Utils import Haddock.Types import Haddock.Utils-import GHC hiding ((<.>))+import GHC import SrcLoc import Outputable @@ -33,10 +33,11 @@ ,""] -ppHoogle :: String -> String -> [Interface] -> FilePath -> IO ()-ppHoogle package version ifaces odir = do- let filename = package <.> "txt"+ppHoogle :: String -> String -> String -> Maybe (HsDoc RdrName) -> [Interface] -> FilePath -> IO ()+ppHoogle package version synopsis prologue ifaces odir = do+ let filename = package ++ ".txt" contents = prefix +++ docWith (drop 2 $ dropWhile (/= ':') synopsis) prologue ++ ["@package " ++ package] ++ ["@version " ++ version | version /= ""] ++ concat [ppModule i | i <- ifaces, OptHide `notElem` ifaceOptions i]@@ -46,15 +47,8 @@ ppModule :: Interface -> [String] ppModule iface = "" : doc (ifaceDoc iface) ++ ["module " ++ moduleString (ifaceMod iface)] ++- concatMap ppExport exported +++ concatMap ppExport (ifaceExportItems iface) ++ concatMap ppInstance (ifaceInstances iface)- where- locals = Set.fromList $ ifaceLocals iface- exported = [i | i@(ExportDecl{expItemDecl=decl}) <- ifaceExportItems iface- , isLocal (unLoc decl)]- isLocal decl- | Just name <- getMainDeclBinder decl = name `Set.member` locals- | otherwise = False ---------------------------------------------------------------------@@ -79,7 +73,7 @@ operator :: String -> String-operator (x:xs) | not (isAlphaNum x) && x `notElem` " ([{" = "(" ++ x:xs ++ ")"+operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = "(" ++ x:xs ++ ")" operator x = x @@ -87,10 +81,11 @@ -- How to print each export ppExport :: ExportItem Name -> [String]-ppExport (ExportDecl decl dc _) = doc dc ++ f (unL decl)+ppExport (ExportDecl decl dc _ _) = doc dc ++ f (unL decl) where f (TyClD d@TyData{}) = ppData d f (TyClD d@ClassDecl{}) = ppClass d+ f (TyClD d@TySynonym{}) = ppSynonym d f (ForD (ForeignImport name typ _)) = ppSig $ TypeSig name typ f (ForD (ForeignExport name typ _)) = ppSig $ TypeSig name typ f (SigD sig) = ppSig sig@@ -99,14 +94,22 @@ ppSig :: Sig Name -> [String]-ppSig (TypeSig name sig) = [operator (out name) ++ " :: " ++ out sig]+ppSig (TypeSig name sig) = [operator (out name) ++ " :: " ++ out typ]+ where+ typ = case unL sig of+ HsForAllTy Explicit a b c -> HsForAllTy Implicit a b c+ x -> x ppSig _ = [] +ppSynonym :: TyClDecl Name -> [String]+ppSynonym x = [out x]++ -- note: does not yet output documentation for class methods ppClass :: TyClDecl Name -> [String] ppClass x = out x{tcdSigs=[]} :- map (out . addContext . unL) (tcdSigs x)+ concatMap (ppSig . addContext . unL) (tcdSigs x) where addContext (TypeSig name (L l sig)) = TypeSig name (L l $ f sig) f (HsForAllTy a b con d) = HsForAllTy a b (reL $ context : unL con) d@@ -156,14 +159,20 @@ --------------------------------------------------------------------- -- DOCUMENTATION -ldoc :: Maybe (LHsDoc Name) -> [String]+ldoc :: Outputable o => Maybe (LHsDoc o) -> [String] ldoc = doc . liftM unL -doc :: Maybe (HsDoc Name) -> [String]-doc Nothing = []-doc (Just d) = "" : zipWith (++) ("-- | " : repeat "-- ") (showTags $ markup markupTag d)+doc :: Outputable o => Maybe (HsDoc o) -> [String]+doc = docWith "" +docWith :: Outputable o => String -> Maybe (HsDoc o) -> [String]+docWith [] Nothing = []+docWith header d = ("":) $ zipWith (++) ("-- | " : repeat "-- ") $+ [header | header /= ""] ++ ["" | header /= "" && isJust d] +++ maybe [] (showTags . markup markupTag) d++ data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String deriving Show @@ -179,7 +188,7 @@ -- or inlne for others (a,i,tt) -- entities (&,>,<) should always be appropriately escaped -markupTag :: DocMarkup Name [Tag]+markupTag :: Outputable o => DocMarkup o [Tag] markupTag = Markup { markupParagraph = box TagP, markupEmpty = str "",@@ -189,9 +198,10 @@ markupModule = box (TagInline "a") . str, markupEmphasis = box (TagInline "i"), markupMonospaced = box (TagInline "tt"),+ markupPic = const $ str " ", markupUnorderedList = box (TagL 'u'), markupOrderedList = box (TagL 'o'),- markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "b" a : Str " " : b),+ markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b), markupCodeBlock = box TagPre, markupURL = box (TagInline "a") . str, markupAName = const $ str ""
src/Haddock/Backends/Html.hs view
@@ -29,17 +29,23 @@ import Control.Exception ( bracket ) import Control.Monad ( when, unless ) import Data.Char ( isUpper, toUpper )-import Data.List ( sortBy )+import Data.List ( sortBy, groupBy ) import Data.Maybe import Foreign.Marshal.Alloc ( allocaBytes ) import System.IO ( IOMode(..), hClose, hGetBuf, hPutBuf, openFile ) import Data.Map ( Map ) import qualified Data.Map as Map hiding ( Map )+import Data.Function+import Data.Ord ( comparing ) +#if __GLASGOW_HASKELL__ >= 609+import GHC hiding ( NoLink, moduleInfo )+#else import GHC hiding ( NoLink )+#endif import Name import Module-import PackageConfig ( stringToPackageId )+import PackageConfig import RdrName hiding ( Qual ) import SrcLoc import FastString ( unpackFS )@@ -72,7 +78,6 @@ let visible_ifaces = filter visible ifaces visible i = OptHide `notElem` ifaceOptions 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@@ -142,7 +147,7 @@ copyLibFile f = do copyFile (pathJoin [libhtmldir, f]) (pathJoin [odir, f]) copyFile css_file css_destination- mapM_ copyLibFile [ iconFile, plusFile, minusFile, jsFile ]+ mapM_ copyLibFile [ iconFile, plusFile, minusFile, jsFile, framesFile ] footer :: HtmlTable footer = @@ -327,6 +332,9 @@ footer ) writeFile (pathJoin [odir, contentsHtmlFile]) (renderHtml html)++ -- XXX: think of a better place for this?+ ppHtmlContentsFrame odir doctitle ifaces -- Generate contents page for Html Help if requested case maybe_html_help_format of@@ -406,9 +414,40 @@ (u,id') = mkNode (s:ss) x (depth+1) id -- The URL for source and wiki links, and the current module-type LinksInfo = (SourceURLs, WikiURLs, Interface)+type LinksInfo = (SourceURLs, WikiURLs) +-- | Turn a module tree into a flat list of full module names. E.g.,+-- @+-- A+-- +-B+-- +-C+-- @+-- becomes+-- @["A", "A.B", "A.B.C"]@+flatModuleTree :: [InstalledInterface] -> [Html]+flatModuleTree ifaces =+ map (uncurry ppModule' . head)+ . groupBy ((==) `on` fst)+ . sortBy (comparing fst)+ $ mods+ where+ mods = [ (moduleString mod, mod) | mod <- map instMod ifaces ]+ ppModule' txt mod =+ anchor ! [href ((moduleHtmlFile mod)), target mainFrameName]+ << toHtml txt +ppHtmlContentsFrame odir doctitle ifaces = do+ let mods = flatModuleTree ifaces+ html =+ header+ (documentCharacterEncoding ++++ thetitle (toHtml doctitle) ++++ styleSheet ++++ (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) ++++ body << vanillaTable << p << (+ foldr (+++) noHtml (map (+++br) mods))+ writeFile (pathJoin [odir, frameIndexHtmlFile]) (renderHtml html)+ -- --------------------------------------------------------------------------- -- Generate the index @@ -530,7 +569,12 @@ header (documentCharacterEncoding +++ thetitle (toHtml mdl) +++ styleSheet +++- (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) ++++ (script ! [src jsFile, thetype "text/javascript"] $ noHtml) ++++ (script ! [thetype "text/javascript"]+ -- XXX: quoting errors possible?+ << Html [HtmlString ("window.onload = function () {setSynopsis(\"mini_" + ++ moduleHtmlFile mod ++ "\")};")])+ ) +++ body << vanillaTable << ( pageHeader mdl iface doctitle maybe_source_url maybe_wiki_url@@ -539,7 +583,22 @@ footer ) writeFile (pathJoin [odir, moduleHtmlFile mod]) (renderHtml html)+ ppHtmlModuleMiniSynopsis odir doctitle iface +ppHtmlModuleMiniSynopsis :: FilePath -> String -> Interface -> IO ()+ppHtmlModuleMiniSynopsis odir _doctitle iface = do+ let mod = ifaceMod iface+ html =+ header+ (documentCharacterEncoding ++++ thetitle (toHtml $ moduleString mod) ++++ styleSheet ++++ (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) ++++ body << thediv ! [ theclass "outer" ] << (+ (thediv ! [theclass "mini-topbar"]+ << toHtml (moduleString mod)) ++++ miniSynopsis mod iface)+ writeFile (pathJoin [odir, "mini_" ++ moduleHtmlFile mod]) (renderHtml html) ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> HtmlTable ifaceToHtml maybe_source_url maybe_wiki_url iface@@ -549,7 +608,7 @@ exports = numberSectionHeadings (ifaceRnExportItems iface) - has_doc (ExportDecl _ doc _) = isJust doc+ has_doc (ExportDecl _ doc _ _) = isJust doc has_doc (ExportNoDecl _ _ _) = False has_doc (ExportModule _) = False has_doc _ = True@@ -586,9 +645,55 @@ _ -> tda [ theclass "section1" ] << toHtml "Documentation" bdy = map (processExport False linksInfo docMap) exports- linksInfo = (maybe_source_url, maybe_wiki_url, iface)+ linksInfo = (maybe_source_url, maybe_wiki_url) +miniSynopsis :: Module -> Interface -> Html+miniSynopsis mod iface =+ thediv ! [ theclass "mini-synopsis" ]+ << hsep (map (processForMiniSynopsis mod) $ exports) + where+ exports = numberSectionHeadings (ifaceRnExportItems iface)++processForMiniSynopsis :: Module -> ExportItem DocName -> Html+processForMiniSynopsis mod (ExportDecl (L _loc decl0) _doc _ _insts) =+ thediv ! [theclass "decl" ] <<+ case decl0 of+ TyClD d@(TyFamily{}) -> ppTyFamHeader True False d+ TyClD d@(TyData{tcdTyPats = ps})+ | Nothing <- ps -> keyword "data" <++> ppTyClBinderWithVarsMini mod d+ | Just _ <- ps -> keyword "data" <++> keyword "instance"+ <++> ppTyClBinderWithVarsMini mod d+ TyClD d@(TySynonym{tcdTyPats = ps})+ | Nothing <- ps -> keyword "type" <++> ppTyClBinderWithVarsMini mod d+ | Just _ <- ps -> keyword "type" <++> keyword "instance"+ <++> ppTyClBinderWithVarsMini mod d+ TyClD d@(ClassDecl {}) ->+ keyword "class" <++> ppTyClBinderWithVarsMini mod d+ SigD (TypeSig (L _ n) (L _ t)) ->+ let nm = docNameOcc n+ in ppNameMini mod nm+ _ -> noHtml+processForMiniSynopsis mod (ExportGroup lvl _id txt) =+ let heading | lvl == 1 = h1+ | lvl == 2 = h2+ | lvl >= 3 = h3+ in heading << docToHtml txt+processForMiniSynopsis _ _ = noHtml++ppNameMini :: Module -> OccName -> Html+ppNameMini mod nm =+ anchor ! [ href ( moduleHtmlFile mod ++ "#"+ ++ (escapeStr (anchorNameStr nm)))+ , target mainFrameName ]+ << ppBinder' nm++ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html+ppTyClBinderWithVarsMini mod decl =+ let n = unLoc $ tcdLName decl+ ns = tyvarNames $ tcdTyVars decl+ in ppTypeApp n ns (ppNameMini mod . docNameOcc) ppTyName+ ppModuleContents :: [ExportItem DocName] -> Maybe HtmlTable ppModuleContents exports | length sections == 0 = Nothing@@ -626,8 +731,8 @@ processExport :: Bool -> LinksInfo -> DocMap -> (ExportItem DocName) -> HtmlTable processExport _ _ _ (ExportGroup lev id0 doc) = ppDocGroup lev (namedAnchor id0 << docToHtml doc)-processExport summary links docMap (ExportDecl decl doc insts)- = ppDecl summary links decl doc insts docMap+processExport summary links docMap (ExportDecl decl doc subdocs insts)+ = ppDecl summary links decl doc insts docMap subdocs processExport summmary _ _ (ExportNoDecl _ y []) = declBox (ppDocName y) processExport summmary _ _ (ExportNoDecl _ y subs)@@ -649,16 +754,17 @@ | lev == 3 = tda [ theclass "section3" ] << doc | otherwise = tda [ theclass "section4" ] << doc -declWithDoc :: Bool -> LinksInfo -> SrcSpan -> Name -> Maybe (HsDoc DocName) -> Html -> HtmlTable+declWithDoc :: Bool -> LinksInfo -> SrcSpan -> DocName -> 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) +-- TODO: use DeclInfo DocName or something ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> - Maybe (HsDoc DocName) -> [InstHead DocName] -> DocMap -> HtmlTable-ppDecl summ links (L loc decl) mbDoc instances docMap = case decl of+ Maybe (HsDoc DocName) -> [InstHead DocName] -> DocMap -> [(DocName, HsDoc DocName)] -> HtmlTable+ppDecl summ links (L loc decl) mbDoc instances docMap subdocs = case decl of TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d TyClD d@(TyData {}) | Nothing <- tcdTyPats d -> ppDataDecl summ links instances loc mbDoc d@@ -666,24 +772,24 @@ TyClD d@(TySynonym {}) | Nothing <- tcdTyPats d -> ppTySyn summ links loc mbDoc d | Just _ <- tcdTyPats d -> ppTyInst summ False links loc mbDoc d- TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc docMap d- SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig summ links loc mbDoc (docNameOrig n) t+ TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc docMap subdocs d+ SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig summ links loc mbDoc n t ForD d -> ppFor summ links loc mbDoc d InstD d -> Html.emptyTable ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) ->- Name -> HsType DocName -> HtmlTable-ppFunSig summary links loc mbDoc name typ =- ppTypeOrFunSig summary links loc name typ mbDoc - (ppTypeSig summary (nameOccName name) typ, - ppBinder False (nameOccName name), dcolon)-+ DocName -> HsType DocName -> HtmlTable+ppFunSig summary links loc mbDoc docname typ =+ ppTypeOrFunSig summary links loc docname typ mbDoc + (ppTypeSig summary occname typ, ppBinder False occname, dcolon)+ where+ occname = nameOccName . docNameOrig $ docname -ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> Name -> HsType DocName ->+ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> DocName -> HsType DocName -> Maybe (HsDoc DocName) -> (Html, Html, Html) -> HtmlTable-ppTypeOrFunSig summary links loc name typ doc (pref1, pref2, sep)- | summary || noArgDocs typ = declWithDoc summary links loc name doc pref1- | otherwise = topDeclBox links loc name pref2 </>+ppTypeOrFunSig summary links loc docname typ doc (pref1, pref2, sep)+ | summary || noArgDocs typ = declWithDoc summary links loc docname doc pref1+ | otherwise = topDeclBox links loc docname pref2 </> (tda [theclass "body"] << vanillaTable << ( do_args sep typ </> (case doc of@@ -728,17 +834,16 @@ where f x = docNameOrig . hsTyVarName . unLoc $ x ppFor summary links loc mbDoc (ForeignImport (L _ name) (L _ typ) _)- = ppFunSig summary links loc mbDoc (docNameOrig name) typ+ = ppFunSig summary links loc mbDoc name typ ppFor _ _ _ _ _ = error "ppFor" -- we skip type patterns for now ppTySyn summary links loc mbDoc (TySynonym (L _ name) ltyvars _ ltype) - = ppTypeOrFunSig summary links loc n (unLoc ltype) mbDoc + = ppTypeOrFunSig summary links loc name (unLoc ltype) mbDoc (full, hdr, spaceHtml +++ equals) where hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars) full = hdr <+> equals <+> ppLType ltype- n = docNameOrig name occ = docNameOcc name @@ -782,7 +887,7 @@ TyClDecl DocName -> HtmlTable ppTyFam summary associated links loc mbDoc decl - | summary = declWithDoc summary links loc name mbDoc + | summary = declWithDoc summary links loc docname mbDoc (ppTyFamHeader True associated decl) | associated, isJust mbDoc = header </> bodyBox << doc @@ -793,13 +898,13 @@ | otherwise = header </> bodyBox << instancesBit where- name = docNameOrig . tcdName $ decl+ docname = tcdName decl - header = topDeclBox links loc name (ppTyFamHeader summary associated decl)+ header = topDeclBox links loc docname (ppTyFamHeader summary associated decl) doc = ndocBox . docToHtml . fromJust $ mbDoc - instId = collapseId name+ instId = collapseId (docNameOrig docname) instancesBit = instHdr instId </> tda [theclass "body"] << @@ -838,16 +943,16 @@ TyClDecl DocName -> HtmlTable ppTyInst summary associated links loc mbDoc decl - | summary = declWithDoc summary links loc name mbDoc+ | summary = declWithDoc summary links loc docname mbDoc (ppTyInstHeader True associated decl) | isJust mbDoc = header </> bodyBox << doc | otherwise = header where- name = docNameOrig . tcdName $ decl+ docname = tcdName decl - header = topDeclBox links loc name (ppTyInstHeader summary associated decl)+ header = topDeclBox links loc docname (ppTyInstHeader summary associated decl) doc = case mbDoc of Just d -> ndocBox (docToHtml d)@@ -869,13 +974,11 @@ -------------------------------------------------------------------------------- -ppAssocType :: Bool -> LinksInfo -> DocMap -> LTyClDecl DocName -> HtmlTable-ppAssocType summ links docMap (L loc decl) = +ppAssocType :: Bool -> LinksInfo -> Maybe (HsDoc DocName) -> LTyClDecl DocName -> HtmlTable+ppAssocType summ links doc (L loc decl) = case decl of TyFamily {} -> ppTyFam summ True links loc doc decl TySynonym {} -> ppTySyn summ links loc doc decl- where- doc = Map.lookup (docNameOrig $ tcdName decl) docMap --------------------------------------------------------------------------------@@ -967,8 +1070,8 @@ fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> toHtml "->" <+> hsep (map ppDocName vars2) -ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> DocMap -> HtmlTable-ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc docMap = +ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, HsDoc DocName)] -> HtmlTable+ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc subdocs = if null sigs && null ats then (if summary then declBox else topDeclBox links loc nm) hdr else (if summary then declBox else topDeclBox links loc nm) (hdr <+> keyword "where")@@ -977,33 +1080,33 @@ bodyBox << aboves (- map (ppAssocType summary links docMap) ats ++-- [ ppFunSig summary links loc mbDoc n typ- | L _ (TypeSig (L _ fname) (L _ typ)) <- sigs- , let n = docNameOrig fname, let mbDoc = Map.lookup n docMap ] + [ ppAssocType summary links doc at | at <- ats+ , let doc = lookup (tcdName $ unL at) subdocs ] ++ + [ ppFunSig summary links loc doc n typ+ | L _ (TypeSig (L _ n) (L _ typ)) <- sigs+ , let doc = lookup n subdocs ] ) ) where hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds- nm = docNameOrig . unLoc $ lname+ nm = unLoc lname ppClassDecl :: Bool -> LinksInfo -> [InstHead DocName] -> SrcSpan ->- Maybe (HsDoc DocName) -> DocMap -> TyClDecl DocName -> + Maybe (HsDoc DocName) -> DocMap -> [(DocName, HsDoc DocName)] -> TyClDecl DocName -> HtmlTable-ppClassDecl summary links instances loc mbDoc docMap+ppClassDecl summary links instances loc mbDoc docMap subdocs decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _)- | summary = ppShortClassDecl summary links decl loc docMap+ | summary = ppShortClassDecl summary links decl loc subdocs | otherwise = classheader </> bodyBox << (classdoc </> body </> instancesBit) where classheader | null lsigs = topDeclBox links loc nm hdr | otherwise = topDeclBox links loc nm (hdr <+> keyword "where") - nm = docNameOrig . unLoc $ tcdLName decl+ nm = unLoc $ tcdLName decl ctxt = unLoc lctxt hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds@@ -1019,13 +1122,14 @@ s8 </> methHdr </> bodyBox << methodTable methodTable =- abovesSep s8 [ ppFunSig summary links loc doc (docNameOrig n) typ+ abovesSep s8 [ ppFunSig summary links loc doc n typ | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs- , let doc = Map.lookup (docNameOrig n) docMap ]+ , let doc = lookup n subdocs ] - atTable = abovesSep s8 $ map (ppAssocType summary links docMap) ats+ atTable = abovesSep s8 $ [ ppAssocType summary links doc at | at <- ats+ , let doc = lookup (tcdName $ unL at) subdocs ] - instId = collapseId nm+ instId = collapseId (docNameOrig nm) instancesBit | null instances = Html.emptyTable | otherwise @@ -1070,14 +1174,14 @@ where dataHeader = - (if summary then declBox else topDeclBox links loc name)+ (if summary then declBox else topDeclBox links loc docname) ((ppDataHeader summary dataDecl) <+> case resTy of ResTyGADT _ -> keyword "where"; _ -> empty) doConstr c con = declBox (toHtml [c] <+> ppShortConstr summary (unLoc con)) doGADTConstr con = declBox (ppShortConstr summary (unLoc con)) - name = docNameOrig . unLoc . tcdLName $ dataDecl+ docname = unLoc . tcdLName $ dataDecl context = unLoc (tcdCtxt dataDecl) newOrData = tcdND dataDecl tyVars = tyvarNames (tcdTyVars dataDecl)@@ -1089,7 +1193,7 @@ SrcSpan -> Maybe (HsDoc DocName) -> TyClDecl DocName -> HtmlTable ppDataDecl summary links instances loc mbDoc dataDecl - | summary = declWithDoc summary links loc name mbDoc + | summary = declWithDoc summary links loc docname mbDoc (ppShortDataDecl summary links loc mbDoc dataDecl) | otherwise@@ -1102,7 +1206,7 @@ where- name = docNameOrig . unLoc . tcdLName $ dataDecl+ docname = unLoc . tcdLName $ dataDecl context = unLoc (tcdCtxt dataDecl) newOrData = tcdND dataDecl tyVars = tyvarNames (tcdTyVars dataDecl)@@ -1110,7 +1214,7 @@ cons = tcdCons dataDecl resTy = (con_res . unLoc . head) cons - header = topDeclBox links loc name (ppDataHeader summary dataDecl+ header = topDeclBox links loc docname (ppDataHeader summary dataDecl <+> whereBit) whereBit @@ -1134,7 +1238,7 @@ aboves (map ppSideBySideConstr cons) ) - instId = collapseId name+ instId = collapseId (docNameOrig docname) instancesBit | null instances = Html.emptyTable@@ -1492,6 +1596,7 @@ markupEmphasis = emphasize . toHtml, markupMonospaced = tt . toHtml, markupUnorderedList = ulist . concatHtml . map (li <<),+ markupPic = \path -> image ! [src path], markupOrderedList = olist . concatHtml . map (li <<), markupDefList = dlist . concatHtml . map markupDef, markupCodeBlock = pre,@@ -1538,10 +1643,13 @@ hsep [] = noHtml hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls -infixr 8 <+>+infixr 8 <+>, <++> (<+>) :: Html -> Html -> Html a <+> b = Html (getHtmlElements (toHtml a) ++ HtmlString " ": getHtmlElements (toHtml b)) +(<++>) :: Html -> Html -> Html+a <++> b = a +++ spaceHtml +++ b+ keyword :: String -> Html keyword s = thespan ! [theclass "keyword"] << toHtml s @@ -1600,9 +1708,9 @@ -- a box for top level documented names -- it adds a source and wiki link at the right hand side of the box-topDeclBox :: LinksInfo -> SrcSpan -> Name -> Html -> HtmlTable-topDeclBox ((_,_,Nothing), (_,_,Nothing), _) _ _ html = declBox html-topDeclBox ((_,_,maybe_source_url), (_,_,maybe_wiki_url), iface)+topDeclBox :: LinksInfo -> SrcSpan -> DocName -> Html -> HtmlTable+topDeclBox ((_,_,Nothing), (_,_,Nothing)) _ _ html = declBox html+topDeclBox ((_,_,maybe_source_url), (_,_,maybe_wiki_url)) loc name html = tda [theclass "topdecl"] << ( table ! [theclass "declbar"] <<@@ -1615,26 +1723,26 @@ Nothing -> Html.emptyTable Just url -> tda [theclass "declbut"] << let url' = spliceURL (Just fname) (Just origMod)- (Just name) (Just loc) url+ (Just n) (Just loc) url in anchor ! [href url'] << toHtml "Source" - -- for source links, we want to point to the original module,- -- because only that will have the source.- origMod = case Map.lookup (nameOccName name) (ifaceEnv iface) of- Just n -> case nameModule_maybe n of- Just m -> m- Nothing -> mod- _ -> error "This shouldn't happen (topDeclBox)"- wikiLink = case maybe_wiki_url of Nothing -> Html.emptyTable Just url -> tda [theclass "declbut"] << let url' = spliceURL (Just fname) (Just mod)- (Just name) (Just loc) url+ (Just n) (Just loc) url in anchor ! [href url'] << toHtml "Comments" - mod = ifaceMod iface+ -- For source links, we want to point to the original module,+ -- because only that will have the source. + -- TODO: do something about type instances. They will point to+ -- the module defining the type family, which is wrong.+ origMod = nameModule n++ -- Name must be documented, otherwise we wouldn't get here+ Documented n mod = name+ fname = unpackFS (srcSpanFile loc)
src/Haddock/DocName.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_HADDOCK hide #-}+ -- -- Haddock - A Haskell Documentation Tool --@@ -5,22 +7,16 @@ -- -{-# OPTIONS_HADDOCK hide #-}-- module Haddock.DocName where -import Haddock.GHC.Utils- import GHC-import OccName import Name import Binary-import Outputable data DocName = Documented Name Module | Undocumented Name+ deriving Eq docNameOcc :: DocName -> OccName@@ -33,10 +29,10 @@ instance Binary DocName where- put_ bh (Documented name mod) = do+ put_ bh (Documented name modu) = do putByte bh 0 put_ bh name- put_ bh mod+ put_ bh modu put_ bh (Undocumented name) = do putByte bh 1 put_ bh name@@ -46,8 +42,9 @@ case h of 0 -> do name <- get bh- mod <- get bh- return (Documented name mod)+ modu <- get bh+ return (Documented name modu) 1 -> do name <- get bh return (Undocumented name)+ _ -> error "get DocName: Bad h"
src/Haddock/Exception.hs view
@@ -19,8 +19,16 @@ data HaddockException = HaddockException String deriving Typeable-throwE str = throwDyn (HaddockException str) instance Show HaddockException where show (HaddockException str) = str+++throwE :: String -> a+#if __GLASGOW_HASKELL__ >= 609+instance Exception HaddockException+throwE str = throw (HaddockException str)+#else+throwE str = throwDyn (HaddockException str)+#endif
src/Haddock/GHC.hs view
@@ -7,7 +7,6 @@ module Haddock.GHC ( startGhc,- loadPackages, module Haddock.GHC.Typecheck, module Haddock.GHC.Utils ) where@@ -26,24 +25,40 @@ import DynFlags hiding (Option) import Packages hiding (package) import StaticFlags+import SrcLoc -- | Start a GHC session with the -haddock flag set. Also turn off -- compilation and linking. +#if __GLASGOW_HASKELL__ >= 609 +startGhc :: String -> [String] -> (DynFlags -> Ghc a) -> IO a+startGhc libDir flags ghcActs = do+ -- TODO: handle warnings?+ (restFlags, _) <- parseStaticFlags (map noLoc flags)+ runGhc (Just libDir) $ do+ dynflags <- getSessionDynFlags+#else startGhc :: String -> [String] -> IO (Session, DynFlags) startGhc libDir flags = do restFlags <- parseStaticFlags flags- session <- newSession (Just libDir)- dynflags <- getSessionDynFlags session- let dynflags' = dopt_set dynflags Opt_Haddock- let dynflags'' = dynflags' {- hscTarget = HscAsm,- ghcMode = CompManager,- ghcLink = NoLink- }- dynflags''' <- parseGhcFlags dynflags'' restFlags flags- setSessionDynFlags session dynflags'''- return (session, dynflags''')+ session <- newSession (Just libDir)+ dynflags <- getSessionDynFlags session+ do+#endif+ let dynflags' = dopt_set dynflags Opt_Haddock+ let dynflags'' = dynflags' {+ hscTarget = HscAsm,+ ghcMode = CompManager,+ ghcLink = NoLink+ }+ dynflags''' <- parseGhcFlags dynflags'' restFlags flags+#if __GLASGOW_HASKELL__ >= 609 + setSessionDynFlags dynflags'''+ ghcActs dynflags'''+#else+ setSessionDynFlags session dynflags'''+ return (session, dynflags''')+#endif -- | Expose the list of packages to GHC. Then initialize GHC's package state@@ -51,6 +66,8 @@ -- list of packages. The matching packages might be newer versions of the -- supplied ones. For each matching package, return its InstalledPackageInfo. +-- Commented out, since it is unused and doesn't build with GHC >= 6.9+{- loadPackages :: Session -> [String] -> IO [InstalledPackageInfo] -- It would be better to try to get the "in scope" packages from GHC instead.@@ -86,11 +103,16 @@ where handleParse (Just pkg) = return (pkgName pkg) handleParse Nothing = throwE "Could not parse package identifier"-+-} -- | Try to parse dynamic GHC flags parseGhcFlags dynflags flags origFlags = do+ -- TODO: handle warnings?+#if __GLASGOW_HASKELL__ >= 609+ (dynflags', rest, _) <- parseDynamicFlags dynflags flags+#else (dynflags', rest) <- parseDynamicFlags dynflags flags+#endif if not (null rest) then throwE ("Couldn't parse GHC options: " ++ (unwords origFlags)) else return dynflags'
src/Haddock/GHC/Typecheck.hs view
@@ -6,7 +6,7 @@ module Haddock.GHC.Typecheck (- typecheckFiles + mkGhcModule ) where @@ -17,6 +17,7 @@ import Data.Maybe import Control.Monad import GHC+import HscTypes ( msHsFilePath ) import Digraph import BasicTypes import SrcLoc@@ -32,37 +33,6 @@ TypecheckedSource, ModuleInfo) ---- TODO: make it handle cleanup-typecheckFiles :: Session -> [FilePath] -> IO [GhcModule]-typecheckFiles session files = do -- -- load all argument files-- targets <- mapM (\f -> guessTarget f Nothing) files- setTargets session targets-- flag <- load session LoadAllTargets- when (failed flag) $ - throwE "Failed to load all needed modules"-- modgraph <- getModuleGraph session-- let mods = concatMap flattenSCC $ topSortModuleGraph False modgraph Nothing- getModFile = fromJust . ml_hs_file . ms_location- mods'= [ (ms_mod modsum, ms_hspp_opts modsum, getModFile modsum) |- modsum <- mods ]-- -- typecheck the argument modules-- ghcMods <- forM mods' $ \(mod, flags, file) -> do- mbMod <- checkModule session (moduleName mod) False- case mbMod of- Just (CheckedModule a (Just b) (Just c) (Just d) _) - -> return $ mkGhcModule (mod, file, (a,b,c,d)) flags- _ -> throwE ("Failed to check module: " ++ moduleString mod)-- return ghcMods -- | Dig out what we want from the typechecker output mkGhcModule :: CheckedMod -> DynFlags -> GhcModule
src/Haddock/GHC/Utils.hs view
@@ -16,12 +16,12 @@ import Data.Version import qualified Data.Map as Map -import GHC import HsSyn import SrcLoc import Outputable import Name import Packages+import Module unL :: Located a -> a@@ -37,14 +37,20 @@ -- return the name of the package, with version info+modulePackageString :: Module -> String modulePackageString = packageIdString . modulePackageId -- return the (name,version) of the package-modulePackageInfo mod = case unpackPackageId pkg of+modulePackageInfo :: Module -> (String, [Char])+modulePackageInfo modu = case unpackPackageId pkg of Nothing -> (packageIdString pkg, "")+#if __GLASGOW_HASKELL__ >= 609+ Just x -> (display $ pkgName x, showVersion (pkgVersion x))+#else Just x -> (pkgName x, showVersion (pkgVersion x))- where pkg = modulePackageId mod+#endif+ where pkg = modulePackageId modu mkModuleNoPackage :: String -> Module@@ -75,23 +81,28 @@ getMainDeclBinder _ = Nothing +isTyClD :: HsDecl a -> Bool isTyClD (TyClD _) = True isTyClD _ = False +isClassD :: HsDecl a -> Bool isClassD (TyClD d) = isClassDecl d isClassD _ = False +isDocD :: HsDecl a -> Bool isDocD (DocD _) = True isDocD _ = False +isInstD :: HsDecl a -> Bool isInstD (InstD _) = True isInstD (TyClD d) = isFamInstDecl d isInstD _ = False +declATs :: HsDecl a -> [a] declATs (TyClD d) | isClassDecl d = map (tcdName . unL) $ tcdATs d declATs _ = []
src/Haddock/Interface.hs view
@@ -21,52 +21,150 @@ import Haddock.Types import Haddock.Options import Haddock.GHC.Utils+import Haddock.GHC.Typecheck+import Haddock.Exception+import Haddock.Utils import qualified Data.Map as Map import Data.Map (Map) import Data.List import Control.Monad+import Control.Exception ( evaluate ) +import GHC import Name+import HscTypes ( msHsFilePath )+import Digraph+import BasicTypes+import SrcLoc --- | Turn a topologically sorted list of GhcModules into interfaces. Also--- return the home link environment created in the process, and any error--- messages.-createInterfaces :: [GhcModule] -> LinkEnv -> [Flag] -> ([Interface], LinkEnv, [ErrMsg])-createInterfaces modules externalLinks flags = (interfaces, homeLinks, messages)- where - ((interfaces, homeLinks), messages) = runWriter $ do+-- | Turn a topologically sorted list of module names/filenames into interfaces. Also+-- return the home link environment created in the process.+#if __GLASGOW_HASKELL__ >= 609+createInterfaces :: [String] -> LinkEnv -> [Flag] -> Ghc ([Interface], LinkEnv)+createInterfaces modules externalLinks flags = do+ -- part 1, create interfaces+ interfaces <- createInterfaces' modules flags+#else+createInterfaces :: Session -> [String] -> LinkEnv -> [Flag] -> IO ([Interface], LinkEnv)+createInterfaces session modules externalLinks flags = do+ -- part 1, create interfaces+ interfaces <- createInterfaces' session modules flags+#endif+ -- part 2, build link environment+ let homeLinks = buildHomeLinks interfaces+ links = homeLinks `Map.union` externalLinks+ allNames = Map.keys links - -- part 1, create the interfaces- interfaces <- createInterfaces' modules flags+ -- part 3, attach instances+ let interfaces' = attachInstances interfaces allNames - -- part 2, build the link environment- let homeLinks = buildHomeLinks interfaces- let links = homeLinks `Map.union` externalLinks- let allNames = Map.keys links+ -- part 4, rename interfaces+ let warnings = Flag_NoWarnings `notElem` flags+ let (interfaces'', msgs) = + runWriter $ mapM (renameInterface links warnings) interfaces'+ liftIO $ mapM_ putStrLn msgs - -- part 3, attach the instances- let interfaces' = attachInstances interfaces allNames- - -- part 3, rename the interfaces- let warnings = Flag_NoWarnings `notElem` flags- interfaces'' <- mapM (renameInterface links warnings) interfaces'+ return (interfaces'', homeLinks) - return (interfaces'', homeLinks)- -createInterfaces' :: [GhcModule] -> [Flag] -> ErrMsgM [Interface]+#if __GLASGOW_HASKELL__ >= 609+createInterfaces' :: [String] -> [Flag] -> Ghc [Interface] createInterfaces' modules flags = do- resultMap <- foldM addInterface Map.empty modules- return (Map.elems resultMap)- where- addInterface :: ModuleMap -> GhcModule -> ErrMsgM ModuleMap- addInterface map mod = do- interface <- createInterface mod flags map- return $ Map.insert (ifaceMod interface) interface map+ targets <- mapM (\f -> guessTarget f Nothing) modules+ setTargets targets+ modgraph <- depanal [] False+ let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph Nothing+ (ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do+ interface <- processModule modsum flags modMap+#else+createInterfaces' :: Session -> [String] -> [Flag] -> IO [Interface]+createInterfaces' session modules flags = do+ targets <- mapM (\f -> guessTarget f Nothing) modules+ setTargets session targets+ mbGraph <- depanal session [] False+ modgraph <- case mbGraph of+ Just graph -> return graph+ Nothing -> throwE "Failed to create dependecy graph"+ let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph Nothing+ (ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do+ interface <- processModule session modsum flags modMap+#endif+ return $ (interface : ifaces , Map.insert (ifaceMod interface) interface modMap)+ ) ([], Map.empty) orderedMods+ return (reverse ifaces) - +{- liftIO $ do+ putStrLn . ppModInfo $ ifaceInfo interface+ putStrLn . show $ fmap pretty (ifaceDoc interface)+ print (ifaceOptions interface)+ mapM (putStrLn . pretty . fst) (Map.elems . ifaceDeclMap $ interface)+ mapM (putStrLn . show . fmap pretty . snd) (Map.elems . ifaceDeclMap $ interface)+ mapM (putStrLn . ppExportItem) (ifaceExportItems interface)+ mapM (putStrLn . pretty) (ifaceLocals interface)+ mapM (putStrLn . pretty) (ifaceExports interface)+ mapM (putStrLn . pretty) (ifaceVisibleExports interface)+ mapM (putStrLn . pretty) (ifaceInstances interface)+ mapM (\(a,b) -> putStrLn $ pretty a ++ pretty b) (Map.toList $ ifaceSubMap interface)+ mapM (putStrLn . pretty) (ifaceInstances interface)-}++{-++ppInsts = concatMap ppInst ++ppInst (a,b,c) = concatMap pretty a ++ pretty b ++ concatMap pretty c +++ppExportItem (ExportDecl decl (Just doc) insts) = pretty decl ++ pretty doc ++ ppInsts insts+ppExportItem (ExportDecl decl Nothing insts) = pretty decl ++ ppInsts insts+ppExportItem (ExportNoDecl name name2 names) = pretty name ++ pretty name2 ++ pretty names+ppExportItem (ExportGroup level id doc) = show level ++ show id ++ pretty doc+ppExportItem (ExportDoc doc) = pretty doc+ppExportItem (ExportModule mod) = pretty mod+++ppModInfo (HaddockModInfo a b c d) = show (fmap pretty a) ++ show b ++ show c ++ show d +-}++#if __GLASGOW_HASKELL__ >= 609+processModule :: ModSummary -> [Flag] -> ModuleMap -> Ghc Interface+processModule modsum flags modMap = ++ let handleSrcErrors action = flip handleSourceError action $ \err -> do + printExceptionAndWarnings err+ throwE ("Failed to check module: " ++ moduleString (ms_mod modsum))++ in handleSrcErrors $ do+ let filename = msHsFilePath modsum+ let dynflags = ms_hspp_opts modsum+ tc_mod <- loadModule =<< typecheckModule =<< parseModule modsum+ let Just renamed_src = renamedSource tc_mod+ let ghcMod = mkGhcModule (ms_mod modsum,+ filename,+ (parsedSource tc_mod,+ renamed_src,+ typecheckedSource tc_mod,+ moduleInfo tc_mod))+ dynflags+ let (interface, msg) = runWriter $ createInterface ghcMod flags modMap+ liftIO $ mapM_ putStrLn msg+ liftIO $ evaluate interface+ return interface+#else+processModule :: Session -> ModSummary -> [Flag] -> ModuleMap -> IO Interface+processModule session modsum flags modMap = do+ let filename = msHsFilePath modsum+ mbMod <- checkAndLoadModule session modsum False+ ghcMod <- case mbMod of+ Just (CheckedModule a (Just b) (Just c) (Just d) _)+ -> return $ mkGhcModule (ms_mod modsum, filename, (a,b,c,d)) (ms_hspp_opts modsum)+ _ -> throwE ("Failed to check module: " ++ (moduleString $ ms_mod modsum))+ let (interface, msg) = runWriter $ createInterface ghcMod flags modMap+ mapM_ putStrLn msg+ return interface+#endif+ -- | Build a mapping which for each original name, points to the "best" -- place to link to in the documentation. For the definition of -- "best", we use "the module nearest the bottom of the dependency
src/Haddock/Interface/AttachInstances.hs view
@@ -43,9 +43,9 @@ where newItems = map attachExport (ifaceExportItems mod) - attachExport (ExportDecl decl@(L _ (TyClD d)) doc _)+ attachExport (ExportDecl decl@(L _ (TyClD d)) doc subs _) | isClassDecl d || isDataDecl d || isFamilyDecl d =- ExportDecl decl doc (case Map.lookup (tcdName d) instMap of+ ExportDecl decl doc subs (case Map.lookup (tcdName d) instMap of Nothing -> [] Just instheads -> instheads) attachExport export = export@@ -78,6 +78,7 @@ Just tycon <- nub (is_tcs inst) ] +-- TODO: should we support PredTy here? instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType]) instHead (_, _, cls, args) = (map argCount args, className cls, map simplify args)@@ -86,7 +87,6 @@ argCount (TyConApp _ ts) = length ts argCount (FunTy _ _ ) = 2 argCount (ForAllTy _ t) = argCount t- argCount (NoteTy _ t) = argCount t argCount _ = 0 simplify (ForAllTy _ t) = simplify t@@ -96,7 +96,6 @@ where (SimpleType s args) = simplify t1 simplify (TyVarTy v) = SimpleType (tyVarName v) [] simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts)- simplify (NoteTy _ t) = simplify t simplify _ = error "simplify" @@ -145,7 +144,6 @@ FunTy a b -> HsFunTy (toLHsType a) (toLHsType b) ForAllTy v t -> cvForAll [v] t PredTy p -> HsPredTy (toHsPred p) - NoteTy _ t -> toHsType t where tycon tc = HsTyVar (tyConName tc) app tc ts = foldl (\a b -> HsAppTy (noLoc a) (noLoc b)) tc (map toHsType ts)
src/Haddock/Interface/Create.hs view
@@ -53,24 +53,21 @@ let group = ghcGroup ghcMod exports = fmap (reverse . map unLoc) (ghcMbExports ghcMod) localNames = ghcDefinedNames ghcMod- subMap = mkSubMap group- decls = topDecls group- decls' = filterOutInstances decls- declMap = mkDeclMap decls'- famMap = Map.empty --mkFamMap decls'+ decls0 = declInfos . topDecls $ group+ decls = filterOutInstances decls0+ declMap = mkDeclMap decls ignoreExps = Flag_IgnoreAllExports `elem` flags exportedNames = ghcExportedNames ghcMod- origEnv = Map.fromList [ (nameOccName n, n) | n <- exportedNames ] instances = ghcInstances ghcMod - warnAboutFilteredDecls mod decls+ warnAboutFilteredDecls mod decls0 visibleNames <- mkVisibleNames mod modMap localNames (ghcNamesInScope ghcMod) - subMap exports opts declMap + exports opts declMap - exportItems <- mkExportItems modMap mod (ghcExportedNames ghcMod) decls' declMap- famMap subMap opts exports ignoreExps instances+ exportItems <- mkExportItems modMap mod (ghcExportedNames ghcMod) decls declMap+ opts exports ignoreExps instances -- prune the export list to just those declarations that have -- documentation, if the 'prune' option is on.@@ -88,10 +85,8 @@ ifaceOptions = opts, ifaceLocals = localNames, ifaceRnDocMap = Map.empty,- ifaceSubMap = subMap, ifaceExportItems = prunedExportItems, ifaceRnExportItems = [],- ifaceEnv = origEnv, ifaceExports = exportedNames, ifaceVisibleExports = visibleNames, ifaceDeclMap = declMap,@@ -130,54 +125,41 @@ -- Declarations -------------------------------------------------------------------------------- -type DeclWithDoc = (LHsDecl Name, Maybe (HsDoc Name)) ---- | A list of type or data instance declarations with an optional family--- declaration.-type Family = (Maybe DeclWithDoc, [DeclWithDoc])----- | Make a map from names to declarations with documentation. The map excludes--- all kinds of instance declarations (including type family instances) and--- documentation declarations.--- Subordinate names are mapped to the parent declaration, but with the doc--- for the subordinate declaration.-mkDeclMap :: [DeclWithDoc] -> Map Name DeclWithDoc-mkDeclMap decls = Map.fromList [ (n, (L loc d, doc)) | (L loc d, doc) <- decls - , (n, doc) <- (declName d, doc) : subordinates d- , not (isDocD d), not (isInstD d) ]+-- Make a map from names to 'DeclInfo's. Exclude declarations that don't+-- have names (instances and stand-alone documentation comments). Include+-- subordinate names, but map them to their parent declarations. +mkDeclMap :: [DeclInfo] -> Map Name DeclInfo+mkDeclMap decls = Map.fromList . concat $+ [ (declName d, (parent, doc, subs)) : subDecls+ | (parent@(L _ d), doc, subs) <- decls + , let subDecls = [ (n, (parent, doc', [])) | (n, doc') <- subs ]+ , not (isDocD d), not (isInstD d) ] --- | Group type family instances together. Include the family declaration--- if found.-{-mkFamMap :: [DeclWithDoc] -> Map Name Family-mkFamMap decls = - Map.fromList [ (tcdName $ ex $ head $ g, family g) | g <- groups ]- where- family g = first listToMaybe $ partition (isFamilyDecl . ex) g- groups = groupBy (comparing (tcdName . ex)) $ - filter (isTyClD . unLoc . fst) decls- ex ((L _ (TyClD d)), _) = d--}-+declInfos :: [(Decl, Maybe Doc)] -> [DeclInfo]+declInfos decls = [ (parent, doc, subordinates d)+ | (parent@(L _ d), doc) <- decls] subordinates (TyClD d) = classDataSubs d subordinates _ = [] -classDataSubs :: TyClDecl Name -> [(Name, Maybe (HsDoc Name))]+classDataSubs :: TyClDecl Name -> [(Name, Maybe Doc)] classDataSubs decl- | isClassDecl decl = classMeths- | isDataDecl decl = recordFields+ | isClassDecl decl = classSubs+ | isDataDecl decl = dataSubs | otherwise = [] where- classMeths = [ (declName d, doc) | (L _ d, doc) <- classDecls decl ]- recordFields = [ (unLoc lname, fmap unLoc doc) |- ConDeclField lname _ doc <- fields ]- cons = [ con | L _ con <- tcdCons decl ]- fields = concat [ fields | RecCon fields <- map con_details cons]+ classSubs = [ (declName d, doc) | (L _ d, doc) <- classDecls decl ]+ dataSubs = constrs ++ fields + where+ cons = map unL $ tcdCons decl+ constrs = [ (unL $ con_name c, fmap unL $ con_doc c) | c <- cons ]+ fields = [ (unL n, fmap unL doc)+ | RecCon flds <- map con_details cons+ , ConDeclField n _ doc <- flds ] -- All the sub declarations of a class (that we handle), ordered by@@ -201,16 +183,16 @@ -- | The top-level declarations of a module that we care about, -- ordered by source location, with documentation attached if it exists.-topDecls :: HsGroup Name -> [DeclWithDoc] +topDecls :: HsGroup Name -> [(Decl, Maybe Doc)] topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . declsFromGroup -filterOutInstances = filter (\(L _ d, _) -> not (isInstD d))+filterOutInstances = filter (\(L _ d, _, _) -> not (isInstD d)) -- | Take all declarations in an 'HsGroup' and convert them into a list of--- 'LHsDecl's-declsFromGroup :: HsGroup Name -> [LHsDecl Name]+-- 'Decl's+declsFromGroup :: HsGroup Name -> [Decl] -- TODO: actually take all declarations declsFromGroup group = decls hs_tyclds TyClD group ++@@ -234,7 +216,7 @@ warnAboutFilteredDecls mod decls = do let modStr = moduleString mod let typeInstances =- nub [ tcdName d | (L _ (TyClD d), _) <- decls, isFamInstDecl d ]+ nub [ tcdName d | (L _ (TyClD d), _, _) <- decls, isFamInstDecl d ] when (not $null typeInstances) $ tell $ nub [@@ -243,7 +225,7 @@ ++ "will be filtered out:\n " ++ (concat $ intersperse ", " $ map (occNameString . nameOccName) typeInstances) ] - let instances = nub [ pretty i | (L _ (InstD (InstDecl i _ _ ats)), _) <- decls+ let instances = nub [ pretty i | (L _ (InstD (InstDecl i _ _ ats)), _, _) <- decls , not (null ats) ] when (not $ null instances) $@@ -262,7 +244,7 @@ -- | Filter out declarations that we don't handle in Haddock-filterDecls :: [DeclWithDoc] -> [DeclWithDoc]+filterDecls :: [(Decl, Maybe Doc)] -> [(Decl, Maybe Doc)] filterDecls decls = filter (isHandled . unL . fst) decls where isHandled (ForD (ForeignImport {})) = True@@ -275,7 +257,7 @@ -- | Go through all class declarations and filter their sub-declarations-filterClasses :: [DeclWithDoc] -> [DeclWithDoc]+filterClasses :: [(Decl, Maybe Doc)] -> [(Decl, Maybe Doc)] filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x | x@(L loc d, doc) <- decls ] where@@ -284,19 +266,6 @@ ----------------------------------------------------------------------------------- Instances-----------------------------------------------------------------------------------{--matchingInsts :: Name -> [Instances] -> [Instances]-matchingInsts name instances = filter ((==) name . is_cls) instances---instToData :: Instance -> LHsDecl Name-instToData inst = TyData {--}---------------------------------------------------------------------------------- -- Collect docs -- -- To be able to attach the right Haddock comment to the right declaration,@@ -306,11 +275,11 @@ -- | Collect the docs and attach them to the right declaration-collectDocs :: [LHsDecl Name] -> [DeclWithDoc]+collectDocs :: [Decl] -> [(Decl, (Maybe Doc))] collectDocs decls = collect Nothing DocEmpty decls -collect :: Maybe (LHsDecl Name) -> HsDoc Name -> [LHsDecl Name] -> [DeclWithDoc]+collect :: Maybe Decl -> Doc -> [Decl] -> [(Decl, (Maybe Doc))] collect d doc_so_far [] = case d of Nothing -> []@@ -332,7 +301,7 @@ | otherwise -> finishedDoc d0 doc_so_far (collect (Just e) DocEmpty es) -finishedDoc :: LHsDecl Name -> HsDoc Name -> [DeclWithDoc] -> [DeclWithDoc]+finishedDoc :: Decl -> Doc -> [(Decl, (Maybe Doc))] -> [(Decl, (Maybe Doc))] finishedDoc d DocEmpty rest = (d, Nothing) : rest finishedDoc d doc rest | notDocDecl d = (d, Just doc) : rest where@@ -344,11 +313,6 @@ sameDecl d1 d2 = getLoc d1 == getLoc d2 -mkSubMap :: HsGroup Name -> Map Name [Name]-mkSubMap group = Map.fromList [ (name, subs) | L _ tycld <- hs_tyclds group,- let name:subs = map unLoc (tyClDeclNames tycld) ]-- {- attachATs :: [IE Name] -> ([IE Name], [Name]) attachATs exports = @@ -364,23 +328,21 @@ :: ModuleMap -> Module -- this module -> [Name] -- exported names (orig)- -> [DeclWithDoc]- -> Map Name DeclWithDoc -- maps local names to declarations- -> Map Name Family- -> Map Name [Name] -- sub-map for this module+ -> [DeclInfo]+ -> Map Name DeclInfo -- maps local names to declarations -> [DocOption] -> Maybe [IE Name] -> Bool -- --ignore-all-exports flag -> [Instance] -> ErrMsgM [ExportItem Name] -mkExportItems modMap this_mod exported_names decls declMap famMap sub_map+mkExportItems modMap this_mod exported_names decls declMap opts maybe_exps ignore_all_exports instances | isNothing maybe_exps || ignore_all_exports || OptIgnoreExports `elem` opts = everything_local_exported | Just specs <- maybe_exps = liftM concat $ mapM lookupExport specs where- instances = [ d | d@(L _ decl, _) <- decls, isInstD decl ]+ instances = [ d | d@(L _ decl, _, _) <- decls, isInstD decl ] everything_local_exported = -- everything exported return (fullContentsOfThisModule this_mod decls)@@ -401,7 +363,7 @@ lookupExport (IEGroup lev doc) = return [ ExportGroup lev "" doc ] lookupExport (IEDoc doc) = return [ ExportDoc doc ] lookupExport (IEDocNamed str) = do- r <- findNamedDoc str (map (unLoc . fst) decls)+ r <- findNamedDoc str [ unL d | (d,_,_) <- decls ] case r of Nothing -> return [] Just found -> return [ ExportDoc found ]@@ -411,16 +373,20 @@ -- temp hack: we filter out separately declared ATs, since we haven't decided how -- to handle them yet. We should really give an warning message also, and filter the -- name out in mkVisibleNames...- | Just (decl, maybeDoc) <- findDecl t, t `notElem` declATs (unL decl) =- return [ ExportDecl (restrictTo subs (extractDecl t mdl decl)) maybeDoc [] ]+ | Just x@(decl,_,_) <- findDecl t,+ t `notElem` declATs (unL decl) = return [ mkExportDecl t x ] | otherwise = return []- where - mdl = nameModule t- subs = filter (`elem` exported_names) all_subs- all_subs- | mdl == this_mod = Map.findWithDefault [] t sub_map- | otherwise = allSubsOfName modMap t ++ mkExportDecl :: Name -> DeclInfo -> ExportItem Name+ mkExportDecl n (decl, doc, subs) = decl'+ where+ decl' = ExportDecl (restrictTo subs' (extractDecl n mdl decl)) doc subdocs []+ mdl = nameModule n+ subs' = filter (`elem` exported_names) $ map fst subs+ subdocs = [ (n, doc) | (n, Just doc) <- subs ]++ fullContentsOf m | m == this_mod = return (fullContentsOfThisModule this_mod decls) | otherwise = @@ -431,9 +397,9 @@ | otherwise -> return [ ExportModule m ] Nothing -> return [] -- already emitted a warning in visibleNames - findDecl :: Name -> Maybe (LHsDecl Name, Maybe (HsDoc Name))+ findDecl :: Name -> Maybe DeclInfo findDecl n - | m == this_mod = Map.lookup n declMap+ | m == this_mod = Map.lookup n declMap | otherwise = case Map.lookup m modMap of Just iface -> Map.lookup n (ifaceDeclMap iface) Nothing -> Nothing@@ -441,11 +407,14 @@ m = nameModule n -fullContentsOfThisModule :: Module -> [(LHsDecl Name, Maybe (HsDoc Name))] -> [ExportItem Name]+fullContentsOfThisModule :: Module -> [DeclInfo] -> [ExportItem Name] fullContentsOfThisModule module_ decls = catMaybes (map mkExportItem decls) where- mkExportItem (L _ (DocD (DocGroup lev doc)), _) = Just $ ExportGroup lev "" doc- mkExportItem (decl, doc) = Just $ ExportDecl decl doc []+ mkExportItem (L _ (DocD (DocGroup lev doc)), _, _) = Just $ ExportGroup lev "" doc+ mkExportItem (L _ (DocD (DocCommentNamed _ doc)), _, _) = Just $ ExportDoc doc+ mkExportItem (decl, doc, subs) = Just $ ExportDecl decl doc subdocs []+ where subdocs = [ (n, doc) | (n, Just doc) <- subs ]+ -- mkExportItem _ = Nothing -- TODO: see if this is really needed @@ -453,7 +422,7 @@ -- it might be an individual record selector or a class method. In these -- cases we have to extract the required declaration (and somehow cobble -- together a type signature for it...)-extractDecl :: Name -> Module -> LHsDecl Name -> LHsDecl Name+extractDecl :: Name -> Module -> Decl -> Decl extractDecl name mdl decl | Just n <- getMainDeclBinder (unLoc decl), n == name = decl | otherwise = @@ -513,7 +482,7 @@ -- Pruning pruneExportItems :: [ExportItem Name] -> [ExportItem Name] pruneExportItems items = filter hasDoc items- where hasDoc (ExportDecl _ d _) = isJust d+ where hasDoc (ExportDecl _ d _ _) = isJust d hasDoc _ = True @@ -522,13 +491,12 @@ -> ModuleMap -> [Name] -> [Name]- -> Map Name [Name] -> Maybe [IE Name] -> [DocOption]- -> Map Name (LHsDecl Name, Maybe (HsDoc Name))+ -> Map Name DeclInfo -> ErrMsgM [Name] -mkVisibleNames mdl modMap localNames scope subMap maybeExps opts declMap +mkVisibleNames mdl modMap localNames scope maybeExps opts declMap -- if no export list, just return all local names | Nothing <- maybeExps = return (filter hasDecl localNames) | OptIgnoreExports `elem` opts = return localNames@@ -546,7 +514,7 @@ IEThingAbs t -> return [t] IEThingAll t -> return (t : all_subs) where- all_subs | nameModule t == mdl = Map.findWithDefault [] t subMap+ all_subs | nameModule t == mdl = subsOfName t declMap | otherwise = allSubsOfName modMap t IEThingWith t cs -> return (t : cs)@@ -573,23 +541,27 @@ -- | For a given entity, find all the names it "owns" (ie. all the -- constructors and field names of a tycon, or all the methods of a -- class).-allSubsOfName :: ModuleMap -> Name -> [Name]-allSubsOfName modMap name - | isExternalName name =- case Map.lookup (nameModule name) modMap of- Just iface -> Map.findWithDefault [] name (ifaceSubMap iface)- Nothing -> []- | otherwise = error $ "Main.allSubsOfName: unexpected unqual'd name"+allSubsOfName :: Map Module Interface -> Name -> [Name]+allSubsOfName ifaces name =+ case Map.lookup (nameModule name) ifaces of+ Just iface -> subsOfName name (ifaceDeclMap iface)+ Nothing -> [] --- Named documentation+subsOfName :: Name -> Map Name DeclInfo -> [Name]+subsOfName n declMap =+ case Map.lookup n declMap of+ Just (_, _, subs) -> map fst subs+ Nothing -> [] -findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe (HsDoc Name))++-- | Find a stand-alone documentation comment by its name+findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe Doc) findNamedDoc name decls = search decls- where+ where search [] = do- tell ["Cannot find documentation for: $" ++ name]- return Nothing+ tell ["Cannot find documentation for: $" ++ name]+ return Nothing search ((DocD (DocCommentNamed name' doc)):rest) | name == name' = return (Just doc) | otherwise = search rest
src/Haddock/Interface/Rename.hs view
@@ -38,7 +38,7 @@ let localEnv = foldl fn renamingEnv (ifaceVisibleExports mod) where fn env name = Map.insert name (ifaceMod mod) env - docMap = Map.map (\(_, doc) -> doc) $ ifaceDeclMap mod+ docMap = Map.map (\(_,x,_) -> x) (ifaceDeclMap mod) docs = [ (n, doc) | (n, Just doc) <- Map.toList docMap ] renameMapElem (k,d) = do d' <- renameDoc d; return (k, d') @@ -130,10 +130,6 @@ -------------------------------------------------------------------------------- -keep n = Undocumented n-keepL (L loc n) = L loc (Undocumented n)-- rename = lookupRn id renameL (L loc name) = return . L loc =<< rename name @@ -188,6 +184,7 @@ doc' <- renameDoc doc return (DocCodeBlock doc') DocURL str -> return (DocURL str) + DocPic str -> return (DocPic str) DocAName str -> return (DocAName str) @@ -340,12 +337,13 @@ 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 (keepL lname) expl ltyvars' lcontext' details' restype' mbldoc') + return (ConDecl lname' expl ltyvars' lcontext' details' restype' mbldoc') renameDetails (RecCon fields) = return . RecCon =<< mapM renameField fields renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps@@ -355,31 +353,38 @@ return (InfixCon a' b') renameField (ConDeclField name t doc) = do+ name' <- renameL name t' <- renameLType t doc' <- mapM renameLDoc doc- return (ConDeclField (keepL name) t' doc')+ return (ConDeclField name' t' doc') renameResType (ResTyH98) = return ResTyH98 renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t - renameLFunDep (L loc (xs, ys)) = return (L loc (map keep xs, map keep ys))+ renameLFunDep (L loc (xs, ys)) = do+ xs' <- mapM rename xs+ ys' <- mapM rename ys+ return (L loc (xs', ys')) renameLSig (L loc sig) = return . L loc =<< renameSig sig renameSig sig = case sig of - TypeSig (L loc name) ltype -> do + TypeSig lname ltype -> do + lname' <- renameL lname ltype' <- renameLType ltype- return (TypeSig (L loc (keep name)) ltype')+ return (TypeSig lname' ltype') -- we have filtered out all other kinds of signatures in Interface.Create renameForD (ForeignImport lname ltype x) = do+ lname' <- renameL lname ltype' <- renameLType ltype- return (ForeignImport (keepL lname) ltype' x)+ return (ForeignImport lname' ltype' x) renameForD (ForeignExport lname ltype x) = do+ lname' <- renameL lname ltype' <- renameLType ltype- return (ForeignExport (keepL lname) ltype' x)+ return (ForeignExport lname' ltype' x) renameInstD (InstDecl ltype _ _ lATs) = do@@ -394,11 +399,12 @@ ExportGroup lev id doc -> do doc' <- renameDoc doc return (ExportGroup lev id doc')- ExportDecl decl doc instances -> do+ ExportDecl decl doc subs instances -> do decl' <- renameLDecl decl doc' <- mapM renameDoc doc+ subs' <- mapM renameSub subs instances' <- mapM renameInstHead instances- return (ExportDecl decl' doc' instances')+ return (ExportDecl decl' doc' subs' instances') ExportNoDecl x y subs -> do y' <- lookupRn id y subs' <- mapM (lookupRn id) subs@@ -406,3 +412,9 @@ ExportDoc doc -> do doc' <- renameDoc doc return (ExportDoc doc')+++renameSub (n,doc) = do+ n' <- rename n+ doc' <- renameDoc doc+ return (n', doc')
src/Haddock/InterfaceFile.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+ -- -- Haddock - A Haskell Documentation Tool --@@ -7,14 +9,14 @@ module Haddock.InterfaceFile ( InterfaceFile(..),- readInterfaceFile,+ readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor, writeInterfaceFile ) where import Haddock.DocName () import Haddock.Types-import Haddock.Exception+import Haddock.Utils import Data.List import Data.Word@@ -32,11 +34,11 @@ import UniqFM import IfaceEnv import Module-import Packages import HscTypes import FastMutInt-import InstEnv import HsDoc+import FastString+import Unique data InterfaceFile = InterfaceFile {@@ -48,32 +50,64 @@ binaryInterfaceMagic :: Word32 binaryInterfaceMagic = 0xD0Cface ++-- Since datatypes in GHC might change between patchlevel versions,+-- and because we store GHC datatypes in our interface files,+-- we need to make sure we version our interface files accordingly.+--+-- Instead of adding one, we add three to all version numbers+-- when one of our own (stored) datatypes is changed. binaryInterfaceVersion :: Word16-binaryInterfaceVersion = 1+#if __GLASGOW_HASKELL__ == 608 && __GHC_PATCHLEVEL__ == 2+binaryInterfaceVersion = 2+#endif +#if __GLASGOW_HASKELL__ == 608 && __GHC_PATCHLEVEL__ == 3+binaryInterfaceVersion = 3+#endif +#if __GLASGOW_HASKELL__ >= 609+binaryInterfaceVersion = 4+#endif + initBinMemSize :: Int initBinMemSize = 1024*1024 writeInterfaceFile :: FilePath -> InterfaceFile -> IO () writeInterfaceFile filename iface = do - bh <- openBinMem initBinMemSize- put_ bh binaryInterfaceMagic- put_ bh binaryInterfaceVersion+ bh0 <- openBinMem initBinMemSize+ put_ bh0 binaryInterfaceMagic+ put_ bh0 binaryInterfaceVersion -- remember where the dictionary pointer will go- dict_p_p <- tellBin bh- put_ bh dict_p_p + dict_p_p <- tellBin bh0+ put_ bh0 dict_p_p -- remember where the symbol table pointer will go- symtab_p_p <- tellBin bh- put_ bh symtab_p_p+ symtab_p_p <- tellBin bh0+ put_ bh0 symtab_p_p -- Make some intial state+#if __GLASGOW_HASKELL__ >= 609+ symtab_next <- newFastMutInt+ writeFastMutInt symtab_next 0+ symtab_map <- newIORef emptyUFM+ let bin_symtab = BinSymbolTable {+ bin_symtab_next = symtab_next,+ bin_symtab_map = symtab_map }+ dict_next_ref <- newFastMutInt+ writeFastMutInt dict_next_ref 0+ dict_map_ref <- newIORef emptyUFM+ let bin_dict = BinDictionary {+ bin_dict_next = dict_next_ref,+ bin_dict_map = dict_map_ref }+ ud <- newWriteState (putName bin_symtab) (putFastString bin_dict)+#else ud <- newWriteState+#endif -- put the main thing- bh <- return $ setUserData bh ud+ bh <- return $ setUserData bh0 ud put_ bh iface -- write the symtab pointer at the fornt of the file@@ -82,9 +116,14 @@ seekBin bh symtab_p -- write the symbol table itself- symtab_next <- readFastMutInt (ud_symtab_next ud)- symtab_map <- readIORef (ud_symtab_map ud)- putSymbolTable bh symtab_next symtab_map+#if __GLASGOW_HASKELL__ >= 609+ symtab_next' <- readFastMutInt symtab_next+ symtab_map' <- readIORef symtab_map+#else+ symtab_next' <- readFastMutInt (ud_symtab_next ud)+ symtab_map' <- readIORef (ud_symtab_map ud)+#endif+ putSymbolTable bh symtab_next' symtab_map' -- write the dictionary pointer at the fornt of the file dict_p <- tellBin bh@@ -92,23 +131,67 @@ seekBin bh dict_p -- write the dictionary itself+#if __GLASGOW_HASKELL__ >= 609+ dict_next <- readFastMutInt dict_next_ref+ dict_map <- readIORef dict_map_ref+#else dict_next <- readFastMutInt (ud_dict_next ud) dict_map <- readIORef (ud_dict_map ud)+#endif putDictionary bh dict_next dict_map - -- snd send the result to the file+ -- and send the result to the file writeBinMem bh filename return () +type NameCacheAccessor m = (m NameCache, NameCache -> m ())+++#if __GLASGOW_HASKELL__ >= 609+nameCacheFromGhc :: NameCacheAccessor Ghc+nameCacheFromGhc = ( read_from_session , write_to_session )+ where+ read_from_session = do+ ref <- withSession (return . hsc_NC)+ liftIO $ readIORef ref+ write_to_session nc' = do+ ref <- withSession (return . hsc_NC)+ liftIO $ writeIORef ref nc'+#else+nameCacheFromGhc :: Session -> NameCacheAccessor IO+nameCacheFromGhc session = ( read_from_session , write_to_session )+ where+ read_from_session = readIORef . hsc_NC =<< sessionHscEnv session+ write_to_session nc' = do+ ref <- liftM hsc_NC $ sessionHscEnv session+ writeIORef ref nc'+#endif+++freshNameCache :: NameCacheAccessor IO+freshNameCache = ( create_fresh_nc , \_ -> return () )+ where+ create_fresh_nc = do+ u <- mkSplitUniqSupply 'a' -- ??+ return (initNameCache u [])+ -- | Read a Haddock (@.haddock@) interface file. Return either an --- 'InterfaceFile' or an error message. If given a GHC 'Session', the function--- registers all read names in the name cache of the session.-readInterfaceFile :: Maybe Session -> FilePath -> IO (Either String InterfaceFile)-readInterfaceFile mbSession filename = do- bh <- readBinMem filename+-- 'InterfaceFile' or an error message.+--+-- This function can be called in two ways. Within a GHC session it will+-- update the use and update the session's name cache. Outside a GHC session+-- a new empty name cache is used. The function is therefore generic in the+-- monad being used. The exact monad is whichever monad the first+-- argument, the getter and setter of the name cache, requires.+--+readInterfaceFile :: MonadIO m =>+ NameCacheAccessor m+ -> FilePath -> m (Either String InterfaceFile)+readInterfaceFile (get_name_cache, set_name_cache) filename = do+ bh0 <- liftIO $ readBinMem filename - magic <- get bh- version <- get bh+ magic <- liftIO $ get bh0+ version <- liftIO $ get bh0 case () of _ | magic /= binaryInterfaceMagic -> return . Left $@@ -117,54 +200,93 @@ "Interface file is of wrong version: " ++ filename | otherwise -> do - -- get the dictionary- dict_p <- get bh- data_p <- tellBin bh - seekBin bh dict_p- dict <- getDictionary bh- seekBin bh data_p -- -- initialise the user-data field of bh- ud <- newReadState dict- bh <- return (setUserData bh ud)-- -- get the name cache from ghc if we have a ghc session,- -- otherwise create a new one- (theNC, mbRef) <- case mbSession of- Just session -> do- ref <- withSession session (return . hsc_NC)- nc <- readIORef ref- return (nc, Just ref)- Nothing -> do- -- construct an empty name cache- u <- mkSplitUniqSupply 'a' -- ??- return (initNameCache u [], Nothing)-- -- get the symbol table- symtab_p <- get bh- data_p <- tellBin bh- seekBin bh symtab_p- (nc', symtab) <- getSymbolTable bh theNC- seekBin bh data_p+ dict <- get_dictionary bh0+ bh1 <- init_handle_user_data bh0 dict - -- write back the new name cache if we have a ghc session- case mbRef of- Just ref -> writeIORef ref nc'- Nothing -> return ()+ theNC <- get_name_cache+ (nc', symtab) <- get_symbol_table bh1 theNC+ set_name_cache nc' -- set the symbol table- let ud = getUserData bh- bh <- return $! setUserData bh ud{ud_symtab = symtab}+ let ud' = getUserData bh1+ bh2 <- return $! setUserData bh1 ud'{ud_symtab = symtab} -- load the actual data- iface <- get bh+ iface <- liftIO $ get bh2 return (Right iface)+ where+ get_dictionary bin_handle = liftIO $ do+ dict_p <- get bin_handle+ data_p <- tellBin bin_handle+ seekBin bin_handle dict_p+ dict <- getDictionary bin_handle+ seekBin bin_handle data_p+ return dict + init_handle_user_data bin_handle dict = liftIO $ do+ ud <- newReadState dict+ return (setUserData bin_handle ud) + get_symbol_table bh1 theNC = liftIO $ do+ symtab_p <- get bh1+ data_p' <- tellBin bh1+ seekBin bh1 symtab_p+ (nc', symtab) <- getSymbolTable bh1 theNC+ seekBin bh1 data_p'+ return (nc', symtab)+ ------------------------------------------------------------------------------- -- Symbol table ------------------------------------------------------------------------------- ++#if __GLASGOW_HASKELL__ >= 609+putName :: BinSymbolTable -> BinHandle -> Name -> IO ()+putName BinSymbolTable{+ bin_symtab_map = symtab_map_ref,+ bin_symtab_next = symtab_next } bh name+ = do+ symtab_map <- readIORef symtab_map_ref+ case lookupUFM symtab_map name of+ Just (off,_) -> put_ bh off+ Nothing -> do+ off <- readFastMutInt symtab_next+ writeFastMutInt symtab_next (off+1)+ writeIORef symtab_map_ref+ $! addToUFM symtab_map name (off,name)+ put_ bh off+++data BinSymbolTable = BinSymbolTable {+ bin_symtab_next :: !FastMutInt, -- The next index to use+ bin_symtab_map :: !(IORef (UniqFM (Int,Name)))+ -- indexed by Name+ }+++putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()+putFastString BinDictionary { bin_dict_next = j_r,+ bin_dict_map = out_r} bh f+ = do+ out <- readIORef out_r+ let unique = getUnique f+ case lookupUFM out unique of+ Just (j, _) -> put_ bh j+ Nothing -> do+ j <- readFastMutInt j_r+ put_ bh j+ writeFastMutInt j_r (j + 1)+ writeIORef out_r $! addToUFM out unique (j, f)+++data BinDictionary = BinDictionary {+ bin_dict_next :: !FastMutInt, -- The next index to use+ bin_dict_map :: !(IORef (UniqFM (Int,FastString)))+ -- indexed by FastString+ }+#endif++ putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO () putSymbolTable bh next_off symtab = do put_ bh next_off@@ -189,28 +311,28 @@ -> NameCache -> OnDiskName -> (NameCache, Name)-fromOnDiskName arr nc (pid, mod_name, occ) =+fromOnDiskName _ nc (pid, mod_name, occ) = let - mod = mkModule pid mod_name+ modu = mkModule pid mod_name cache = nsNames nc in- case lookupOrigNameCache cache mod occ of+ case lookupOrigNameCache cache modu occ of Just name -> (nc, name) Nothing -> let us = nsUniqs nc- uniq = uniqFromSupply us- name = mkExternalName uniq mod occ noSrcSpan- new_cache = extendNameCache cache mod occ name+ u = uniqFromSupply us+ name = mkExternalName u modu occ noSrcSpan+ new_cache = extendNameCache cache modu occ name in case splitUniqSupply us of { (us',_) -> ( nc{ nsUniqs = us', nsNames = new_cache }, name ) } serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()-serialiseName bh name symtab = do- let mod = nameModule name- put_ bh (modulePackageId mod, moduleName mod, nameOccName name)+serialiseName bh name _ = do+ let modu = nameModule name+ put_ bh (modulePackageId modu, moduleName modu, nameOccName name) -------------------------------------------------------------------------------@@ -230,20 +352,20 @@ instance Binary InstalledInterface where- put_ bh (InstalledInterface mod info docMap exps visExps) = do- put_ bh mod+ put_ bh (InstalledInterface modu info docMap exps visExps) = do+ put_ bh modu put_ bh info put_ bh (Map.toList docMap) put_ bh exps put_ bh visExps get bh = do- mod <- get bh+ modu <- get bh info <- get bh docMap <- get bh exps <- get bh visExps <- get bh- return (InstalledInterface mod info (Map.fromList docMap) exps visExps)+ return (InstalledInterface modu info (Map.fromList docMap) exps visExps) instance Binary DocOption where@@ -310,8 +432,11 @@ put_ bh (DocURL am) = do putByte bh 12 put_ bh am- put_ bh (DocAName an) = do+ put_ bh (DocPic x) = do putByte bh 13+ put_ bh x+ put_ bh (DocAName an) = do+ putByte bh 14 put_ bh an get bh = do h <- getByte bh@@ -356,6 +481,9 @@ am <- get bh return (DocURL am) 13 -> do+ x <- get bh+ return (DocPic x)+ 14 -> do an <- get bh return (DocAName an) _ -> fail "invalid binary data found"
src/Haddock/ModuleTree.hs view
@@ -9,7 +9,11 @@ import Haddock.DocName import GHC ( HsDoc, Name ) import Module ( Module, moduleNameString, moduleName, modulePackageId )-import PackageConfig ( packageIdString )+#if __GLASGOW_HASKELL__ >= 609+import Module (packageIdString)+#else+import PackageConfig (packageIdString)+#endif data ModuleTree = Node String Bool (Maybe String) (Maybe (HsDoc Name)) [ModuleTree]
src/Haddock/Types.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_HADDOCK hide #-}+ -- -- Haddock - A Haskell Documentation Tool --@@ -5,24 +7,26 @@ -- -{-# OPTIONS_HADDOCK hide #-}-- module Haddock.Types where -import Haddock.GHC.Utils import Haddock.DocName- import Data.Map (Map) import qualified Data.Map as Map- import GHC hiding (NoLink)-import Outputable-import OccName import Name +-- convenient short-hands+type Decl = LHsDecl Name+type Doc = HsDoc Name+++-- | A declaration that may have documentation, including its subordinates,+-- which may also have documentation+type DeclInfo = (Decl, Maybe Doc, [(Name, Maybe Doc)])++ {-! for DocOption derive: Binary !-} data DocOption = OptHide -- ^ This module should not appear in the docs@@ -43,6 +47,9 @@ -- | Maybe a doc comment expItemMbDoc :: Maybe (HsDoc name), + -- | Documentation for subordinate declarations+ expItemSubDocs :: [(name, HsDoc name)],+ -- | Instances relevant to this declaration expItemInstances :: [InstHead name] @@ -116,31 +123,28 @@ ifaceOrigFilename :: FilePath, -- | Textual information about the module - ifaceInfo :: HaddockModInfo Name,+ ifaceInfo :: !(HaddockModInfo Name), -- | The documentation header for this module- ifaceDoc :: Maybe (HsDoc Name),+ ifaceDoc :: !(Maybe (HsDoc Name)), -- | The renamed documentation header for this module ifaceRnDoc :: Maybe (HsDoc DocName), -- | The Haddock options for this module (prune, ignore-exports, etc)- ifaceOptions :: [DocOption],+ ifaceOptions :: ![DocOption], - ifaceDeclMap :: Map Name (LHsDecl Name, Maybe (HsDoc Name)),+ ifaceDeclMap :: Map Name DeclInfo, ifaceRnDocMap :: Map Name (HsDoc DocName), - ifaceExportItems :: [ExportItem Name],+ ifaceExportItems :: ![ExportItem Name], ifaceRnExportItems :: [ExportItem DocName], - -- | Environment mapping exported names to *original* names- ifaceEnv :: Map OccName Name,- -- | All the names that are defined in this module- ifaceLocals :: [Name],+ ifaceLocals :: ![Name], -- | All the names that are exported by this module- ifaceExports :: [Name],+ ifaceExports :: ![Name], -- | All the visible names exported by this module -- For a name to be visible, it has to:@@ -149,12 +153,10 @@ -- exception that it can't be from another package. -- Basically, a visible name is a name that will show up in the documentation -- for this module.- ifaceVisibleExports :: [Name],-- ifaceSubMap :: Map Name [Name],+ ifaceVisibleExports :: ![Name], -- | The instances exported by this module- ifaceInstances :: [Instance]+ ifaceInstances :: ![Instance] } @@ -194,7 +196,8 @@ markupDefList :: [(a,a)] -> a, markupCodeBlock :: a -> a, markupURL :: String -> a,- markupAName :: String -> a+ markupAName :: String -> a,+ markupPic :: String -> a }
src/Haddock/Utils.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE PatternSignatures #-}+ -- -- Haddock - A Haskell Documentation Tool --@@ -6,9 +8,6 @@ -- -{-# LANGUAGE PatternSignatures #-}-- module Haddock.Utils ( -- * Misc utilities@@ -18,9 +17,12 @@ -- * Filename utilities basename, dirname, splitFilename3, moduleHtmlFile, nameHtmlRef,- contentsHtmlFile, indexHtmlFile, subIndexHtmlFile, pathJoin,+ contentsHtmlFile, indexHtmlFile,+ frameIndexHtmlFile,+ moduleIndexFrameName, mainFrameName, synopsisFrameName,+ subIndexHtmlFile, pathJoin, anchorNameStr,- cssFile, iconFile, jsFile, plusFile, minusFile,+ cssFile, iconFile, jsFile, plusFile, minusFile, framesFile, -- * Miscellaneous utilities getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr,@@ -37,6 +39,9 @@ -- * Binary extras -- FormatVersion, mkFormatVersion + + -- * MTL stuff+ MonadIO(..) ) where import Haddock.Types@@ -48,16 +53,15 @@ import OccName import Binary import Module-import PackageConfig ( stringToPackageId ) -import Control.Monad ( liftM, MonadPlus(..) )-import Data.Char ( isAlpha, isSpace, toUpper, ord, chr )+import Control.Monad ( liftM )+import Data.Char ( isAlpha, ord, chr ) import Numeric ( showIntAtBase ) import Data.Map ( Map ) import qualified Data.Map as Map hiding ( Map ) import Data.IORef ( IORef, newIORef, readIORef )-import Data.List ( intersect, isSuffixOf, intersperse )-import Data.Maybe ( maybeToList, fromMaybe, isJust, fromJust )+import Data.List ( isSuffixOf )+import Data.Maybe ( fromJust ) import Data.Word ( Word8 ) import Data.Bits ( testBit ) import System.Environment ( getProgName )@@ -65,6 +69,14 @@ import System.IO ( hPutStr, stderr ) import System.IO.Unsafe ( unsafePerformIO ) +#if __GLASGOW_HASKELL__ >= 609+import MonadUtils ( MonadIO(..) )+#else+class Monad m => MonadIO m where+ liftIO :: IO a -> m a +instance MonadIO IO where liftIO = id+#endif+ -- ----------------------------------------------------------------------------- -- Some Utilities @@ -89,6 +101,7 @@ case restrictCons names (tcdCons d) of [] -> TyClD (d { tcdND = DataType, tcdCons = [] }) [con] -> TyClD (d { tcdCons = [con] })+ _ -> error "Should not happen" TyClD d | isClassDecl d -> TyClD (d { tcdSigs = restrictDecls names (tcdSigs d), tcdATs = restrictATs names (tcdATs d) })@@ -112,7 +125,7 @@ field_avail (ConDeclField n _ _) = (unLoc n) `elem` names field_types flds = [ t | ConDeclField _ t _ <- flds ] - keep d | otherwise = Nothing+ keep _ | otherwise = Nothing restrictDecls :: [Name] -> [LSig Name] -> [LSig Name] restrictDecls names decls = filter keep decls@@ -185,6 +198,17 @@ contentsHtmlFile = "index.html" indexHtmlFile = "doc-index.html" +-- | The name of the module index file to be displayed inside a frame.+-- Modules are display in full, but without indentation. Clicking opens in+-- the main window.+frameIndexHtmlFile :: String+frameIndexHtmlFile = "index-frames.html"++moduleIndexFrameName, mainFrameName, synopsisFrameName :: String+moduleIndexFrameName = "modules"+mainFrameName = "main"+synopsisFrameName = "synopsis"+ subIndexHtmlFile :: Char -> String subIndexHtmlFile a = "doc-index-" ++ b ++ ".html" where b | isAlpha a = [a]@@ -206,12 +230,13 @@ -- ----------------------------------------------------------------------------- -- Files we need to copy from our $libdir -cssFile, iconFile, jsFile, plusFile,minusFile :: String+cssFile, iconFile, jsFile, plusFile, minusFile, framesFile :: String cssFile = "haddock.css" iconFile = "haskell_icon.gif" jsFile = "haddock-util.js" plusFile = "plus.gif" minusFile = "minus.gif"+framesFile = "frames.html" ----------------------------------------------------------------------------- -- misc.@@ -258,7 +283,7 @@ myShowHex :: Int -> ShowS myShowHex n r = case showIntAtBase 16 (toChrHex) n r of [] -> "00"- [c] -> ['0',c]+ [a] -> ['0',a] cs -> cs toChrHex d | d < 10 = chr (ord '0' + fromIntegral d)@@ -270,6 +295,8 @@ isUnreserved :: Char -> Bool isUnreserved c = isAlphaNumChar c || (c `elem` "-_.~") ++isAlphaChar, isDigitChar, isAlphaNumChar :: Char -> Bool isAlphaChar c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') isDigitChar c = (c >= '0' && c <= '9') isAlphaNumChar c = isAlphaChar c || isDigitChar c@@ -299,6 +326,7 @@ ----------------------------------------------------------------------------- +replace :: Eq a => a -> a -> [a] -> [a] replace a b xs = map (\x -> if x == a then b else x) xs @@ -320,6 +348,7 @@ markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) markup m (DocURL url) = markupURL m url markup m (DocAName ref) = markupAName m ref+markup m (DocPic img) = markupPic m img markupPair :: DocMarkup id a -> (HsDoc id, HsDoc id) -> (a, a) markupPair m (a,b) = (markup m a, markup m b)@@ -339,15 +368,11 @@ markupOrderedList = DocOrderedList, markupDefList = DocDefList, markupCodeBlock = DocCodeBlock,- markupURL = DocURL,- markupAName = DocAName+ markupURL = DocURL,+ markupAName = DocAName,+ markupPic = DocPic } --- | Since marking up is just a matter of mapping 'Doc' into some--- other type, we can \'rename\' documentation by marking up 'Doc' into--- the same thing, modifying only the identifiers embedded in it.--mapIdent f = idMarkup { markupIdentifier = f } ----------------------------------------------------------------------------- -- put here temporarily
src/Main.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE ForeignFunctionInterface, PatternSignatures #-}+ -- -- Haddock - A Haskell Documentation Tool --@@ -23,22 +25,43 @@ import Paths_haddock import Control.Monad-import Control.Exception+#if __GLASGOW_HASKELL__ >= 609+import Control.OldException+import qualified Control.Exception as NewException+#else import Control.Exception+#endif import Data.Dynamic import Data.Maybe import Data.IORef import qualified Data.Map as Map+import Data.Version import System.IO import System.Exit import System.Environment+import System.FilePath -import GHC+#if defined(mingw32_HOST_OS)+import Foreign+import Foreign.C+import Data.Int+#endif++#ifndef IN_GHC_TREE import GHC.Paths+#endif++import GHC import DynFlags import Bag-import Util (handleDyn) import ErrUtils+#if __GLASGOW_HASKELL__ >= 609+import Panic (handleGhcException)+import Util+import MonadUtils ( MonadIO(..) )+#else+import Util hiding (handle)+#endif --------------------------------------------------------------------------------@@ -65,28 +88,39 @@ handleHaddockExceptions inner = - handleDyn (\(e::HaddockException) -> do- putStrLn $ "haddock: " ++ (show e)- exitFailure- ) inner+#if __GLASGOW_HASKELL__ >= 609+ NewException.catches inner [NewException.Handler handler]+#else+ handleDyn handler inner+#endif+ where+ handler (e::HaddockException) = do+ putStrLn $ "haddock: " ++ (show e)+ exitFailure handleGhcExceptions inner = -- compilation errors: messages with locations attached- handleDyn (\dyn -> do+#if __GLASGOW_HASKELL__ < 609+ handleDyn (\e -> do putStrLn "haddock: Compilation error(s):"- printBagOfErrors defaultDynFlags (unitBag dyn)+ printBagOfErrors defaultDynFlags (unitBag e) exitFailure ) $+#endif -- error messages propagated as exceptions- handleDyn (\dyn -> do+#if __GLASGOW_HASKELL__ >= 609+ handleGhcException (\e -> do+#else+ handleDyn (\e -> do+#endif hFlush stdout- case dyn of+ case e of PhaseFailed _ code -> exitWith code Interrupted -> exitFailure _ -> do - print (dyn :: GhcException)+ print (e :: GhcException) exitFailure ) inner @@ -113,35 +147,63 @@ if not (null fileArgs) then do - let libDir- | Just dir <- getGhcLibDir flags = dir- | otherwise = libdir -- from GHC.Paths+ libDir <- case getGhcLibDir flags of+ Just dir -> return dir+ Nothing ->+#ifdef IN_GHC_TREE+ do m <- getExecDir+ case m of+ Nothing -> error "No GhcLibDir found"+ Just d -> return (d </> "..")+#else+ return libdir -- from GHC.Paths+#endif +#if __GLASGOW_HASKELL__ >= 609 -- initialize GHC+ startGhc libDir (ghcFlags flags) $ \dynflags -> do++ -- get packages supplied with --read-interface+ packages <- readInterfaceFiles nameCacheFromGhc (ifacePairs flags)++ -- combine the link envs of the external packages into one+ let extLinks = Map.unions (map (ifLinkEnv . fst) packages)++ -- create the interfaces -- this is the core part of Haddock+ (interfaces, homeLinks) <- createInterfaces fileArgs extLinks flags++ let visibleIfaces = [ i | i <- interfaces, OptHide `notElem` ifaceOptions i ]+ + liftIO $ do+ -- render the interfaces+ renderStep packages visibleIfaces+ + -- last but not least, dump the interface file+ dumpInterfaceFile (map toInstalledIface visibleIfaces) homeLinks flags+#else+ -- initialize GHC (session, dynflags) <- startGhc libDir (ghcFlags flags) -- get packages supplied with --read-interface- packages <- readInterfaceFiles (Just session) (ifacePairs flags)-- -- typecheck argument modules using GHC- modules <- typecheckFiles session fileArgs+ packages <- readInterfaceFiles (nameCacheFromGhc session) (ifacePairs flags) -- combine the link envs of the external packages into one let extLinks = Map.unions (map (ifLinkEnv . fst) packages) -- create the interfaces -- this is the core part of Haddock- let (interfaces, homeLinks, messages) = createInterfaces modules extLinks flags- mapM_ putStrLn messages+ (interfaces, homeLinks) <- createInterfaces session fileArgs extLinks flags + let visibleIfaces = [ i | i <- interfaces, OptHide `notElem` ifaceOptions i ]+ -- render the interfaces- renderStep packages interfaces+ renderStep packages visibleIfaces -- last but not least, dump the interface file- dumpInterfaceFile (map toInstalledIface interfaces) homeLinks flags-+ dumpInterfaceFile (map toInstalledIface visibleIfaces) homeLinks flags+#endif else do -- get packages supplied with --read-interface- packages <- readInterfaceFiles Nothing (ifacePairs flags)+ packages <- readInterfaceFiles freshNameCache (ifacePairs flags) -- render even though there are no input files (usually contents/index) renderStep packages []@@ -154,7 +216,7 @@ -- | Render the interfaces with whatever backend is specified in the flags render :: [Flag] -> [Interface] -> [InstalledInterface] -> IO ()-render flags interfaces installedIfaces = do+render flags visibleIfaces installedIfaces = do let title = case [str | Flag_Heading str <- flags] of [] -> ""@@ -171,7 +233,15 @@ verbose = Flag_Verbose `elem` flags libdir <- case [str | Flag_Lib str <- flags] of- [] -> getDataDir -- provided by Cabal+ [] ->+#ifdef IN_GHC_TREE+ do m <- getExecDir+ case m of+ Nothing -> error "No libdir found"+ Just d -> return (d </> "..")+#else+ getDataDir -- provided by Cabal+#endif fs -> return (last fs) let css_file = case [str | Flag_CSS str <- flags] of@@ -201,9 +271,6 @@ prologue <- getPrologue flags let - -- visible home-module interfaces- visibleIfaces = [ m | m <- interfaces, OptHide `notElem` (ifaceOptions m) ]- -- *all* visible interfaces including external package modules allVisibleIfaces = map toInstalledIface visibleIfaces ++ installedIfaces@@ -236,24 +303,26 @@ copyHtmlBits odir libdir css_file when (Flag_Hoogle `elem` flags) $ do- ppHoogle pkgName pkgVer visibleIfaces odir+ ppHoogle pkgName pkgVer title prologue visibleIfaces odir ------------------------------------------------------------------------------- -- Reading and dumping interface files ------------------------------------------------------------------------------- -readInterfaceFiles :: Maybe Session -> [(FilePath, FilePath)] ->- IO [(InterfaceFile, FilePath)]-readInterfaceFiles session pairs = do+readInterfaceFiles :: MonadIO m =>+ NameCacheAccessor m+ -> [(FilePath, FilePath)] ->+ m [(InterfaceFile, FilePath)]+readInterfaceFiles name_cache_accessor pairs = do mbPackages <- mapM tryReadIface pairs return (catMaybes mbPackages) where -- try to read an interface, warn if we can't tryReadIface (html, iface) = do- eIface <- readInterfaceFile session iface+ eIface <- readInterfaceFile name_cache_accessor iface case eIface of- Left err -> do+ Left err -> liftIO $ do putStrLn ("Warning: Cannot read " ++ iface ++ ":") putStrLn (" " ++ show err) putStrLn "Skipping this interface."@@ -321,3 +390,21 @@ Left err -> throwE err Right doc -> return (Just doc) _otherwise -> throwE "multiple -p/--prologue options"++getExecDir :: IO (Maybe String)+#if defined(mingw32_HOST_OS)+getExecDir = allocaArray len $ \buf -> do+ ret <- getModuleFileName nullPtr buf len+ if ret == 0+ then return Nothing+ else do s <- peekCString buf+ return (Just (dropFileName s))+ where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.++foreign import stdcall unsafe "GetModuleFileNameA"+ getModuleFileName :: Ptr () -> CString -> Int -> IO Int32+#else+getExecDir = return Nothing+#endif++