diff --git a/CHANGES b/CHANGES
--- a/CHANGES
+++ b/CHANGES
@@ -1,3 +1,25 @@
+Changes in version 2.6.0:
+
+ * Drop support for GHC 6.10.*
+
+ * Add support for GHC 6.12.1
+
+ * Cross-package documentation: full documentation show up when re-exporting
+ things coming from external packages
+
+ * Lexing and parsing the Haddock comment markup is now done in Haddock
+ again, instead of in GHC
+
+ * Slightly prettier printing of instance heads
+
+ * Support platforms for which GHC has no native code generator
+
+ * Add a flag --print-ghc-libdir
+
+ * Minor bug fixes
+
+-----------------------------------------------------------------------------
+
Changed in version 2.5.0:
* Drop support for GHC 6.8.*
diff --git a/doc/haddock.xml b/doc/haddock.xml
--- a/doc/haddock.xml
+++ b/doc/haddock.xml
@@ -16,7 +16,7 @@
Simon Marlow
- This document describes Haddock version 2.5.0, a Haskell
+ This document describes Haddock version 2.6.0, a Haskell
documentation tool.
diff --git a/haddock.cabal b/haddock.cabal
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -1,5 +1,5 @@
name: haddock
-version: 2.5.0
+version: 2.6.0
cabal-version: >= 1.6
license: BSD3
build-type: Simple
@@ -65,15 +65,14 @@
executable haddock
build-depends:
- base >= 4.0.0.0 && < 4.2.0.0,
- haskell98,
+ base >= 4.0.0.0 && < 4.3.0.0,
filepath,
directory,
pretty,
containers,
array,
Cabal >= 1.5,
- ghc == 6.10.* || == 6.11.*
+ ghc >= 6.12 && < 6.14
if flag(in-ghc-tree)
cpp-options: -DIN_GHC_TREE
@@ -91,7 +90,13 @@
Haddock.Interface
Haddock.Interface.Rename
Haddock.Interface.Create
+ Haddock.Interface.ExtractFnArgDocs
Haddock.Interface.AttachInstances
+ Haddock.Interface.Lex
+ Haddock.Interface.Parse
+ Haddock.Interface.Rn
+ Haddock.Interface.LexParseRn
+ Haddock.Interface.ParseModuleHeader
Haddock.Utils.FastMutInt2
Haddock.Utils.BlockTable
Haddock.Utils.Html
@@ -104,10 +109,12 @@
Haddock.Backends.Hoogle
Haddock.ModuleTree
Haddock.Types
+ Haddock.HsDoc
Haddock.Version
Haddock.InterfaceFile
Haddock.Options
Haddock.GhcUtils
+ Haddock.Convert
-- Cabal doesn't define __GHC_PATCHLEVEL__
if impl(ghc == 6.10.1)
diff --git a/haddock.spec b/haddock.spec
--- a/haddock.spec
+++ b/haddock.spec
@@ -17,7 +17,7 @@
# version label of your release tarball.
%define name haddock
-%define version 2.5.0
+%define version 2.6.0
%define release 1
Name: %{name}
diff --git a/src/Haddock/Backends/DevHelp.hs b/src/Haddock/Backends/DevHelp.hs
--- a/src/Haddock/Backends/DevHelp.hs
+++ b/src/Haddock/Backends/DevHelp.hs
@@ -18,9 +18,6 @@
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
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -23,7 +23,6 @@
import GHC
import Outputable
-import Control.Monad
import Data.Char
import Data.List
import Data.Maybe
@@ -109,9 +108,9 @@
-- How to print each export
ppExport :: ExportItem Name -> [String]
-ppExport (ExportDecl decl dc _ _) = doc dc ++ f (unL decl)
+ppExport (ExportDecl decl dc subdocs _) = doc (fst dc) ++ f (unL decl)
where
- f (TyClD d@TyData{}) = ppData d
+ f (TyClD d@TyData{}) = ppData d subdocs
f (TyClD d@ClassDecl{}) = ppClass d
f (TyClD d@TySynonym{}) = ppSynonym d
f (ForD (ForeignImport name typ _)) = ppSig $ TypeSig name typ
@@ -156,9 +155,9 @@
ppInstance x = [dropComment $ out x]
-ppData :: TyClDecl Name -> [String]
-ppData x = showData x{tcdCons=[],tcdDerivs=Nothing} :
- concatMap (ppCtor x . unL) (tcdCons x)
+ppData :: TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]
+ppData x subdocs = showData x{tcdCons=[],tcdDerivs=Nothing} :
+ concatMap (ppCtor x subdocs . unL) (tcdCons x)
where
-- GHC gives out "data Bar =", we want to delete the equals
-- also writes data : a b, when we want data (:) a b
@@ -168,14 +167,20 @@
nam = out $ tcdLName d
f w = if w == nam then operator nam else w
+-- | for constructors, and named-fields...
+lookupCon :: [(Name, DocForDecl Name)] -> Located Name -> Maybe (HsDoc Name)
+lookupCon subdocs (L _ name) = case lookup name subdocs of
+ Just (d, _) -> d
+ _ -> Nothing
-ppCtor :: TyClDecl Name -> ConDecl Name -> [String]
-ppCtor dat con = ldoc (con_doc con) ++ f (con_details con)
+ppCtor :: TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String]
+ppCtor dat subdocs con = doc (lookupCon subdocs (con_name con))
+ ++ f (con_details con)
where
f (PrefixCon args) = [typeSig name $ args ++ [resType]]
f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
f (RecCon recs) = f (PrefixCon $ map cd_fld_type recs) ++ concat
- [ldoc (cd_fld_doc r) ++
+ [doc (lookupCon subdocs (cd_fld_name r)) ++
[out (unL $ cd_fld_name r) `typeSig` [resType, cd_fld_type r]]
| r <- recs]
@@ -192,9 +197,6 @@
---------------------------------------------------------------------
-- DOCUMENTATION
-
-ldoc :: Outputable o => Maybe (LHsDoc o) -> [String]
-ldoc = doc . liftM unL
doc :: Outputable o => Maybe (HsDoc o) -> [String]
doc = docWith ""
diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs
--- a/src/Haddock/Backends/Html.hs
+++ b/src/Haddock/Backends/Html.hs
@@ -23,7 +23,7 @@
import Haddock.Backends.HH
import Haddock.Backends.HH2
import Haddock.ModuleTree
-import Haddock.Types hiding ( Doc )
+import Haddock.Types
import Haddock.Version
import Haddock.Utils
import Haddock.Utils.Html hiding ( name, title, p )
@@ -43,11 +43,7 @@
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 RdrName hiding ( Qual, is_explicit )
@@ -60,10 +56,6 @@
type WikiURLs = (Maybe String, Maybe String, Maybe String)
--- convenient short-hands
-type Doc = HsDoc DocName
-
-
-- -----------------------------------------------------------------------------
-- Generating HTML documentation
@@ -71,7 +63,7 @@
-> Maybe String -- package
-> [Interface]
-> FilePath -- destination directory
- -> Maybe (GHC.HsDoc GHC.RdrName) -- prologue text, maybe
+ -> Maybe (HsDoc GHC.RdrName) -- prologue text, maybe
-> Maybe String -- the Html Help format (--html-help)
-> SourceURLs -- the source URL (--source)
-> WikiURLs -- the wiki URL (--wiki)
@@ -285,7 +277,7 @@
let
info = ifaceInfo iface
- doOneEntry :: (String, (GHC.HaddockModInfo GHC.Name) -> Maybe String) -> Maybe HtmlTable
+ doOneEntry :: (String, (HaddockModInfo GHC.Name) -> Maybe String) -> Maybe HtmlTable
doOneEntry (fieldName,field) = case field info of
Nothing -> Nothing
Just fieldValue ->
@@ -294,9 +286,9 @@
entries :: [HtmlTable]
entries = mapMaybe doOneEntry [
- ("Portability",GHC.hmi_portability),
- ("Stability",GHC.hmi_stability),
- ("Maintainer",GHC.hmi_maintainer)
+ ("Portability",hmi_portability),
+ ("Stability",hmi_stability),
+ ("Maintainer",hmi_maintainer)
]
in
case entries of
@@ -314,7 +306,7 @@
-> Maybe String
-> SourceURLs
-> WikiURLs
- -> [InstalledInterface] -> Bool -> Maybe (GHC.HsDoc GHC.RdrName)
+ -> [InstalledInterface] -> Bool -> Maybe (HsDoc GHC.RdrName)
-> IO ()
ppHtmlContents odir doctitle
maybe_package maybe_html_help_format maybe_index_url
@@ -349,7 +341,7 @@
Just "devhelp" -> return ()
Just format -> fail ("The "++format++" format is not implemented")
-ppPrologue :: String -> Maybe (GHC.HsDoc GHC.RdrName) -> HtmlTable
+ppPrologue :: String -> Maybe (HsDoc GHC.RdrName) -> HtmlTable
ppPrologue _ Nothing = Html.emptyTable
ppPrologue title (Just doc) =
(tda [theclass "section1"] << toHtml title)
@@ -657,11 +649,11 @@
ifaceToHtml maybe_source_url maybe_wiki_url iface unicode
= abovesSep s15 (contents ++ description: synopsis: maybe_doc_hdr: bdy)
where
- docMap = ifaceRnDocMap iface
-
exports = numberSectionHeadings (ifaceRnExportItems iface)
- has_doc (ExportDecl _ doc _ _) = isJust doc
+ -- todo: if something has only sub-docs, or fn-args-docs, should
+ -- it be measured here and thus prevent omitting the synopsis?
+ has_doc (ExportDecl _ doc _ _) = isJust (fst doc)
has_doc (ExportNoDecl _ _) = False
has_doc (ExportModule _) = False
has_doc _ = True
@@ -685,7 +677,7 @@
= (tda [theclass "section1"] << toHtml "Synopsis")
s15
(tda [theclass "body"] << vanillaTable <<
- abovesSep s8 (map (processExport True linksInfo docMap unicode)
+ abovesSep s8 (map (processExport True linksInfo unicode)
(filter forSummary exports))
)
@@ -697,7 +689,7 @@
ExportGroup _ _ _ : _ -> Html.emptyTable
_ -> tda [ theclass "section1" ] << toHtml "Documentation"
- bdy = map (processExport False linksInfo docMap unicode) exports
+ bdy = map (processExport False linksInfo unicode) exports
linksInfo = (maybe_source_url, maybe_wiki_url)
miniSynopsis :: Module -> Interface -> Bool -> Html
@@ -782,18 +774,18 @@
go n (other:es)
= other : go n es
-processExport :: Bool -> LinksInfo -> DocMap -> Bool -> (ExportItem DocName) -> HtmlTable
-processExport _ _ _ _ (ExportGroup lev id0 doc)
+processExport :: Bool -> LinksInfo -> Bool -> (ExportItem DocName) -> HtmlTable
+processExport _ _ _ (ExportGroup lev id0 doc)
= ppDocGroup lev (namedAnchor id0 << docToHtml doc)
-processExport summary links docMap unicode (ExportDecl decl doc subdocs insts)
- = ppDecl summary links decl doc insts docMap subdocs unicode
-processExport _ _ _ _ (ExportNoDecl y [])
+processExport summary links unicode (ExportDecl decl doc subdocs insts)
+ = ppDecl summary links decl doc insts subdocs unicode
+processExport _ _ _ (ExportNoDecl y [])
= declBox (ppDocName y)
-processExport _ _ _ _ (ExportNoDecl y subs)
+processExport _ _ _ (ExportNoDecl y subs)
= declBox (ppDocName y <+> parenList (map ppDocName subs))
-processExport _ _ _ _ (ExportDoc doc)
+processExport _ _ _ (ExportDoc doc)
= docBox (docToHtml doc)
-processExport _ _ _ _ (ExportModule mdl)
+processExport _ _ _ (ExportModule mdl)
= declBox (toHtml "module" <+> ppModule mdl "")
forSummary :: (ExportItem DocName) -> Bool
@@ -817,70 +809,63 @@
-- TODO: use DeclInfo DocName or something
ppDecl :: Bool -> LinksInfo -> LHsDecl DocName ->
- Maybe (HsDoc DocName) -> [InstHead DocName] -> DocMap -> [(DocName, Maybe (HsDoc DocName))] -> Bool -> HtmlTable
-ppDecl summ links (L loc decl) mbDoc instances docMap subdocs unicode = case decl of
+ DocForDecl DocName -> [InstHead DocName] -> [(DocName, DocForDecl DocName)] -> Bool -> HtmlTable
+ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode = case decl of
TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d unicode
TyClD d@(TyData {})
- | Nothing <- tcdTyPats d -> ppDataDecl summ links instances loc mbDoc d unicode
+ | Nothing <- tcdTyPats d -> ppDataDecl summ links instances subdocs loc mbDoc d unicode
| Just _ <- tcdTyPats d -> ppDataInst summ links loc mbDoc d
TyClD d@(TySynonym {})
- | Nothing <- tcdTyPats d -> ppTySyn summ links loc mbDoc d unicode
+ | Nothing <- tcdTyPats d -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode
| Just _ <- tcdTyPats d -> ppTyInst summ False links loc mbDoc d unicode
- TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc docMap subdocs d unicode
- SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig summ links loc mbDoc n t unicode
- ForD d -> ppFor summ links loc mbDoc d unicode
+ TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode
+ SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) n t unicode
+ ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode
InstD _ -> Html.emptyTable
_ -> error "declaration not supported by ppDecl"
-ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) ->
+ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
DocName -> HsType DocName -> Bool -> HtmlTable
-ppFunSig summary links loc mbDoc docname typ unicode =
- ppTypeOrFunSig summary links loc docname typ mbDoc
+ppFunSig summary links loc doc docname typ unicode =
+ ppTypeOrFunSig summary links loc docname typ doc
(ppTypeSig summary occname typ unicode, ppBinder False occname, dcolon unicode) unicode
where
occname = docNameOcc docname
ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> DocName -> HsType DocName ->
- Maybe (HsDoc DocName) -> (Html, Html, Html) -> Bool -> HtmlTable
-ppTypeOrFunSig summary links loc docname typ doc (pref1, pref2, sep) unicode
- | summary || noArgDocs typ = declWithDoc summary links loc docname doc pref1
+ DocForDecl DocName -> (Html, Html, Html) -> Bool -> HtmlTable
+ppTypeOrFunSig summary links loc docname typ (doc, argDocs) (pref1, pref2, sep) unicode
+ | summary || Map.null argDocs = declWithDoc summary links loc docname doc pref1
| otherwise = topDeclBox links loc docname pref2
(tda [theclass "body"] << vanillaTable << (
- do_args sep typ
+ do_args 0 sep typ
(case doc of
Just d -> ndocBox (docToHtml d)
Nothing -> Html.emptyTable)
))
where
- 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
+ argDocHtml n = case Map.lookup n argDocs of
+ Just adoc -> docToHtml adoc
+ Nothing -> noHtml
- do_largs leader (L _ t) = do_args leader t
- do_args :: Html -> (HsType DocName) -> HtmlTable
- do_args leader (HsForAllTy Explicit tvs lctxt ltype)
+ do_largs n leader (L _ t) = do_args n leader t
+ do_args :: Int -> Html -> (HsType DocName) -> HtmlTable
+ do_args n leader (HsForAllTy Explicit tvs lctxt ltype)
= (argBox (
leader <+>
hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+>
ppLContextNoArrow lctxt unicode)
<-> rdocBox noHtml)
- do_largs (darrow unicode) ltype
- do_args leader (HsForAllTy Implicit _ lctxt ltype)
+ do_largs n (darrow unicode) ltype
+ do_args n leader (HsForAllTy Implicit _ lctxt ltype)
= (argBox (leader <+> ppLContextNoArrow lctxt unicode)
<-> rdocBox noHtml)
- do_largs (darrow unicode) ltype
- do_args leader (HsFunTy (L _ (HsDocTy lt ldoc)) r)
- = (argBox (leader <+> ppLType unicode lt) <-> rdocBox (docToHtml (unLoc ldoc)))
- do_largs (arrow unicode) r
- do_args leader (HsFunTy lt r)
- = (argBox (leader <+> ppLType unicode lt) <-> rdocBox noHtml) do_largs (arrow unicode) r
- do_args leader (HsDocTy lt ldoc)
- = (argBox (leader <+> ppLType unicode lt) <-> rdocBox (docToHtml (unLoc ldoc)))
- do_args leader t
- = argBox (leader <+> ppType unicode t) <-> rdocBox (noHtml)
+ do_largs (n+1) (darrow unicode) ltype
+ do_args n leader (HsFunTy lt r)
+ = (argBox (leader <+> ppLType unicode lt) <-> rdocBox (argDocHtml n))
+ do_largs (n+1) (arrow unicode) r
+ do_args n leader t
+ = argBox (leader <+> ppType unicode t) <-> rdocBox (argDocHtml n)
ppTyVars :: [LHsTyVarBndr DocName] -> [Html]
@@ -891,16 +876,16 @@
tyvarNames = map (getName . hsTyVarName . unLoc)
-ppFor :: Bool -> LinksInfo -> SrcSpan -> Maybe Doc -> ForeignDecl DocName -> Bool -> HtmlTable
-ppFor summary links loc mbDoc (ForeignImport (L _ name) (L _ typ) _) unicode
- = ppFunSig summary links loc mbDoc name typ unicode
+ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> HtmlTable
+ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _) unicode
+ = ppFunSig summary links loc doc name typ unicode
ppFor _ _ _ _ _ _ = error "ppFor"
-- we skip type patterns for now
-ppTySyn :: Bool -> LinksInfo -> SrcSpan -> Maybe Doc -> TyClDecl DocName -> Bool -> HtmlTable
-ppTySyn summary links loc mbDoc (TySynonym (L _ name) ltyvars _ ltype) unicode
- = ppTypeOrFunSig summary links loc name (unLoc ltype) mbDoc
+ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> HtmlTable
+ppTySyn summary links loc doc (TySynonym (L _ name) ltyvars _ ltype) unicode
+ = ppTypeOrFunSig summary links loc name (unLoc ltype) doc
(full, hdr, spaceHtml +++ equals) unicode
where
hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars)
@@ -1033,10 +1018,10 @@
--------------------------------------------------------------------------------
-ppAssocType :: Bool -> LinksInfo -> Maybe (HsDoc DocName) -> LTyClDecl DocName -> Bool -> HtmlTable
+ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LTyClDecl DocName -> Bool -> HtmlTable
ppAssocType summ links doc (L loc decl) unicode =
case decl of
- TyFamily {} -> ppTyFam summ True links loc doc decl unicode
+ TyFamily {} -> ppTyFam summ True links loc (fst doc) decl unicode
TySynonym {} -> ppTySyn summ links loc doc decl unicode
_ -> error "declaration type not supported by ppAssocType"
@@ -1140,7 +1125,7 @@
fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> arrow unicode <+>
hsep (map ppDocName vars2)
-ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, Maybe (HsDoc DocName))] -> Bool -> HtmlTable
+ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, DocForDecl DocName)] -> Bool -> HtmlTable
ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc subdocs unicode =
if null sigs && null ats
then (if summary then declBox else topDeclBox links loc nm) hdr
@@ -1151,11 +1136,11 @@
aboves
(
[ ppAssocType summary links doc at unicode | at <- ats
- , let doc = join $ lookup (tcdName $ unL at) subdocs ] ++
+ , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] ++
[ ppFunSig summary links loc doc n typ unicode
| L _ (TypeSig (L _ n) (L _ typ)) <- sigs
- , let doc = join $ lookup n subdocs ]
+ , let doc = lookupAnySubdoc n subdocs ]
)
)
where
@@ -1166,9 +1151,9 @@
ppClassDecl :: Bool -> LinksInfo -> [InstHead DocName] -> SrcSpan
- -> Maybe (HsDoc DocName) -> DocMap -> [(DocName, Maybe (HsDoc DocName))]
+ -> Maybe (HsDoc DocName) -> [(DocName, DocForDecl DocName)]
-> TyClDecl DocName -> Bool -> HtmlTable
-ppClassDecl summary links instances loc mbDoc _ subdocs
+ppClassDecl summary links instances loc mbDoc subdocs
decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode
| summary = ppShortClassDecl summary links decl loc subdocs unicode
| otherwise = classheader bodyBox << (classdoc body_ instancesBit)
@@ -1194,10 +1179,10 @@
methodTable =
abovesSep s8 [ ppFunSig summary links loc doc n typ unicode
| L _ (TypeSig (L _ n) (L _ typ)) <- lsigs
- , let doc = join $ lookup n subdocs ]
+ , let doc = lookupAnySubdoc n subdocs ]
atTable = abovesSep s8 $ [ ppAssocType summary links doc at unicode | at <- ats
- , let doc = join $ lookup (tcdName $ unL at) subdocs ]
+ , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ]
instId = collapseId (getName nm)
instancesBit
@@ -1209,7 +1194,7 @@
spacedTable1 << (
aboves (map (declBox . ppInstHead unicode) instances)
))
-ppClassDecl _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
+ppClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
ppInstHead :: Bool -> InstHead DocName -> Html
@@ -1217,6 +1202,14 @@
ppInstHead unicode (ctxt, n, ts) = ppContextNoLocs ctxt unicode <+> ppAppNameTypes n ts unicode
+lookupAnySubdoc :: (Eq name1) =>
+ name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2
+lookupAnySubdoc n subdocs = case lookup n subdocs of
+ Nothing -> noDocForDecl
+ Just docs -> docs
+
+
+
-- -----------------------------------------------------------------------------
-- Data & newtype declarations
@@ -1256,9 +1249,10 @@
cons = tcdCons dataDecl
resTy = (con_res . unLoc . head) cons
-ppDataDecl :: Bool -> LinksInfo -> [InstHead DocName] ->
+ppDataDecl :: Bool -> LinksInfo -> [InstHead DocName] ->
+ [(DocName, DocForDecl DocName)] ->
SrcSpan -> Maybe (HsDoc DocName) -> TyClDecl DocName -> Bool -> HtmlTable
-ppDataDecl summary links instances loc mbDoc dataDecl unicode
+ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode
| summary = declWithDoc summary links loc docname mbDoc
(ppShortDataDecl summary links loc dataDecl unicode)
@@ -1298,7 +1292,7 @@
| null cons = Html.emptyTable
| otherwise = constrHdr (
tda [theclass "body"] << constrTable <<
- aboves (map (ppSideBySideConstr unicode) cons)
+ aboves (map (ppSideBySideConstr subdocs unicode) cons)
)
instId = collapseId (getName docname)
@@ -1373,8 +1367,8 @@
Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> toHtml ". "
Implicit -> empty
-ppSideBySideConstr :: Bool -> LConDecl DocName -> HtmlTable
-ppSideBySideConstr unicode (L _ con) = case con_res con of
+ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LConDecl DocName -> HtmlTable
+ppSideBySideConstr subdocs unicode (L _ con) = case con_res con of
ResTyH98 -> case con_details con of
@@ -1403,7 +1397,7 @@
where
doRecordFields fields =
(tda [theclass "body"] << spacedTable1 <<
- aboves (map (ppSideBySideField unicode) fields))
+ aboves (map (ppSideBySideField subdocs unicode) fields))
doGADTCon args resTy = argBox (ppBinder False occ <+> dcolon unicode <+> hsep [
ppForAll forall ltvs (con_cxt con) unicode,
ppLType unicode (foldr mkFunTy resTy args) ]
@@ -1416,14 +1410,21 @@
tyVars = tyvarNames (con_qvars con)
context = unLoc (con_cxt con)
forall = con_explicit con
- mbLDoc = con_doc con
+ -- don't use "con_doc con", in case it's reconstructed from a .hi file,
+ -- or also because we want Haddock to do the doc-parsing, not GHC.
+ -- The 'fmap' and 'join' are in Maybe
+ mbLDoc = fmap noLoc $ join $ fmap fst $
+ lookup (unLoc $ con_name con) subdocs
mkFunTy a b = noLoc (HsFunTy a b)
-ppSideBySideField :: Bool -> ConDeclField DocName -> HtmlTable
-ppSideBySideField unicode (ConDeclField (L _ name) ltype mbLDoc) =
+ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> HtmlTable
+ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) =
argBox (ppBinder False (docNameOcc name)
<+> dcolon unicode <+> ppLType unicode ltype) <->
maybeRDocBox mbLDoc
+ where
+ -- don't use cd_fld_doc for same reason we don't use con_doc above
+ mbLDoc = fmap noLoc $ join $ fmap fst $ lookup name subdocs
{-
ppHsFullConstr :: HsConDecl -> Html
@@ -1598,7 +1599,8 @@
ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u)
ppr_mono_ty _ (HsPredTy p) u = parens (ppPred u p)
ppr_mono_ty _ (HsNumTy n) _ = toHtml (show n) -- generics only
-ppr_mono_ty _ (HsSpliceTy _) _ = error "ppr_mono_ty-haddock"
+ppr_mono_ty _ (HsSpliceTy _) _ = error "ppr_mono_ty HsSpliceTy"
+ppr_mono_ty _ (HsSpliceTyOut _) _ = error "ppr_mono_ty HsSpliceTyOut"
#if __GLASGOW_HASKELL__ >= 611
ppr_mono_ty _ (HsRecTy _) _ = error "ppr_mono_ty HsRecTy"
#endif
@@ -1748,15 +1750,15 @@
-- separate them. So we catch the single paragraph case and transform it
-- here.
unParagraph :: HsDoc a -> HsDoc a
-unParagraph (GHC.DocParagraph d) = d
+unParagraph (DocParagraph d) = d
--NO: This eliminates line breaks in the code block: (SDM, 6/5/2003)
--unParagraph (DocCodeBlock d) = (DocMonospaced d)
unParagraph doc = doc
-htmlCleanup :: DocMarkup a (GHC.HsDoc a)
+htmlCleanup :: DocMarkup a (HsDoc a)
htmlCleanup = idMarkup {
- markupUnorderedList = GHC.DocUnorderedList . map unParagraph,
- markupOrderedList = GHC.DocOrderedList . map unParagraph
+ markupUnorderedList = DocUnorderedList . map unParagraph,
+ markupOrderedList = DocOrderedList . map unParagraph
}
-- -----------------------------------------------------------------------------
@@ -1888,7 +1890,7 @@
rdocBox :: Html -> HtmlTable
rdocBox html = tda [theclass "rdoc"] << html
-maybeRDocBox :: Maybe (GHC.LHsDoc DocName) -> HtmlTable
+maybeRDocBox :: Maybe (LHsDoc DocName) -> HtmlTable
maybeRDocBox Nothing = rdocBox (noHtml)
maybeRDocBox (Just ldoc) = rdocBox (docToHtml (unLoc ldoc))
diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
new file mode 100644
--- /dev/null
+++ b/src/Haddock/Convert.hs
@@ -0,0 +1,284 @@
+{-# LANGUAGE PatternGuards #-}
+
+-- This functionality may be moved into GHC at some point, and then
+-- we can use the GHC version (#if GHC version is new enough).
+
+-- Some other functions turned out to be useful for converting
+-- instance heads, which aren't TyThings, so just export everything.
+module Haddock.Convert where
+
+import HsSyn
+import TcType ( tcSplitSigmaTy )
+import TypeRep
+import Type ( splitKindFunTys )
+import Name
+import Var
+import Class
+import TyCon
+import DataCon
+import BasicTypes
+import TysPrim ( alphaTyVars )
+import TysWiredIn ( listTyConName )
+import Bag ( emptyBag )
+import SrcLoc ( Located, noLoc, unLoc )
+
+-- the main function here! yay!
+tyThingToLHsDecl :: TyThing -> LHsDecl Name
+tyThingToLHsDecl t = noLoc $ case t of
+ -- ids (functions and zero-argument a.k.a. CAFs) get a type signature.
+ -- Including built-in functions like seq.
+ -- foreign-imported functions could be represented with ForD
+ -- instead of SigD if we wanted...
+ --
+ -- in a future code version we could turn idVarDetails = foreign-call
+ -- into a ForD instead of a SigD if we wanted. Haddock doesn't
+ -- need to care.
+ AnId i -> SigD (synifyIdSig ImplicitizeForAll i)
+ -- type-constructors (e.g. Maybe) are complicated, put the definition
+ -- later in the file (also it's used for class associated-types too.)
+ ATyCon tc -> TyClD (synifyTyCon tc)
+ -- a data-constructor alone just gets rendered as a function:
+ ADataCon dc -> SigD (TypeSig (synifyName dc)
+ (synifyType ImplicitizeForAll (dataConUserType dc)))
+ -- classes are just a little tedious
+ AClass cl ->
+ TyClD $ ClassDecl
+ (synifyCtx (classSCTheta cl))
+ (synifyName cl)
+ (synifyTyVars (classTyVars cl))
+ (map (\ (l,r) -> noLoc
+ (map getName l, map getName r) ) $
+ snd $ classTvsFds cl)
+ (map (\i -> noLoc $ synifyIdSig DeleteTopLevelQuantification i)
+ (classMethods cl))
+ emptyBag --ignore default method definitions, they don't affect signature
+ (map synifyClassAT (classATs cl))
+ [] --we don't have any docs at this point
+
+-- class associated-types are a subset of TyCon
+-- (mainly only type/data-families)
+synifyClassAT :: TyCon -> LTyClDecl Name
+synifyClassAT tc = noLoc $ synifyTyCon tc
+
+synifyTyCon :: TyCon -> TyClDecl Name
+synifyTyCon tc
+ | isFunTyCon tc || isPrimTyCon tc =
+ TyData
+ -- arbitrary lie, they are neither algebraic data nor newtype:
+ DataType
+ -- no built-in type has any stupidTheta:
+ (noLoc [])
+ (synifyName tc)
+ -- tyConTyVars doesn't work on fun/prim, but we can make them up:
+ (zipWith
+ (\fakeTyVar realKind -> noLoc $
+ KindedTyVar (getName fakeTyVar) realKind)
+ alphaTyVars --a, b, c... which are unfortunately all kind *
+ (fst . splitKindFunTys $ tyConKind tc)
+ )
+ -- assume primitive types aren't members of data/newtype families:
+ Nothing
+ -- we have their kind accurately:
+ (Just (tyConKind tc))
+ -- no algebraic constructors:
+ []
+ -- "deriving" needn't be specified:
+ Nothing
+ | isOpenSynTyCon tc =
+ case synTyConRhs tc of
+ OpenSynTyCon rhs_kind _ ->
+ TyFamily TypeFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
+ (Just rhs_kind)
+ _ -> error "synifyTyCon: impossible open type synonym?"
+ | isOpenTyCon tc = --(why no "isOpenAlgTyCon"?)
+ case algTyConRhs tc of
+ OpenTyCon _ ->
+ TyFamily DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
+ Nothing --always kind '*'
+ _ -> error "synifyTyCon: impossible open data type?"
+ | otherwise =
+ -- (closed) type, newtype, and data
+ let
+ -- alg_ only applies to newtype/data
+ -- syn_ only applies to type
+ -- others apply to both
+ alg_nd = if isNewTyCon tc then NewType else DataType
+ alg_ctx = synifyCtx (tyConStupidTheta tc)
+ name = synifyName tc
+ tyvars = synifyTyVars (tyConTyVars tc)
+ typats = case tyConFamInst_maybe tc of
+ Nothing -> Nothing
+ Just (_, indexes) -> Just (map (synifyType WithinType) indexes)
+ alg_kindSig = Just (tyConKind tc)
+ -- The data constructors.
+ --
+ -- Any data-constructors not exported from the module that *defines* the
+ -- type will not (cannot) be included.
+ --
+ -- Very simple constructors, Haskell98 with no existentials or anything,
+ -- probably look nicer in non-GADT syntax. In source code, all constructors
+ -- must be declared with the same (GADT vs. not) syntax, and it probably
+ -- is less confusing to follow that principle for the documentation as well.
+ --
+ -- There is no sensible infix-representation for GADT-syntax constructor
+ -- declarations. They cannot be made in source code, but we could end up
+ -- with some here in the case where some constructors use existentials.
+ -- That seems like an acceptable compromise (they'll just be documented
+ -- in prefix position), since, otherwise, the logic (at best) gets much more
+ -- complicated. (would use dataConIsInfix.)
+ alg_use_gadt_syntax = any (not . isVanillaDataCon) (tyConDataCons tc)
+ alg_cons = map (synifyDataCon alg_use_gadt_syntax) (tyConDataCons tc)
+ -- "deriving" doesn't affect the signature, no need to specify any.
+ alg_deriv = Nothing
+ syn_type = synifyType WithinType (synTyConType tc)
+ in if isSynTyCon tc
+ then TySynonym name tyvars typats syn_type
+ else TyData alg_nd alg_ctx name tyvars typats alg_kindSig alg_cons alg_deriv
+
+-- User beware: it is your responsibility to pass True (use_gadt_syntax)
+-- for any constructor that would be misrepresented by omitting its
+-- result-type.
+-- But you might want pass False in simple enough cases,
+-- if you think it looks better.
+synifyDataCon :: Bool -> DataCon -> LConDecl Name
+synifyDataCon use_gadt_syntax dc = noLoc $
+ let
+ -- dataConIsInfix allegedly tells us whether it was declared with
+ -- infix *syntax*.
+ use_infix_syntax = dataConIsInfix dc
+ use_named_field_syntax = not (null field_tys)
+ name = synifyName dc
+ -- con_qvars means a different thing depending on gadt-syntax
+ qvars = if use_gadt_syntax
+ then synifyTyVars (dataConAllTyVars dc)
+ else synifyTyVars (dataConExTyVars dc)
+ -- skip any EqTheta, use 'orig'inal syntax
+ ctx = synifyCtx (dataConDictTheta dc)
+ linear_tys = zipWith (\ty strict ->
+ let tySyn = synifyType WithinType ty
+ in case strict of
+ MarkedStrict -> noLoc $ HsBangTy HsStrict tySyn
+ MarkedUnboxed -> noLoc $ HsBangTy HsUnbox tySyn
+ NotMarkedStrict ->
+ -- HsNoBang never appears, it's implied instead.
+ tySyn
+ )
+ (dataConOrigArgTys dc) (dataConStrictMarks dc)
+ field_tys = zipWith (\field synTy -> ConDeclField
+ (synifyName field) synTy Nothing)
+ (dataConFieldLabels dc) linear_tys
+ tys = case (use_named_field_syntax, use_infix_syntax) of
+ (True,True) -> error "synifyDataCon: contradiction!"
+ (True,False) -> RecCon field_tys
+ (False,False) -> PrefixCon linear_tys
+ (False,True) -> case linear_tys of
+ [a,b] -> InfixCon a b
+ _ -> error "synifyDataCon: infix with non-2 args?"
+ res_ty = if use_gadt_syntax
+ then ResTyGADT (synifyType WithinType (dataConOrigResTy dc))
+ else ResTyH98
+ -- finally we get synifyDataCon's result!
+ in ConDecl name Implicit{-we don't know nor care-}
+ qvars ctx tys res_ty Nothing
+#if __GLASGOW_HASKELL__ >= 611
+ False --we don't want any "deprecated GADT syntax" warnings!
+#endif
+
+synifyName :: NamedThing n => n -> Located Name
+synifyName n = noLoc (getName n)
+
+synifyIdSig :: SynifyTypeState -> Id -> Sig Name
+synifyIdSig s i = TypeSig (synifyName i) (synifyType s (varType i))
+
+
+synifyCtx :: [PredType] -> LHsContext Name
+synifyCtx ps = noLoc (map synifyPred ps)
+
+synifyPred :: PredType -> LHsPred Name
+synifyPred (ClassP cls tys) =
+ let sTys = map (synifyType WithinType) tys
+ in noLoc $
+ HsClassP (getName cls) sTys
+synifyPred (IParam ip ty) =
+ let sTy = synifyType WithinType ty
+ -- IPName should be in class NamedThing...
+ in noLoc $
+ HsIParam ip sTy
+synifyPred (EqPred ty1 ty2) =
+ let
+ s1 = synifyType WithinType ty1
+ s2 = synifyType WithinType ty2
+ in noLoc $
+ HsEqualP s1 s2
+
+synifyTyVars :: [TyVar] -> [LHsTyVarBndr Name]
+synifyTyVars = map synifyTyVar
+ where
+ synifyTyVar tv = noLoc $ let
+ kind = tyVarKind tv
+ name = getName tv
+ in if isLiftedTypeKind kind
+ then UserTyVar name
+ else KindedTyVar name kind
+
+--states of what to do with foralls:
+data SynifyTypeState
+ = WithinType
+ -- ^ normal situation. This is the safe one to use if you don't
+ -- quite understand what's going on.
+ | ImplicitizeForAll
+ -- ^ beginning of a function definition, in which, to make it look
+ -- less ugly, those rank-1 foralls are made implicit.
+ | DeleteTopLevelQuantification
+ -- ^ because in class methods the context is added to the type
+ -- (e.g. adding @forall a. Num a =>@ to @(+) :: a -> a -> a@)
+ -- which is rather sensible,
+ -- but we want to restore things to the source-syntax situation where
+ -- the defining class gets to quantify all its functions for free!
+
+synifyType :: SynifyTypeState -> Type -> LHsType Name
+synifyType _ (PredTy{}) = --should never happen.
+ error "synifyType: PredTys are not, in themselves, source-level types."
+synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv)
+synifyType _ (TyConApp tc tys)
+ -- Use non-prefix tuple syntax where possible, because it looks nicer.
+ | isTupleTyCon tc, tyConArity tc == length tys =
+ noLoc $ HsTupleTy (tupleTyConBoxity tc) (map (synifyType WithinType) tys)
+ -- ditto for lists
+ | getName tc == listTyConName, [ty] <- tys =
+ noLoc $ HsListTy (synifyType WithinType ty)
+ -- Most TyCons:
+ | otherwise =
+ foldl (\t1 t2 -> noLoc (HsAppTy t1 t2))
+ (noLoc $ HsTyVar (getName tc))
+ (map (synifyType WithinType) tys)
+synifyType _ (AppTy t1 t2) = let
+ s1 = synifyType WithinType t1
+ s2 = synifyType WithinType t2
+ in noLoc $ HsAppTy s1 s2
+synifyType _ (FunTy t1 t2) = let
+ s1 = synifyType WithinType t1
+ s2 = synifyType WithinType t2
+ in noLoc $ HsFunTy s1 s2
+synifyType s forallty@(ForAllTy _tv _ty) =
+ let (tvs, ctx, tau) = tcSplitSigmaTy forallty
+ in case s of
+ DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau
+ _ -> let
+ forallPlicitness = case s of
+ WithinType -> Explicit
+ ImplicitizeForAll -> Implicit
+ _ -> error "synifyType: impossible case!!!"
+ sTvs = synifyTyVars tvs
+ sCtx = synifyCtx ctx
+ sTau = synifyType WithinType tau
+ in noLoc $
+ HsForAllTy forallPlicitness sTvs sCtx sTau
+
+synifyInstHead :: ([TyVar], [PredType], Class, [Type]) ->
+ ([HsPred Name], Name, [HsType Name])
+synifyInstHead (_, preds, cls, ts) =
+ ( map (unLoc . synifyPred) preds
+ , getName cls
+ , map (unLoc . synifyType WithinType) ts
+ )
diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs
--- a/src/Haddock/GhcUtils.hs
+++ b/src/Haddock/GhcUtils.hs
@@ -22,13 +22,19 @@
import Control.Arrow
import Data.Foldable hiding (concatMap)
import Data.Traversable
+#if __GLASGOW_HASKELL__ >= 611
+import Distribution.Compat.ReadP
+import Distribution.Text
+#endif
-import HsSyn
-import SrcLoc
import Outputable
import Name
import Packages
import Module
+import RdrName (GlobalRdrEnv)
+import HscTypes
+import LazyUniqFM
+import GHC
moduleString :: Module -> String
@@ -44,16 +50,32 @@
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))
-#endif
where pkg = modulePackageId modu
+#if __GLASGOW_HASKELL__ >= 611
+-- This was removed from GHC 6.11
+-- XXX we shouldn't be using it, probably
+-- | Try and interpret a GHC 'PackageId' as a cabal 'PackageIdentifer'. Returns @Nothing@ if
+-- we could not parse it as such an object.
+unpackPackageId :: PackageId -> Maybe PackageIdentifier
+unpackPackageId p
+ = case [ pid | (pid,"") <- readP_to_S parse str ] of
+ [] -> Nothing
+ (pid:_) -> Just pid
+ where str = packageIdString p
+#endif
+
mkModuleNoPackage :: String -> Module
mkModuleNoPackage str = mkModule (stringToPackageId "") (mkModuleName str)
+
+
+lookupLoadedHomeModuleGRE :: GhcMonad m => ModuleName -> m (Maybe GlobalRdrEnv)
+lookupLoadedHomeModuleGRE mod_name = withSession $ \hsc_env ->
+ case lookupUFM (hsc_HPT hsc_env) mod_name of
+ Just mod_info -> return (mi_globals (hm_iface mod_info))
+ _not_a_home_module -> return Nothing
instance (Outputable a, Outputable b) => Outputable (Map.Map a b) where
diff --git a/src/Haddock/HsDoc.hs b/src/Haddock/HsDoc.hs
new file mode 100644
--- /dev/null
+++ b/src/Haddock/HsDoc.hs
@@ -0,0 +1,73 @@
+module Haddock.HsDoc (
+ docAppend,
+ docParagraph
+ ) where
+
+#if __GLASGOW_HASKELL__ <= 610
+
+import HsDoc -- just re-export
+
+#else
+
+import Haddock.Types
+
+import Data.Char (isSpace)
+
+
+-- used to make parsing easier; we group the list items later
+docAppend :: HsDoc id -> HsDoc id -> HsDoc id
+docAppend (DocUnorderedList ds1) (DocUnorderedList ds2)
+ = DocUnorderedList (ds1++ds2)
+docAppend (DocUnorderedList ds1) (DocAppend (DocUnorderedList ds2) d)
+ = DocAppend (DocUnorderedList (ds1++ds2)) d
+docAppend (DocOrderedList ds1) (DocOrderedList ds2)
+ = DocOrderedList (ds1++ds2)
+docAppend (DocOrderedList ds1) (DocAppend (DocOrderedList ds2) d)
+ = DocAppend (DocOrderedList (ds1++ds2)) d
+docAppend (DocDefList ds1) (DocDefList ds2)
+ = DocDefList (ds1++ds2)
+docAppend (DocDefList ds1) (DocAppend (DocDefList ds2) d)
+ = DocAppend (DocDefList (ds1++ds2)) d
+docAppend DocEmpty d = d
+docAppend d DocEmpty = d
+docAppend d1 d2
+ = DocAppend d1 d2
+
+-- again to make parsing easier - we spot a paragraph whose only item
+-- is a DocMonospaced and make it into a DocCodeBlock
+docParagraph :: HsDoc id -> HsDoc id
+docParagraph (DocMonospaced p)
+ = DocCodeBlock (docCodeBlock p)
+docParagraph (DocAppend (DocString s1) (DocMonospaced p))
+ | all isSpace s1
+ = DocCodeBlock (docCodeBlock p)
+docParagraph (DocAppend (DocString s1)
+ (DocAppend (DocMonospaced p) (DocString s2)))
+ | all isSpace s1 && all isSpace s2
+ = DocCodeBlock (docCodeBlock p)
+docParagraph (DocAppend (DocMonospaced p) (DocString s2))
+ | all isSpace s2
+ = DocCodeBlock (docCodeBlock p)
+docParagraph p
+ = DocParagraph p
+
+
+-- Drop trailing whitespace from @..@ code blocks. Otherwise this:
+--
+-- -- @
+-- -- foo
+-- -- @
+--
+-- turns into (DocCodeBlock "\nfoo\n ") which when rendered in HTML
+-- gives an extra vertical space after the code block. The single space
+-- on the final line seems to trigger the extra vertical space.
+--
+docCodeBlock :: HsDoc id -> HsDoc id
+docCodeBlock (DocString s)
+ = DocString (reverse $ dropWhile (`elem` " \t") $ reverse s)
+docCodeBlock (DocAppend l r)
+ = DocAppend l (docCodeBlock r)
+docCodeBlock d = d
+
+#endif
+
diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs
--- a/src/Haddock/Interface.hs
+++ b/src/Haddock/Interface.hs
@@ -42,7 +42,6 @@
-- | 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 :: Verbosity -> [String] -> [Flag] -> [InterfaceFile]
-> Ghc ([Interface], LinkEnv)
createInterfaces verbosity modules flags extIfaces = do
@@ -51,16 +50,7 @@
, iface <- ifInstalledIfaces ext ]
out verbosity verbose "Creating interfaces..."
interfaces <- createInterfaces' verbosity modules flags instIfaceMap
-#else
-createInterfaces :: Verbosity -> Session -> [String] -> [Flag]
- -> [InterfaceFile] -> IO ([Interface], LinkEnv)
-createInterfaces verbosity session modules flags extIfaces = do
- -- part 1, create interfaces
- let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces
- , iface <- ifInstalledIfaces ext ]
- out verbosity verbose "Creating interfaces..."
- interfaces <- createInterfaces' verbosity session modules flags instIfaceMap
-#endif
+
-- part 2, build link environment
out verbosity verbose "Building link environment..."
-- combine the link envs of the external packages into one
@@ -68,11 +58,10 @@
homeLinks = buildHomeLinks interfaces -- build the environment for the home
-- package
links = homeLinks `Map.union` extLinks
- allNames = Map.keys links
-- part 3, attach instances
out verbosity verbose "Attaching instances..."
- let interfaces' = attachInstances interfaces allNames
+ interfaces' <- attachInstances interfaces
-- part 4, rename interfaces
out verbosity verbose "Renaming interfaces..."
@@ -84,7 +73,6 @@
return (interfaces'', homeLinks)
-#if __GLASGOW_HASKELL__ >= 609
createInterfaces' :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface]
createInterfaces' verbosity modules flags instIfaceMap = do
targets <- mapM (\f -> guessTarget f Nothing) modules
@@ -101,9 +89,9 @@
modgraph' <- if needsTemplateHaskell modgraph
then do
dflags <- getSessionDynFlags
- _ <- setSessionDynFlags dflags { hscTarget = HscAsm }
- -- we need to set HscAsm on all the ModSummaries as well
- let addHscAsm m = m { ms_hspp_opts = (ms_hspp_opts m) { hscTarget = HscAsm } }
+ _ <- setSessionDynFlags dflags { hscTarget = defaultObjectTarget }
+ -- we need to set defaultObjectTarget on all the ModSummaries as well
+ let addHscAsm m = m { ms_hspp_opts = (ms_hspp_opts m) { hscTarget = defaultObjectTarget } }
return (map addHscAsm modgraph)
else return modgraph
#else
@@ -113,19 +101,6 @@
let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph' Nothing
(ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do
x <- processModule verbosity modsum flags modMap instIfaceMap
-#else
-createInterfaces' :: Verbosity -> Session -> [String] -> [Flag] -> InstIfaceMap -> IO [Interface]
-createInterfaces' verbosity session modules flags instIfaceMap = 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 dependency graph"
- let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph Nothing
- (ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do
- x <- processModule verbosity session modsum flags modMap instIfaceMap
-#endif
case x of
Just interface ->
return $ (interface : ifaces , Map.insert (ifaceMod interface) interface modMap)
@@ -133,39 +108,7 @@
) ([], 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 :: Verbosity -> ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> Ghc (Maybe Interface)
processModule verbosity modsum flags modMap instIfaceMap = do
out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..."
@@ -183,30 +126,12 @@
moduleInfo tc_mod))
dynflags
out verbosity verbose "Creating interface..."
- let (interface, msg) = runWriter $ createInterface ghcMod flags modMap instIfaceMap
+ (interface, msg) <- runWriterGhc $ createInterface ghcMod flags modMap instIfaceMap
liftIO $ mapM_ putStrLn msg
interface' <- liftIO $ evaluate interface
return (Just interface')
else
return Nothing
-#else
-processModule :: Verbosity -> Session -> ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> IO (Maybe Interface)
-processModule verbosity session modsum flags modMap instIfaceMap = do
- out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..."
- let filename = msHsFilePath modsum
- mbMod <- checkAndLoadModule session modsum False
- if not $ isBootSummary modsum
- then do
- 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 instIfaceMap
- mapM_ putStrLn msg
- return (Just interface)
- else
- return Nothing
-#endif
type CheckedMod = (Module, FilePath, FullyCheckedMod)
@@ -224,8 +149,7 @@
ghcModule = mdl,
ghcFilename = file,
ghcMbDocOpts = mbOpts,
- ghcHaddockModInfo = info,
- ghcMbDoc = mbDoc,
+ ghcMbDocHdr = mbDocHdr,
ghcGroup = group_,
ghcMbExports = mbExports,
ghcExportedNames = modInfoExports modInfo,
@@ -234,12 +158,13 @@
ghcInstances = modInfoInstances modInfo
}
where
-#if __GLASGOW_HASKELL__ == 608 && __GHC_PATCHLEVEL__ == 2
- HsModule _ _ _ _ _ mbOpts _ _ = unLoc parsed
-#else
mbOpts = haddockOptions dynflags
-#endif
+#if __GLASGOW_HASKELL__ >= 611
+ (group_, _, mbExports, mbDocHdr) = renamed
+#else
(group_, _, mbExports, mbDoc, info) = renamed
+ mbDocHdr = (info, mbDoc)
+#endif
(_, renamed, _, modInfo) = checkedMod
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
--- a/src/Haddock/Interface/AttachInstances.hs
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -2,7 +2,9 @@
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.AttachInstances
--- Copyright : (c) David Waern 2006-2009
+-- Copyright : (c) Simon Marlow 2006,
+-- David Waern 2006-2009,
+-- Isaac Dupree 2009
-- License : BSD-like
--
-- Maintainer : haddock@projects.haskell.org
@@ -14,17 +16,18 @@
import Haddock.Types
+import Haddock.Convert
-import qualified Data.Map as Map
-import Data.Map (Map)
import Data.List
import GHC
import Name
import InstEnv
import Class
+import HscTypes (withSession, ioMsg)
+import TcRnDriver (tcRnGetInfo)
-#if __GLASGOW_HASKELL__ >= 610 && __GHC_PATCHLEVEL__ >= 2
+#if __GLASGOW_HASKELL__ > 610 || (__GLASGOW_HASKELL__ == 610 && __GHC_PATCHLEVEL__ >= 2)
import TypeRep hiding (funTyConName)
#else
import TypeRep
@@ -37,24 +40,28 @@
#define FSLIT(x) (mkFastString# (x#))
-attachInstances :: [Interface] -> [Name] -> [Interface]
-attachInstances ifaces filterNames = map attach ifaces
+attachInstances :: [Interface] -> Ghc [Interface]
+attachInstances = mapM attach
where
- instMap =
- fmap (map toHsInstHead . sortImage instHead) $
- collectInstances ifaces filterNames
+ attach iface = do
+ newItems <- mapM attachExport $ ifaceExportItems iface
+ return $ iface { ifaceExportItems = newItems }
- attach iface = iface { ifaceExportItems = newItems }
- where
- newItems = map attachExport (ifaceExportItems iface)
+ attachExport export@ExportDecl{expItemDecl = L _ (TyClD d)} = do
+ mb_info <- getAllInfo (unLoc (tcdLName d))
+ return $ export { expItemInstances = case mb_info of
+ Just (_, _, instances) ->
+ map synifyInstHead . sortImage instHead . map instanceHead $ instances
+ Nothing ->
+ []
+ }
+ attachExport export = return export
- attachExport (ExportDecl decl@(L _ (TyClD d)) doc subs _)
- | isClassDecl d || isDataDecl d || isFamilyDecl d =
- ExportDecl decl doc subs (case Map.lookup (tcdName d) instMap of
- Nothing -> []
- Just instheads -> instheads)
- attachExport export = export
+-- | Like GHC's getInfo but doesn't cut things out depending on the
+-- interative context, which we don't set sufficiently anyway.
+getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance]))
+getAllInfo name = withSession $ \hsc_env -> ioMsg $ tcRnGetInfo hsc_env name
--------------------------------------------------------------------------------
-- Collecting and sorting instances
@@ -63,28 +70,11 @@
-- | Simplified type for sorting types, ignoring qualification (not visible
-- in Haddock output) and unifying special tycons with normal ones.
+-- For the benefit of the user (looks nice and predictable) and the
+-- tests (which prefer output to be deterministic).
data SimpleType = SimpleType Name [SimpleType] deriving (Eq,Ord)
-collectInstances
- :: [Interface]
- -> [Name]
- -> Map Name [([TyVar], [PredType], Class, [Type])] -- maps class/type names to instances
-
-collectInstances ifaces _ -- filterNames
- = Map.fromListWith (flip (++)) tyInstPairs `Map.union`
- Map.fromListWith (flip (++)) classInstPairs
- where
- allInstances = concatMap ifaceInstances ifaces
- classInstPairs = [ (is_cls inst, [instanceHead inst]) |
- inst <- allInstances ]
- -- unfinished filtering of internal instances
- -- Just n <- nub (is_tcs inst) ]
- -- n `elem` filterNames ]
- tyInstPairs = [ (tycon, [instanceHead inst]) | inst <- allInstances,
- Just tycon <- nub (is_tcs inst) ]
-
-
-- TODO: should we support PredTy here?
instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType])
instHead (_, _, cls, args)
@@ -118,44 +108,3 @@
funTyConKey
(ATyCon funTyCon) -- Relevant TyCon
BuiltInSyntax
-
-
-toHsInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name
-toHsInstHead (_, preds, cls, ts) = (map toHsPred preds, className cls, map toHsType ts)
-
-
---------------------------------------------------------------------------------
--- Type -> HsType conversion
---------------------------------------------------------------------------------
-
-
-toHsPred :: PredType -> HsPred Name
-toHsPred (ClassP cls ts) = HsClassP (className cls) (map toLHsType ts)
-toHsPred (IParam n t) = HsIParam n (toLHsType t)
-toHsPred (EqPred t1 t2) = HsEqualP (toLHsType t1) (toLHsType t2)
-
-
-toLHsType :: Type -> Located (HsType Name)
-toLHsType = noLoc . toHsType
-
-
-toHsType :: Type -> HsType Name
-toHsType t = case t of
- TyVarTy v -> HsTyVar (tyVarName v)
- AppTy a b -> HsAppTy (toLHsType a) (toLHsType b)
-
- TyConApp tc ts -> case ts of
- t1:t2:rest
- | isSymOcc . nameOccName . tyConName $ tc ->
- app (HsOpTy (toLHsType t1) (noLoc . tyConName $ tc) (toLHsType t2)) rest
- _ -> app (tycon tc) ts
-
- FunTy a b -> HsFunTy (toLHsType a) (toLHsType b)
- ForAllTy v ty -> cvForAll [v] ty
- PredTy p -> HsPredTy (toHsPred p)
- where
- tycon = HsTyVar . tyConName
- app tc = foldl (\a b -> HsAppTy (noLoc a) (noLoc b)) tc . map toHsType
- cvForAll vs (ForAllTy v ty) = cvForAll (v:vs) ty
- cvForAll vs ty = mkExplicitHsForAllTy (tyvarbinders vs) (noLoc []) (toLHsType ty)
- tyvarbinders = map (noLoc . UserTyVar . tyVarName)
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -17,6 +17,9 @@
import Haddock.Options
import Haddock.GhcUtils
import Haddock.Utils
+import Haddock.Convert
+import Haddock.Interface.LexParseRn
+import Haddock.Interface.ExtractFnArgDocs
import qualified Data.Map as Map
import Data.Map (Map)
@@ -24,39 +27,46 @@
import Data.Maybe
import Data.Ord
import Control.Monad
+import qualified Data.Traversable as Traversable
import GHC hiding (flags)
import Name
import Bag
+import RdrName (GlobalRdrEnv)
-- | Process the data in the GhcModule to produce an interface.
-- To do this, we need access to already processed modules in the topological
-- sort. That's what's in the module map.
createInterface :: GhcModule -> [Flag] -> ModuleMap -> InstIfaceMap
- -> ErrMsgM Interface
+ -> ErrMsgGhc Interface
createInterface ghcMod flags modMap instIfaceMap = do
let mdl = ghcModule ghcMod
- opts0 <- mkDocOpts (ghcMbDocOpts ghcMod) flags mdl
+ -- The pattern-match should not fail, because createInterface is only
+ -- done on loaded modules.
+ Just gre <- liftGhcToErrMsgGhc $ lookupLoadedHomeModuleGRE (moduleName mdl)
+
+ opts0 <- liftErrMsg $ mkDocOpts (ghcMbDocOpts ghcMod) flags mdl
let opts
| Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0
| otherwise = opts0
- let group_ = ghcGroup ghcMod
+ (info, mbDoc) <- liftErrMsg $ lexParseRnHaddockModHeader
+ gre (ghcMbDocHdr ghcMod)
+ decls0 <- liftErrMsg $ declInfos gre (topDecls (ghcGroup ghcMod))
+ let decls = filterOutInstances decls0
+ declMap = mkDeclMap decls
exports = fmap (reverse . map unLoc) (ghcMbExports ghcMod)
localNames = ghcDefinedNames ghcMod
- decls0 = declInfos . topDecls $ group_
- decls = filterOutInstances decls0
- declMap = mkDeclMap decls
ignoreExps = Flag_IgnoreAllExports `elem` flags
exportedNames = ghcExportedNames ghcMod
instances = ghcInstances ghcMod
- warnAboutFilteredDecls mdl decls0
+ liftErrMsg $ warnAboutFilteredDecls mdl decls0
- exportItems <- mkExportItems modMap mdl (ghcExportedNames ghcMod) decls declMap
+ exportItems <- mkExportItems modMap mdl gre (ghcExportedNames ghcMod) decls declMap
opts exports ignoreExps instances instIfaceMap
let visibleNames = mkVisibleNames exportItems opts
@@ -71,8 +81,8 @@
return Interface {
ifaceMod = mdl,
ifaceOrigFilename = ghcFilename ghcMod,
- ifaceInfo = ghcHaddockModInfo ghcMod,
- ifaceDoc = ghcMbDoc ghcMod,
+ ifaceInfo = info,
+ ifaceDoc = mbDoc,
ifaceRnDoc = Nothing,
ifaceOptions = opts,
ifaceLocals = localNames,
@@ -138,35 +148,71 @@
, not (isDocD d), not (isInstD d) ]
-declInfos :: [(Decl, Maybe Doc)] -> [DeclInfo]
-declInfos decls = [ (parent, doc, subordinates d)
- | (parent@(L _ d), doc) <- decls]
+declInfos :: GlobalRdrEnv -> [(Decl, MaybeDocStrings)] -> ErrMsgM [DeclInfo]
+declInfos gre decls =
+ forM decls $ \(parent@(L _ d), mbDocString) -> do
+ mbDoc <- lexParseRnHaddockCommentList NormalHaddockComment
+ gre mbDocString
+ fnArgsDoc <- fmap (Map.mapMaybe id) $
+ Traversable.forM (getDeclFnArgDocs d) $
+ \doc -> lexParseRnHaddockComment NormalHaddockComment gre doc
+ let subs_ = subordinates d
+ subs <- forM subs_ $ \(subName, mbSubDocStr, subFnArgsDocStr) -> do
+ mbSubDoc <- lexParseRnHaddockCommentList NormalHaddockComment
+ gre mbSubDocStr
+ subFnArgsDoc <- fmap (Map.mapMaybe id) $
+ Traversable.forM subFnArgsDocStr $
+ \doc -> lexParseRnHaddockComment NormalHaddockComment gre doc
+ return (subName, (mbSubDoc, subFnArgsDoc))
-subordinates :: HsDecl Name -> [(Name, Maybe Doc)]
+ return (parent, (mbDoc, fnArgsDoc), subs)
+
+
+-- | If you know the HsDecl can't contain any docs
+-- (e.g., it was loaded from a .hi file and you don't have a .haddock file
+-- to help you find out about the subs or docs)
+-- then you can use this to get its subs.
+subordinatesWithNoDocs :: HsDecl Name -> [(Name, DocForDecl Name)]
+subordinatesWithNoDocs decl = map noDocs (subordinates decl)
+ where
+ -- check the condition... or shouldn't we be checking?
+ noDocs (n, doc1, doc2) | null doc1, Map.null doc2
+ = (n, noDocForDecl)
+ noDocs _ = error ("no-docs thing has docs! " ++ pretty decl)
+
+
+subordinates :: HsDecl Name -> [(Name, MaybeDocStrings, Map Int HsDocString)]
subordinates (TyClD d) = classDataSubs d
subordinates _ = []
-classDataSubs :: TyClDecl Name -> [(Name, Maybe Doc)]
+classDataSubs :: TyClDecl Name -> [(Name, MaybeDocStrings, Map Int HsDocString)]
classDataSubs decl
| isClassDecl decl = classSubs
| isDataDecl decl = dataSubs
| otherwise = []
where
- classSubs = [ (declName d, doc) | (L _ d, doc) <- classDecls decl ]
+ classSubs = [ (declName d, doc, fnArgsDoc)
+ | (L _ d, doc) <- classDecls decl
+ , let fnArgsDoc = getDeclFnArgDocs d ]
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)
+ -- should we use the type-signature of the constructor
+ -- and the docs of the fields to produce fnArgsDoc for the constr,
+ -- just in case someone exports it without exporting the type
+ -- and perhaps makes it look like a function? I doubt it.
+ constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c, Map.empty)
+ | c <- cons ]
+ fields = [ (unL n, maybeToList $ fmap unL doc, Map.empty)
| RecCon flds <- map con_details cons
, ConDeclField n _ doc <- flds ]
-- All the sub declarations of a class (that we handle), ordered by
-- source location, with documentation attached if it exists.
-classDecls :: TyClDecl Name -> [(Decl, Maybe Doc)]
+classDecls :: TyClDecl Name -> [(Decl, MaybeDocStrings)]
classDecls = filterDecls . collectDocs . sortByLoc . declsFromClass
@@ -189,7 +235,7 @@
-- | The top-level declarations of a module that we care about,
-- ordered by source location, with documentation attached if it exists.
-topDecls :: HsGroup Name -> [(Decl, Maybe Doc)]
+topDecls :: HsGroup Name -> [(Decl, MaybeDocStrings)]
topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . declsFromGroup
@@ -254,7 +300,7 @@
-- | Filter out declarations that we don't handle in Haddock
-filterDecls :: [(Decl, Maybe Doc)] -> [(Decl, Maybe Doc)]
+filterDecls :: [(Decl, doc)] -> [(Decl, doc)]
filterDecls decls = filter (isHandled . unL . fst) decls
where
isHandled (ForD (ForeignImport {})) = True
@@ -267,7 +313,7 @@
-- | Go through all class declarations and filter their sub-declarations
-filterClasses :: [(Decl, Maybe Doc)] -> [(Decl, Maybe Doc)]
+filterClasses :: [(Decl, doc)] -> [(Decl, doc)]
filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x
| x@(L loc d, doc) <- decls ]
where
@@ -284,12 +330,25 @@
-- declaration.
--------------------------------------------------------------------------------
+type MaybeDocStrings = [HsDocString]
+-- avoid [] because we're appending from the left (quadratic),
+-- and avoid adding another package dependency for haddock,
+-- so use the difference-list pattern
+type MaybeDocStringsFast = MaybeDocStrings -> MaybeDocStrings
+docStringEmpty :: MaybeDocStringsFast
+docStringEmpty = id
+docStringSingleton :: HsDocString -> MaybeDocStringsFast
+docStringSingleton = (:)
+docStringAppend :: MaybeDocStringsFast -> MaybeDocStringsFast -> MaybeDocStringsFast
+docStringAppend = (.)
+docStringToList :: MaybeDocStringsFast -> MaybeDocStrings
+docStringToList = ($ [])
-- | Collect the docs and attach them to the right declaration.
-collectDocs :: [Decl] -> [(Decl, (Maybe Doc))]
-collectDocs = collect Nothing DocEmpty
+collectDocs :: [Decl] -> [(Decl, MaybeDocStrings)]
+collectDocs = collect Nothing docStringEmpty
-collect :: Maybe Decl -> Doc -> [Decl] -> [(Decl, (Maybe Doc))]
+collect :: Maybe Decl -> MaybeDocStringsFast -> [Decl] -> [(Decl, MaybeDocStrings)]
collect d doc_so_far [] =
case d of
Nothing -> []
@@ -299,23 +358,39 @@
case e of
L _ (DocD (DocCommentNext str)) ->
case d of
- Nothing -> collect d (docAppend doc_so_far str) es
- Just d0 -> finishedDoc d0 doc_so_far (collect Nothing str es)
+ Nothing -> collect d
+ (docStringAppend doc_so_far (docStringSingleton str))
+ es
+ Just d0 -> finishedDoc d0 doc_so_far (collect Nothing
+ (docStringSingleton str)
+ es)
- L _ (DocD (DocCommentPrev str)) -> collect d (docAppend doc_so_far str) es
+ L _ (DocD (DocCommentPrev str)) -> collect d
+ (docStringAppend doc_so_far (docStringSingleton str))
+ es
_ -> case d of
Nothing -> collect (Just e) doc_so_far es
- Just d0 -> finishedDoc d0 doc_so_far (collect (Just e) DocEmpty es)
+ Just d0 -> finishedDoc d0 doc_so_far (collect (Just e) docStringEmpty es)
-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
- notDocDecl (L _ (DocD _)) = False
- notDocDecl _ = True
-finishedDoc _ _ rest = rest
+-- This used to delete all DocD:s, unless doc was DocEmpty,
+-- which I suppose means you could kill a DocCommentNamed
+-- by:
+--
+-- > -- | killer
+-- >
+-- > -- $victim
+--
+-- Anyway I accidentally deleted the DocEmpty condition without
+-- realizing it was necessary for retaining some DocDs (at least
+-- DocCommentNamed), so I'm going to try just not testing any conditions
+-- and see if anything breaks. It really shouldn't break anything
+-- to keep more doc decls around, IMHO.
+--
+-- -Isaac
+finishedDoc :: Decl -> MaybeDocStringsFast -> [(Decl, MaybeDocStrings)] -> [(Decl, MaybeDocStrings)]
+finishedDoc d doc rest = (d, docStringToList doc) : rest
{-
@@ -335,6 +410,7 @@
mkExportItems
:: ModuleMap
-> Module -- this module
+ -> GlobalRdrEnv
-> [Name] -- exported names (orig)
-> [DeclInfo]
-> Map Name DeclInfo -- maps local names to declarations
@@ -343,9 +419,9 @@
-> Bool -- --ignore-all-exports flag
-> [Instance]
-> InstIfaceMap
- -> ErrMsgM [ExportItem Name]
+ -> ErrMsgGhc [ExportItem Name]
-mkExportItems modMap this_mod exported_names decls declMap
+mkExportItems modMap this_mod gre exported_names decls declMap
opts maybe_exps ignore_all_exports _ instIfaceMap
| isNothing maybe_exps || ignore_all_exports || OptIgnoreExports `elem` opts
= everything_local_exported
@@ -356,7 +432,7 @@
-- instances = [ d | d@(L _ decl, _, _) <- decls, isInstD decl ]
everything_local_exported = -- everything exported
- return (fullContentsOfThisModule decls)
+ liftErrMsg $ fullContentsOfThisModule gre decls
lookupExport (IEVar x) = declWith x
@@ -370,15 +446,24 @@
lookupExport (IEThingAll t) = declWith t
lookupExport (IEThingWith t _) = declWith t
lookupExport (IEModuleContents m) = fullContentsOf m
- lookupExport (IEGroup lev doc) = return [ ExportGroup lev "" doc ]
- lookupExport (IEDoc doc) = return [ ExportDoc doc ]
- lookupExport (IEDocNamed str) = do
- r <- findNamedDoc str [ unL d | (d,_,_) <- decls ]
- case r of
- Nothing -> return []
- Just found -> return [ ExportDoc found ]
+ lookupExport (IEGroup lev docStr) = liftErrMsg $ do
+ ifDoc (lexParseRnHaddockComment DocSectionComment gre docStr)
+ (\doc -> return [ ExportGroup lev "" doc ])
+ lookupExport (IEDoc docStr) = liftErrMsg $ do
+ ifDoc (lexParseRnHaddockComment NormalHaddockComment gre docStr)
+ (\doc -> return [ ExportDoc doc ])
+ lookupExport (IEDocNamed str) = liftErrMsg $ do
+ ifDoc (findNamedDoc str [ unL d | (d,_,_) <- decls ])
+ (\docStr ->
+ ifDoc (lexParseRnHaddockComment NormalHaddockComment gre docStr)
+ (\doc -> return [ ExportDoc doc ]))
- declWith :: Name -> ErrMsgM [ ExportItem Name ]
+ ifDoc :: (Monad m) => m (Maybe a) -> (a -> m [b]) -> m [b]
+ ifDoc parse finish = do
+ mbDoc <- parse
+ case mbDoc of Nothing -> return []; Just doc -> finish doc
+
+ declWith :: Name -> ErrMsgGhc [ ExportItem Name ]
declWith t =
case findDecl t of
Just x@(decl,_,_) ->
@@ -397,7 +482,7 @@
-- parents is also exported. See note [1].
| t /= declName_,
Just p <- find isExported (parents t $ unL decl) ->
- do tell [
+ do liftErrMsg $ tell [
"Warning: " ++ moduleString this_mod ++ ": " ++
pretty (nameOccName t) ++ " is exported separately but " ++
"will be documented under " ++ pretty (nameOccName p) ++
@@ -407,17 +492,111 @@
-- normal case
| otherwise -> return [ mkExportDecl t x ]
- Nothing ->
- -- If we can't find the declaration, it must belong to another package.
- -- We return just the name of the declaration and try to get the subs
- -- from the installed interface of that package.
- case Map.lookup (nameModule t) instIfaceMap of
- Nothing -> return [ ExportNoDecl t [] ]
- Just iface ->
- let subs = case Map.lookup t (instSubMap iface) of
+ Nothing -> do
+ -- If we can't find the declaration, it must belong to
+ -- another package
+ mbTyThing <- liftGhcToErrMsgGhc $ lookupName t
+ -- show the name as exported as well as the name's
+ -- defining module (because the latter is where we
+ -- looked for the .hi/.haddock). It's to help people
+ -- debugging after all, so good to show more info.
+ let exportInfoString =
+ moduleString this_mod ++ "." ++ getOccString t
+ ++ ": "
+ ++ pretty (nameModule t) ++ "." ++ getOccString t
+
+ case mbTyThing of
+ Nothing -> do
+ liftErrMsg $ tell
+ ["Warning: Couldn't find TyThing for exported "
+ ++ exportInfoString ++ "; not documenting."]
+ -- Is getting to here a bug in Haddock?
+ -- Aren't the .hi files always present?
+ return [ ExportNoDecl t [] ]
+ Just tyThing -> do
+ let hsdecl = tyThingToLHsDecl tyThing
+ -- This is not the ideal way to implement haddockumentation
+ -- for functions/values without explicit type signatures.
+ --
+ -- However I didn't find an easy way to implement it properly,
+ -- and as long as we're using lookupName it is going to find
+ -- the types of local inferenced binds. If we don't check for
+ -- this at all, then we'll get the "warning: couldn't find
+ -- .haddock" which is wrong.
+ --
+ -- The reason this is not an ideal implementation
+ -- (besides that we take a trip to desugared syntax and back
+ -- unnecessarily)
+ -- is that Haddock won't be able to detect doc-strings being
+ -- attached to such a function, such as,
+ --
+ -- > -- | this is an identity function
+ -- > id a = a
+ --
+ -- . It's more difficult to say what it ought to mean in cases
+ -- where multiple exports are bound at once, like
+ --
+ -- > -- | comment...
+ -- > (a, b) = ...
+ --
+ -- especially since in the export-list they might not even
+ -- be next to each other. But a proper implementation would
+ -- really need to find the type of *all* exports as well as
+ -- addressing all these issues. This implementation works
+ -- adequately. Do you see a way to improve the situation?
+ -- Please go ahead! I got stuck trying to figure out how to
+ -- get the 'PostTcType's that we want for all the bindings
+ -- of an HsBind (you get 'LHsBinds' from 'GHC.typecheckedSource'
+ -- for example).
+ --
+ -- But I might be missing something obvious. What's important
+ -- *here* is that we behave reasonably when we run into one of
+ -- those exported type-inferenced values.
+ isLocalAndTypeInferenced <- liftGhcToErrMsgGhc $
+ isLoaded (moduleName (nameModule t))
+ if isLocalAndTypeInferenced
+ then do
+ -- I don't think there can be any subs in this case,
+ -- currently? But better not to rely on it.
+ let subs = subordinatesWithNoDocs (unLoc hsdecl)
+ return [ mkExportDecl t (hsdecl, noDocForDecl, subs) ]
+ else
+ -- We try to get the subs and docs
+ -- from the installed interface of that package.
+ case Map.lookup (nameModule t) instIfaceMap of
+ -- It's Nothing in the cases where I thought
+ -- Haddock has already warned the user: "Warning: The
+ -- documentation for the following packages are not
+ -- installed. No links will be generated to these packages:
+ -- ..."
+ -- But I guess it was Cabal creating that warning. Anyway,
+ -- this is more serious than links: it's exported decls where
+ -- we don't have the docs that they deserve!
+
+ -- We could use 'subordinates' to find the Names of the subs
+ -- (with no docs). Is that necessary? Yes it is, otherwise
+ -- e.g. classes will be shown without their exported subs.
+ Nothing -> do
+ liftErrMsg $ tell
+ ["Warning: Couldn't find .haddock for exported "
+ ++ exportInfoString]
+ let subs = subordinatesWithNoDocs (unLoc hsdecl)
+ return [ mkExportDecl t (hsdecl, noDocForDecl, subs) ]
+ Just iface -> do
+ let subs = case Map.lookup t (instSubMap iface) of
Nothing -> []
Just x -> x
- in return [ ExportNoDecl t subs ]
+ return [ mkExportDecl t
+ ( hsdecl
+ , fromMaybe noDocForDecl $
+ Map.lookup t (instDocMap iface)
+ , map (\subt ->
+ ( subt ,
+ fromMaybe noDocForDecl $
+ Map.lookup subt (instDocMap iface)
+ )
+ ) subs
+ )]
mkExportDecl :: Name -> DeclInfo -> ExportItem Name
mkExportDecl n (decl, doc, subs) = decl'
@@ -430,7 +609,7 @@
isExported n = n `elem` exported_names
fullContentsOf modname
- | m == this_mod = return (fullContentsOfThisModule decls)
+ | m == this_mod = liftErrMsg $ fullContentsOfThisModule gre decls
| otherwise =
case Map.lookup m modMap of
Just iface
@@ -443,7 +622,8 @@
case Map.lookup modname (Map.mapKeys moduleName instIfaceMap) of
Just iface -> return [ ExportModule (instMod iface) ]
Nothing -> do
- tell ["Warning: " ++ pretty this_mod ++ ": Could not find " ++
+ liftErrMsg $
+ tell ["Warning: " ++ pretty this_mod ++ ": Could not find " ++
"documentation for exported module: " ++ pretty modname]
return []
where
@@ -478,14 +658,16 @@
-- (For more information, see Trac #69)
-fullContentsOfThisModule :: [DeclInfo] -> [ExportItem Name]
-fullContentsOfThisModule decls = catMaybes (map mkExportItem decls)
+fullContentsOfThisModule :: GlobalRdrEnv -> [DeclInfo] -> ErrMsgM [ExportItem Name]
+fullContentsOfThisModule gre decls = liftM catMaybes $ mapM mkExportItem decls
where
- 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 subs []
-
--- mkExportItem _ = Nothing -- TODO: see if this is really needed
+ mkExportItem (L _ (DocD (DocGroup lev docStr)), _, _) = do
+ mbDoc <- lexParseRnHaddockComment DocSectionComment gre docStr
+ return $ fmap (\doc -> ExportGroup lev "" doc) mbDoc
+ mkExportItem (L _ (DocD (DocCommentNamed _ docStr)), _, _) = do
+ mbDoc <- lexParseRnHaddockComment NormalHaddockComment gre docStr
+ return $ fmap ExportDoc mbDoc
+ mkExportItem (decl, doc, subs) = return $ Just $ ExportDecl decl doc subs []
-- | Sometimes the declaration we want to export is not the "main" declaration:
@@ -547,7 +729,7 @@
-- Pruning
pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
pruneExportItems items = filter hasDoc items
- where hasDoc (ExportDecl _ d _ _) = isJust d
+ where hasDoc (ExportDecl{expItemMbDoc = (d, _)}) = isJust d
hasDoc _ = True
@@ -567,7 +749,7 @@
-- | Find a stand-alone documentation comment by its name
-findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe Doc)
+findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString)
findNamedDoc name decls = search decls
where
search [] = do
diff --git a/src/Haddock/Interface/ExtractFnArgDocs.hs b/src/Haddock/Interface/ExtractFnArgDocs.hs
new file mode 100644
--- /dev/null
+++ b/src/Haddock/Interface/ExtractFnArgDocs.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE PatternGuards #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Interface.ExtractFnArgDocs
+-- Copyright : (c) Isaac Dupree 2009,
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+
+module Haddock.Interface.ExtractFnArgDocs (
+ getDeclFnArgDocs, getSigFnArgDocs, getTypeFnArgDocs
+) where
+
+import Haddock.Types
+
+import qualified Data.Map as Map
+import Data.Map (Map)
+
+import GHC
+
+-- the type of Name doesn't matter, except in 6.10 where
+-- HsDocString = HsDoc Name, so we can't just say "HsDecl name" yet.
+
+getDeclFnArgDocs :: HsDecl Name -> Map Int HsDocString
+getDeclFnArgDocs (SigD (TypeSig _ ty)) = getTypeFnArgDocs ty
+getDeclFnArgDocs (ForD (ForeignImport _ ty _)) = getTypeFnArgDocs ty
+getDeclFnArgDocs (TyClD (TySynonym {tcdSynRhs = ty})) = getTypeFnArgDocs ty
+getDeclFnArgDocs _ = Map.empty
+
+getSigFnArgDocs :: Sig Name -> Map Int HsDocString
+getSigFnArgDocs (TypeSig _ ty) = getTypeFnArgDocs ty
+getSigFnArgDocs _ = Map.empty
+
+getTypeFnArgDocs :: LHsType Name -> Map Int HsDocString
+getTypeFnArgDocs ty = getLTypeDocs 0 ty
+
+
+getLTypeDocs :: Int -> LHsType Name -> Map Int HsDocString
+getLTypeDocs n (L _ ty) = getTypeDocs n ty
+
+getTypeDocs :: Int -> HsType Name -> Map Int HsDocString
+getTypeDocs n (HsForAllTy _ _ _ ty) = getLTypeDocs n ty
+getTypeDocs n (HsFunTy (L _ (HsDocTy _arg_type (L _ doc))) res_type) =
+ Map.insert n doc $ getLTypeDocs (n+1) res_type
+getTypeDocs n (HsFunTy _ res_type) = getLTypeDocs (n+1) res_type
+getTypeDocs n (HsDocTy _res_type (L _ doc)) = Map.singleton n doc
+getTypeDocs _ _res_type = Map.empty
+
diff --git a/src/Haddock/Interface/Lex.x b/src/Haddock/Interface/Lex.x
new file mode 100644
--- /dev/null
+++ b/src/Haddock/Interface/Lex.x
@@ -0,0 +1,171 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2002
+--
+-- This file was modified and integrated into GHC by David Waern 2006
+--
+
+{
+{-# OPTIONS -Wwarn -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
+module Haddock.Interface.Lex (
+ Token(..),
+ tokenise
+ ) where
+
+import Lexer hiding (Token)
+import Parser ( parseIdentifier )
+import StringBuffer
+import RdrName
+import SrcLoc
+import DynFlags
+
+import Data.Char
+import Numeric
+import System.IO.Unsafe
+}
+
+$ws = $white # \n
+$digit = [0-9]
+$hexdigit = [0-9a-fA-F]
+$special = [\"\@]
+$alphanum = [A-Za-z0-9]
+$ident = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~]
+
+:-
+
+-- beginning of a paragraph
+<0,para> {
+ $ws* \n ;
+ $ws* \> { begin birdtrack }
+ $ws* [\*\-] { token TokBullet `andBegin` string }
+ $ws* \[ { token TokDefStart `andBegin` def }
+ $ws* \( $digit+ \) { token TokNumber `andBegin` string }
+ $ws* { begin string }
+}
+
+-- beginning of a line
+ {
+ $ws* \> { begin birdtrack }
+ $ws* \n { token TokPara `andBegin` para }
+ -- Here, we really want to be able to say
+ -- $ws* (\n | ) { token TokPara `andBegin` para}
+ -- because otherwise a trailing line of whitespace will result in
+ -- a spurious TokString at the end of a docstring. We don't have ,
+ -- though (NOW I realise what it was for :-). To get around this, we always
+ -- append \n to the end of a docstring.
+ () { begin string }
+}
+
+ .* \n? { strtokenNL TokBirdTrack `andBegin` line }
+
+ {
+ $special { strtoken $ \s -> TokSpecial (head s) }
+ \<\<.*\>\> { strtoken $ \s -> TokPic (init $ init $ tail $ tail s) }
+ \<.*\> { strtoken $ \s -> TokURL (init (tail s)) }
+ \#.*\# { strtoken $ \s -> TokAName (init (tail s)) }
+ \/ [^\/]* \/ { strtoken $ \s -> TokEmphasis (init (tail s)) }
+ [\'\`] $ident+ [\'\`] { ident }
+ \\ . { strtoken (TokString . tail) }
+ "&#" $digit+ \; { strtoken $ \s -> TokString [chr (read (init (drop 2 s)))] }
+ "&#" [xX] $hexdigit+ \; { strtoken $ \s -> case readHex (init (drop 3 s)) of [(n,_)] -> TokString [chr n] }
+ -- allow special characters through if they don't fit one of the previous
+ -- patterns.
+ [\/\'\`\<\#\&\\] { strtoken TokString }
+ [^ $special \/ \< \# \n \'\` \& \\ \]]* \n { strtokenNL TokString `andBegin` line }
+ [^ $special \/ \< \# \n \'\` \& \\ \]]+ { strtoken TokString }
+}
+
+ {
+ \] { token TokDefEnd `andBegin` string }
+}
+
+-- ']' doesn't have any special meaning outside of the [...] at the beginning
+-- of a definition paragraph.
+ {
+ \] { strtoken TokString }
+}
+
+{
+data Token
+ = TokPara
+ | TokNumber
+ | TokBullet
+ | TokDefStart
+ | TokDefEnd
+ | TokSpecial Char
+ | TokIdent [RdrName]
+ | TokString String
+ | TokURL String
+ | TokPic String
+ | TokEmphasis String
+ | TokAName String
+ | TokBirdTrack String
+-- deriving Show
+
+-- -----------------------------------------------------------------------------
+-- Alex support stuff
+
+type StartCode = Int
+type Action = String -> StartCode -> (StartCode -> [Token]) -> [Token]
+
+type AlexInput = (Char,String)
+
+alexGetChar (_, []) = Nothing
+alexGetChar (_, c:cs) = Just (c, (c,cs))
+
+alexInputPrevChar (c,_) = c
+
+tokenise :: String -> [Token]
+tokenise str = let toks = go ('\n', eofHack str) para in {-trace (show toks)-} toks
+ where go inp@(_,str) sc =
+ case alexScan inp sc of
+ AlexEOF -> []
+ AlexError _ -> error "lexical error"
+ AlexSkip inp' _ -> go inp' sc
+ AlexToken inp' len act -> act (take len str) sc (\sc -> go inp' sc)
+
+-- NB. we add a final \n to the string, (see comment in the beginning of line
+-- production above).
+eofHack str = str++"\n"
+
+andBegin :: Action -> StartCode -> Action
+andBegin act new_sc = \str _ cont -> act str new_sc cont
+
+token :: Token -> Action
+token t = \_ sc cont -> t : cont sc
+
+strtoken, strtokenNL :: (String -> Token) -> Action
+strtoken t = \str sc cont -> t str : cont sc
+strtokenNL t = \str sc cont -> t (filter (/= '\r') str) : cont sc
+-- ^ We only want LF line endings in our internal doc string format, so we
+-- filter out all CRs.
+
+begin :: StartCode -> Action
+begin sc = \_ _ cont -> cont sc
+
+-- -----------------------------------------------------------------------------
+-- Lex a string as a Haskell identifier
+
+ident :: Action
+ident str sc cont =
+ case strToHsQNames id of
+ Just names -> TokIdent names : cont sc
+ Nothing -> TokString str : cont sc
+ where id = init (tail str)
+
+strToHsQNames :: String -> Maybe [RdrName]
+strToHsQNames str0 =
+ let buffer = unsafePerformIO (stringToStringBuffer str0)
+ pstate = mkPState buffer noSrcLoc defaultDynFlags
+ result = unP parseIdentifier pstate
+ in case result of
+ POk _ name -> Just [unLoc name]
+ _ -> Nothing
+}
diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs
new file mode 100644
--- /dev/null
+++ b/src/Haddock/Interface/LexParseRn.hs
@@ -0,0 +1,89 @@
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Interface.LexParseRn
+-- Copyright : (c) Isaac Dupree 2009,
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+
+module Haddock.Interface.LexParseRn (
+ HaddockCommentType(..),
+ lexParseRnHaddockComment,
+ lexParseRnHaddockCommentList,
+ lexParseRnMbHaddockComment,
+ lexParseRnHaddockModHeader
+ ) where
+
+import Haddock.Types
+
+import Data.Maybe
+
+#if __GLASGOW_HASKELL__ >= 611
+import Haddock.Interface.Lex
+import Haddock.Interface.Parse
+import Haddock.Interface.Rn
+import Haddock.Interface.ParseModuleHeader
+import Haddock.HsDoc
+import FastString
+#endif
+
+import GHC
+import RdrName
+
+data HaddockCommentType = NormalHaddockComment | DocSectionComment
+
+lexParseRnHaddockCommentList :: HaddockCommentType -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (HsDoc Name))
+lexParseRnHaddockCommentList hty gre docStrs = do
+ docMbs <- mapM (lexParseRnHaddockComment hty gre) docStrs
+ let docs = catMaybes docMbs
+ let doc = foldl docAppend DocEmpty docs
+ case doc of
+ DocEmpty -> return Nothing
+ _ -> return (Just doc)
+
+lexParseRnHaddockComment :: HaddockCommentType ->
+ GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (HsDoc Name))
+#if __GLASGOW_HASKELL__ >= 611
+lexParseRnHaddockComment hty gre (HsDocString fs) = do
+ let str = unpackFS fs
+ let toks = tokenise str
+ let parse = case hty of
+ NormalHaddockComment -> parseHaddockParagraphs
+ DocSectionComment -> parseHaddockString
+ case parse toks of
+ Nothing -> do
+ tell ["doc comment parse failed: "++str]
+ return Nothing
+ Just doc -> do
+ return (Just (rnHsDoc gre doc))
+#else
+lexParseRnHaddockComment _ _ doc = return (Just doc)
+#endif
+
+lexParseRnMbHaddockComment :: HaddockCommentType -> GlobalRdrEnv -> Maybe HsDocString -> ErrMsgM (Maybe (HsDoc Name))
+lexParseRnMbHaddockComment _ _ Nothing = return Nothing
+lexParseRnMbHaddockComment hty gre (Just d) = lexParseRnHaddockComment hty gre d
+
+-- yes, you always get a HaddockModInfo though it might be empty
+lexParseRnHaddockModHeader :: GlobalRdrEnv -> GhcDocHdr -> ErrMsgM (HaddockModInfo Name, Maybe (HsDoc Name))
+#if __GLASGOW_HASKELL__ >= 611
+lexParseRnHaddockModHeader gre mbStr = do
+ let failure = (emptyHaddockModInfo, Nothing)
+ case mbStr of
+ Nothing -> return failure
+ Just (L _ (HsDocString fs)) -> do
+ let str = unpackFS fs
+ case parseModuleHeader str of
+ Left mess -> do
+ tell ["haddock module header parse failed: " ++ mess]
+ return failure
+ Right (info, doc) ->
+ return (rnHaddockModInfo gre info, Just (rnHsDoc gre doc))
+#else
+lexParseRnHaddockModHeader _ hdr = return hdr
+#endif
+
diff --git a/src/Haddock/Interface/Parse.y b/src/Haddock/Interface/Parse.y
new file mode 100644
--- /dev/null
+++ b/src/Haddock/Interface/Parse.y
@@ -0,0 +1,106 @@
+{
+{-# OPTIONS -Wwarn -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
+module Haddock.Interface.Parse (
+ parseHaddockParagraphs,
+ parseHaddockString
+) where
+
+import Haddock.Interface.Lex
+import Haddock.Types (HsDoc(..))
+import Haddock.HsDoc
+import HsSyn
+import RdrName
+}
+
+%expect 0
+
+%tokentype { Token }
+
+%token '/' { TokSpecial '/' }
+ '@' { TokSpecial '@' }
+ '[' { TokDefStart }
+ ']' { TokDefEnd }
+ DQUO { TokSpecial '\"' }
+ URL { TokURL $$ }
+ PIC { TokPic $$ }
+ ANAME { TokAName $$ }
+ '/../' { TokEmphasis $$ }
+ '-' { TokBullet }
+ '(n)' { TokNumber }
+ '>..' { TokBirdTrack $$ }
+ IDENT { TokIdent $$ }
+ PARA { TokPara }
+ STRING { TokString $$ }
+
+%monad { Maybe }
+
+%name parseHaddockParagraphs doc
+%name parseHaddockString seq
+
+%%
+
+doc :: { HsDoc RdrName }
+ : apara PARA doc { docAppend $1 $3 }
+ | PARA doc { $2 }
+ | apara { $1 }
+ | {- empty -} { DocEmpty }
+
+apara :: { HsDoc RdrName }
+ : ulpara { DocUnorderedList [$1] }
+ | olpara { DocOrderedList [$1] }
+ | defpara { DocDefList [$1] }
+ | para { $1 }
+
+ulpara :: { HsDoc RdrName }
+ : '-' para { $2 }
+
+olpara :: { HsDoc RdrName }
+ : '(n)' para { $2 }
+
+defpara :: { (HsDoc RdrName, HsDoc RdrName) }
+ : '[' seq ']' seq { ($2, $4) }
+
+para :: { HsDoc RdrName }
+ : seq { docParagraph $1 }
+ | codepara { DocCodeBlock $1 }
+
+codepara :: { HsDoc RdrName }
+ : '>..' codepara { docAppend (DocString $1) $2 }
+ | '>..' { DocString $1 }
+
+seq :: { HsDoc RdrName }
+ : elem seq { docAppend $1 $2 }
+ | elem { $1 }
+
+elem :: { HsDoc RdrName }
+ : elem1 { $1 }
+ | '@' seq1 '@' { DocMonospaced $2 }
+
+seq1 :: { HsDoc RdrName }
+ : PARA seq1 { docAppend (DocString "\n") $2 }
+ | elem1 seq1 { docAppend $1 $2 }
+ | elem1 { $1 }
+
+elem1 :: { HsDoc RdrName }
+ : STRING { DocString $1 }
+ | '/../' { DocEmphasis (DocString $1) }
+ | URL { DocURL $1 }
+ | PIC { DocPic $1 }
+ | ANAME { DocAName $1 }
+ | IDENT { DocIdentifier $1 }
+ | DQUO strings DQUO { DocModule $2 }
+
+strings :: { String }
+ : STRING { $1 }
+ | STRING strings { $1 ++ $2 }
+
+{
+happyError :: [Token] -> Maybe a
+happyError toks = Nothing
+}
diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs
new file mode 100644
--- /dev/null
+++ b/src/Haddock/Interface/ParseModuleHeader.hs
@@ -0,0 +1,158 @@
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Interface.ParseModuleHeader
+-- Copyright : (c) Simon Marlow 2006, Isaac Dupree 2009
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+
+module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where
+
+import Haddock.Types
+import Haddock.Interface.Lex
+import Haddock.Interface.Parse
+
+import RdrName
+
+import Data.Char
+
+-- -----------------------------------------------------------------------------
+-- Parsing module headers
+
+-- NB. The headers must be given in the order Module, Description,
+-- Copyright, License, Maintainer, Stability, Portability, except that
+-- any or all may be omitted.
+parseModuleHeader :: String -> Either String (HaddockModInfo RdrName, HsDoc RdrName)
+parseModuleHeader str0 =
+ let
+ getKey :: String -> String -> (Maybe String,String)
+ getKey key str = case parseKey key str of
+ Nothing -> (Nothing,str)
+ Just (value,rest) -> (Just value,rest)
+
+ (_moduleOpt,str1) = getKey "Module" str0
+ (descriptionOpt,str2) = getKey "Description" str1
+ (_copyrightOpt,str3) = getKey "Copyright" str2
+ (_licenseOpt,str4) = getKey "License" str3
+ (_licenceOpt,str5) = getKey "Licence" str4
+ (maintainerOpt,str6) = getKey "Maintainer" str5
+ (stabilityOpt,str7) = getKey "Stability" str6
+ (portabilityOpt,str8) = getKey "Portability" str7
+
+ description1 :: Either String (Maybe (HsDoc RdrName))
+ description1 = case descriptionOpt of
+ Nothing -> Right Nothing
+ Just description -> case parseHaddockString . tokenise $ description of
+ Nothing -> Left ("Cannot parse Description: " ++ description)
+ Just doc -> Right (Just doc)
+ in
+ case description1 of
+ Left mess -> Left mess
+ Right docOpt -> case parseHaddockParagraphs . tokenise $ str8 of
+ Nothing -> Left "Cannot parse header documentation paragraphs"
+ Just doc -> Right (HaddockModInfo {
+ hmi_description = docOpt,
+ hmi_portability = portabilityOpt,
+ hmi_stability = stabilityOpt,
+ hmi_maintainer = maintainerOpt
+ }, doc)
+
+-- | This function is how we read keys.
+--
+-- all fields in the header are optional and have the form
+--
+-- [spaces1][field name][spaces] ":"
+-- [text]"\n" ([spaces2][space][text]"\n" | [spaces]"\n")*
+-- where each [spaces2] should have [spaces1] as a prefix.
+--
+-- Thus for the key "Description",
+--
+-- > Description : this is a
+-- > rather long
+-- >
+-- > description
+-- >
+-- > The module comment starts here
+--
+-- the value will be "this is a .. description" and the rest will begin
+-- at "The module comment".
+parseKey :: String -> String -> Maybe (String,String)
+parseKey key toParse0 =
+ do
+ let
+ (spaces0,toParse1) = extractLeadingSpaces toParse0
+
+ indentation = spaces0
+ afterKey0 <- extractPrefix key toParse1
+ let
+ afterKey1 = extractLeadingSpaces afterKey0
+ afterColon0 <- case snd afterKey1 of
+ ':':afterColon -> return afterColon
+ _ -> Nothing
+ let
+ (_,afterColon1) = extractLeadingSpaces afterColon0
+
+ return (scanKey True indentation afterColon1)
+ where
+ scanKey :: Bool -> String -> String -> (String,String)
+ scanKey _ _ [] = ([],[])
+ scanKey isFirst indentation str =
+ let
+ (nextLine,rest1) = extractNextLine str
+
+ accept = isFirst || sufficientIndentation || allSpaces
+
+ sufficientIndentation = case extractPrefix indentation nextLine of
+ Just (c:_) | isSpace c -> True
+ _ -> False
+
+ allSpaces = case extractLeadingSpaces nextLine of
+ (_,[]) -> True
+ _ -> False
+ in
+ if accept
+ then
+ let
+ (scanned1,rest2) = scanKey False indentation rest1
+
+ scanned2 = case scanned1 of
+ "" -> if allSpaces then "" else nextLine
+ _ -> nextLine ++ "\n" ++ scanned1
+ in
+ (scanned2,rest2)
+ else
+ ([],str)
+
+ extractLeadingSpaces :: String -> (String,String)
+ extractLeadingSpaces [] = ([],[])
+ extractLeadingSpaces (s@(c:cs))
+ | isSpace c =
+ let
+ (spaces1,cs1) = extractLeadingSpaces cs
+ in
+ (c:spaces1,cs1)
+ | True = ([],s)
+
+ extractNextLine :: String -> (String,String)
+ extractNextLine [] = ([],[])
+ extractNextLine (c:cs)
+ | c == '\n' =
+ ([],cs)
+ | True =
+ let
+ (line,rest) = extractNextLine cs
+ in
+ (c:line,rest)
+
+ -- comparison is case-insensitive.
+ extractPrefix :: String -> String -> Maybe String
+ extractPrefix [] s = Just s
+ extractPrefix _ [] = Nothing
+ extractPrefix (c1:cs1) (c2:cs2)
+ | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2
+ | True = Nothing
+
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -38,8 +38,8 @@
where fn env name = Map.insert name (ifaceMod iface) env
docMap = Map.map (\(_,x,_) -> x) (ifaceDeclMap iface)
- docs = [ (n, doc) | (n, Just doc) <- Map.toList docMap ]
- renameMapElem (k,d) = do d' <- renameDoc d; return (k, d')
+ docs = Map.toList docMap
+ renameMapElem (k,d) = do d' <- renameDocForDecl d; return (k, d')
-- rename names in the exported declarations to point to things that
-- are closer to, or maybe even exported by, the current module.
@@ -141,12 +141,27 @@
renameExportItems = mapM renameExportItem
+renameDocForDecl :: (Maybe (HsDoc Name), FnArgsDoc Name) -> RnM (Maybe (HsDoc DocName), FnArgsDoc DocName)
+renameDocForDecl (mbDoc, fnArgsDoc) = do
+ mbDoc' <- renameMaybeDoc mbDoc
+ fnArgsDoc' <- renameFnArgsDoc fnArgsDoc
+ return (mbDoc', fnArgsDoc')
+
+
renameMaybeDoc :: Maybe (HsDoc Name) -> RnM (Maybe (HsDoc DocName))
renameMaybeDoc = mapM renameDoc
+#if __GLASGOW_HASKELL__ >= 611
+renameLDocHsSyn :: LHsDocString -> RnM LHsDocString
+renameLDocHsSyn = return
+#else
+renameLDocHsSyn :: LHsDoc Name -> RnM (LHsDoc DocName)
+renameLDocHsSyn = renameLDoc
+-- This is inside the #if to avoid a defined-but-not-used warning.
renameLDoc :: LHsDoc Name -> RnM (LHsDoc DocName)
renameLDoc = mapM renameDoc
+#endif
renameDoc :: HsDoc Name -> RnM (HsDoc DocName)
@@ -192,6 +207,10 @@
DocAName str -> return (DocAName str)
+renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName)
+renameFnArgsDoc = mapM renameDoc
+
+
renameLPred :: LHsPred Name -> RnM (LHsPred DocName)
renameLPred = mapM renamePred
@@ -259,7 +278,7 @@
HsDocTy ty doc -> do
ty' <- renameLType ty
- doc' <- renameLDoc doc
+ doc' <- renameLDocHsSyn doc
return (HsDocTy ty' doc')
_ -> error "renameType"
@@ -363,7 +382,7 @@
lcontext' <- renameLContext lcontext
details' <- renameDetails details
restype' <- renameResType restype
- mbldoc' <- mapM renameLDoc mbldoc
+ mbldoc' <- mapM renameLDocHsSyn mbldoc
return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext'
, con_details = details', con_res = restype', con_doc = mbldoc' })
@@ -377,7 +396,7 @@
renameField (ConDeclField name t doc) = do
name' <- renameL name
t' <- renameLType t
- doc' <- mapM renameLDoc doc
+ doc' <- mapM renameLDocHsSyn doc
return (ConDeclField name' t' doc')
renameResType (ResTyH98) = return ResTyH98
@@ -427,7 +446,7 @@
return (ExportGroup lev id_ doc')
ExportDecl decl doc subs instances -> do
decl' <- renameLDecl decl
- doc' <- mapM renameDoc doc
+ doc' <- renameDocForDecl doc
subs' <- mapM renameSub subs
instances' <- mapM renameInstHead instances
return (ExportDecl decl' doc' subs' instances')
@@ -440,8 +459,8 @@
return (ExportDoc doc')
-renameSub :: (Name, Maybe (HsDoc Name)) -> RnM (DocName, Maybe (HsDoc DocName))
+renameSub :: (Name, DocForDecl Name) -> RnM (DocName, DocForDecl DocName)
renameSub (n,doc) = do
n' <- rename n
- doc' <- mapM renameDoc doc
+ doc' <- renameDocForDecl doc
return (n', doc')
diff --git a/src/Haddock/Interface/Rn.hs b/src/Haddock/Interface/Rn.hs
new file mode 100644
--- /dev/null
+++ b/src/Haddock/Interface/Rn.hs
@@ -0,0 +1,82 @@
+
+module Haddock.Interface.Rn ( rnHsDoc, rnHaddockModInfo ) where
+
+import Haddock.Types
+
+import RnEnv ( dataTcOccs )
+
+import RdrName ( RdrName, gre_name, GlobalRdrEnv, lookupGRE_RdrName )
+import Name ( Name )
+import Outputable ( ppr, defaultUserStyle )
+
+rnHaddockModInfo :: GlobalRdrEnv -> HaddockModInfo RdrName -> HaddockModInfo Name
+rnHaddockModInfo gre (HaddockModInfo desc port stab maint) =
+ HaddockModInfo (fmap (rnHsDoc gre) desc) port stab maint
+
+ids2string :: [RdrName] -> String
+ids2string [] = []
+ids2string (x:_) = show $ ppr x defaultUserStyle
+
+data Id x = Id {unId::x}
+instance Monad Id where (Id v)>>=f = f v; return = Id
+
+rnHsDoc :: GlobalRdrEnv -> HsDoc RdrName -> HsDoc Name
+rnHsDoc gre = unId . do_rn
+ where
+ do_rn doc_to_rn = case doc_to_rn of
+
+ DocEmpty -> return DocEmpty
+
+ DocAppend a b -> do
+ a' <- do_rn a
+ b' <- do_rn b
+ return (DocAppend a' b')
+
+ DocString str -> return (DocString str)
+
+ DocParagraph doc -> do
+ doc' <- do_rn doc
+ return (DocParagraph doc')
+
+ DocIdentifier ids -> do
+ let choices = concatMap dataTcOccs ids
+ let gres = concatMap (\rdrName ->
+ map gre_name (lookupGRE_RdrName rdrName gre)) choices
+ case gres of
+ [] -> return (DocString (ids2string ids))
+ ids' -> return (DocIdentifier ids')
+
+ DocModule str -> return (DocModule str)
+
+ DocEmphasis doc -> do
+ doc' <- do_rn doc
+ return (DocEmphasis doc')
+
+ DocMonospaced doc -> do
+ doc' <- do_rn doc
+ return (DocMonospaced doc')
+
+ DocUnorderedList docs -> do
+ docs' <- mapM do_rn docs
+ return (DocUnorderedList docs')
+
+ DocOrderedList docs -> do
+ docs' <- mapM do_rn docs
+ return (DocOrderedList docs')
+
+ DocDefList list -> do
+ list' <- mapM (\(a,b) -> do
+ a' <- do_rn a
+ b' <- do_rn b
+ return (a', b')) list
+ return (DocDefList list')
+
+ DocCodeBlock doc -> do
+ doc' <- do_rn doc
+ return (DocCodeBlock doc')
+
+ DocURL str -> return (DocURL str)
+
+ DocPic str -> return (DocPic str)
+
+ DocAName str -> return (DocAName str)
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -27,6 +27,7 @@
import Data.Array
import Data.IORef
import qualified Data.Map as Map
+import Data.Map (Map)
import GHC hiding (NoLink)
import Binary
@@ -36,10 +37,8 @@
import IfaceEnv
import HscTypes
import FastMutInt
-#if __GLASGOW_HASKELL__ >= 609
import FastString
import Unique
-#endif
data InterfaceFile = InterfaceFile {
ifLinkEnv :: LinkEnv,
@@ -56,9 +55,15 @@
-- we version our interface files accordingly.
binaryInterfaceVersion :: Word16
#if __GLASGOW_HASKELL__ == 610
-binaryInterfaceVersion = 12
+binaryInterfaceVersion = 14
#elif __GLASGOW_HASKELL__ == 611
-binaryInterfaceVersion = 13
+binaryInterfaceVersion = 15
+#elif __GLASGOW_HASKELL__ == 612
+binaryInterfaceVersion = 15
+#elif __GLASGOW_HASKELL__ == 613
+binaryInterfaceVersion = 15
+#else
+#error Unknown GHC version
#endif
@@ -81,7 +86,6 @@
put_ bh0 symtab_p_p
-- Make some intial state
-#if __GLASGOW_HASKELL__ >= 609
symtab_next <- newFastMutInt
writeFastMutInt symtab_next 0
symtab_map <- newIORef emptyUFM
@@ -95,9 +99,6 @@
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 bh0 ud
@@ -109,13 +110,8 @@
seekBin bh symtab_p
-- write the symbol table itself
-#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
@@ -124,13 +120,8 @@
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
-- and send the result to the file
@@ -140,7 +131,6 @@
type NameCacheAccessor m = (m NameCache, NameCache -> m ())
-#if __GLASGOW_HASKELL__ >= 609
nameCacheFromGhc :: NameCacheAccessor Ghc
nameCacheFromGhc = ( read_from_session , write_to_session )
where
@@ -150,15 +140,6 @@
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
@@ -233,7 +214,6 @@
-------------------------------------------------------------------------------
-#if __GLASGOW_HASKELL__ >= 609
putName :: BinSymbolTable -> BinHandle -> Name -> IO ()
putName BinSymbolTable{
bin_symtab_map = symtab_map_ref,
@@ -241,13 +221,13 @@
= do
symtab_map <- readIORef symtab_map_ref
case lookupUFM symtab_map name of
- Just (off,_) -> put_ bh off
+ Just (off,_) -> put_ bh (fromIntegral off :: Word32)
Nothing -> do
off <- readFastMutInt symtab_next
writeFastMutInt symtab_next (off+1)
writeIORef symtab_map_ref
$! addToUFM symtab_map name (off,name)
- put_ bh off
+ put_ bh (fromIntegral off :: Word32)
data BinSymbolTable = BinSymbolTable {
@@ -264,10 +244,10 @@
out <- readIORef out_r
let unique = getUnique f
case lookupUFM out unique of
- Just (j, _) -> put_ bh j
+ Just (j, _) -> put_ bh (fromIntegral j :: Word32)
Nothing -> do
j <- readFastMutInt j_r
- put_ bh j
+ put_ bh (fromIntegral j :: Word32)
writeFastMutInt j_r (j + 1)
writeIORef out_r $! addToUFM out unique (j, f)
@@ -277,7 +257,6 @@
bin_dict_map :: !(IORef (UniqFM (Int,FastString)))
-- indexed by FastString
}
-#endif
putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
@@ -332,27 +311,33 @@
-- GhcBinary instances
-------------------------------------------------------------------------------
+-- Hmm, why didn't we dare to make this instance already? It makes things
+-- much easier.
+instance (Ord k, Binary k, Binary v) => Binary (Map k v) where
+ put_ bh m = put_ bh (Map.toList m)
+ get bh = fmap (Map.fromList) (get bh)
+
instance Binary InterfaceFile where
put_ bh (InterfaceFile env ifaces) = do
- put_ bh (Map.toList env)
+ put_ bh env
put_ bh ifaces
get bh = do
env <- get bh
ifaces <- get bh
- return (InterfaceFile (Map.fromList env) ifaces)
+ return (InterfaceFile env ifaces)
instance Binary InstalledInterface where
put_ bh (InstalledInterface modu info docMap exps visExps opts subMap) = do
put_ bh modu
put_ bh info
- put_ bh (Map.toList docMap)
+ put_ bh docMap
put_ bh exps
put_ bh visExps
put_ bh opts
- put_ bh (Map.toList subMap)
+ put_ bh subMap
get bh = do
modu <- get bh
@@ -363,8 +348,8 @@
opts <- get bh
subMap <- get bh
- return (InstalledInterface modu info (Map.fromList docMap)
- exps visExps opts (Map.fromList subMap))
+ return (InstalledInterface modu info docMap
+ exps visExps opts subMap)
instance Binary DocOption where
diff --git a/src/Haddock/ModuleTree.hs b/src/Haddock/ModuleTree.hs
--- a/src/Haddock/ModuleTree.hs
+++ b/src/Haddock/ModuleTree.hs
@@ -12,13 +12,11 @@
module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where
-import GHC ( HsDoc, Name )
+import Haddock.Types ( HsDoc )
+
+import GHC ( Name )
import Module ( Module, moduleNameString, moduleName, modulePackageId )
-#if __GLASGOW_HASKELL__ >= 609
import Module (packageIdString)
-#else
-import PackageConfig (packageIdString)
-#endif
data ModuleTree = Node String Bool (Maybe String) (Maybe (HsDoc Name)) [ModuleTree]
diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs
--- a/src/Haddock/Options.hs
+++ b/src/Haddock/Options.hs
@@ -91,6 +91,7 @@
| Flag_OptGhc String
| Flag_GhcLibDir String
| Flag_GhcVersion
+ | Flag_PrintGhcLibDir
| Flag_NoWarnings
| Flag_UseUnicode
deriving (Eq)
@@ -161,5 +162,7 @@
"option to be forwarded to GHC",
Option [] ["ghc-version"] (NoArg Flag_GhcVersion)
"output GHC version in numeric format",
+ Option [] ["print-ghc-libdir"] (NoArg Flag_PrintGhcLibDir)
+ "output GHC lib dir",
Option ['w'] ["no-warnings"] (NoArg Flag_NoWarnings) "turn off all warnings"
]
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -15,12 +15,22 @@
-- important types are defined here, like 'Interface' and 'DocName'.
-----------------------------------------------------------------------------
-module Haddock.Types where
+module Haddock.Types (
+ module Haddock.Types
+-- avoid duplicate-export warnings, use the conditional to only
+-- mention things not defined in this module:
+#if __GLASGOW_HASKELL__ >= 611
+ , HsDocString, LHsDocString
+#else
+ , HsDoc(..), LHsDoc, HaddockModInfo(..), emptyHaddockModInfo
+#endif
+ ) where
import Control.Exception
import Data.Typeable
import Data.Map (Map)
+import qualified Data.Map as Map
import GHC hiding (NoLink)
import Name
@@ -29,10 +39,22 @@
type Decl = LHsDecl Name
type Doc = HsDoc Name
+#if __GLASGOW_HASKELL__ <= 610
+type HsDocString = HsDoc Name
+type LHsDocString = Located HsDocString
+#endif
+-- | Arguments and result are indexed by Int, zero-based from the left,
+-- because that's the easiest to use when recursing over types.
+type FnArgsDoc name = Map Int (HsDoc name)
+type DocForDecl name = (Maybe (HsDoc name), FnArgsDoc name)
+
+noDocForDecl :: DocForDecl name
+noDocForDecl = (Nothing, Map.empty)
+
-- | A declaration that may have documentation, including its subordinates,
-- which may also have documentation
-type DeclInfo = (Decl, Maybe Doc, [(Name, Maybe Doc)])
+type DeclInfo = (Decl, DocForDecl Name, [(Name, DocForDecl Name)])
-- | A 'DocName' is an identifier that may be documented. The 'Module'
@@ -68,11 +90,12 @@
-- | A declaration
expItemDecl :: LHsDecl name,
- -- | Maybe a doc comment
- expItemMbDoc :: Maybe (HsDoc name),
+ -- | Maybe a doc comment, and possibly docs for arguments (if this
+ -- decl is a function or type-synonym)
+ expItemMbDoc :: DocForDecl name,
-- | Subordinate names, possibly with documentation
- expItemSubDocs :: [(name, Maybe (HsDoc name))],
+ expItemSubDocs :: [(name, DocForDecl name)],
-- | Instances relevant to this declaration
expItemInstances :: [InstHead name]
@@ -113,6 +136,11 @@
type DocMap = Map Name (HsDoc DocName)
type LinkEnv = Map Name Module
+#if __GLASGOW_HASKELL__ >= 611
+type GhcDocHdr = Maybe LHsDocString
+#else
+type GhcDocHdr = (HaddockModInfo Name, Maybe (HsDoc Name))
+#endif
-- | This structure holds the module information we get from GHC's
-- type checking phase
@@ -120,8 +148,7 @@
ghcModule :: Module,
ghcFilename :: FilePath,
ghcMbDocOpts :: Maybe String,
- ghcHaddockModInfo :: HaddockModInfo Name,
- ghcMbDoc :: Maybe (HsDoc Name),
+ ghcMbDocHdr :: GhcDocHdr,
ghcGroup :: HsGroup Name,
ghcMbExports :: Maybe [LIE Name],
ghcExportedNames :: [Name],
@@ -161,7 +188,7 @@
ifaceDeclMap :: Map Name DeclInfo,
-- | Everything declared in the module (including subordinates) that has docs
- ifaceRnDocMap :: Map Name (HsDoc DocName),
+ ifaceRnDocMap :: Map Name (DocForDecl DocName),
ifaceSubMap :: Map Name [Name],
@@ -202,7 +229,7 @@
instInfo :: HaddockModInfo Name,
-- | Everything declared in the module (including subordinates) that has docs
- instDocMap :: Map Name (HsDoc DocName),
+ instDocMap :: Map Name (DocForDecl Name),
-- | All names exported by this module
instExports :: [Name],
@@ -231,14 +258,41 @@
toInstalledIface interface = InstalledInterface {
instMod = ifaceMod interface,
instInfo = ifaceInfo interface,
- instDocMap = ifaceRnDocMap interface,
+ instDocMap = fmap unrenameDocForDecl $ ifaceRnDocMap interface,
instExports = ifaceExports interface,
instVisibleExports = ifaceVisibleExports interface,
instOptions = ifaceOptions interface,
instSubMap = ifaceSubMap interface
}
+unrenameHsDoc :: HsDoc DocName -> HsDoc Name
+unrenameHsDoc = fmapHsDoc getName
+unrenameDocForDecl :: DocForDecl DocName -> DocForDecl Name
+unrenameDocForDecl (mbDoc, fnArgsDoc) =
+ (fmap unrenameHsDoc mbDoc, fmap unrenameHsDoc fnArgsDoc)
+#if __GLASGOW_HASKELL__ >= 611
+data HsDoc id
+ = DocEmpty
+ | DocAppend (HsDoc id) (HsDoc id)
+ | DocString String
+ | DocParagraph (HsDoc id)
+ | DocIdentifier [id]
+ | DocModule String
+ | DocEmphasis (HsDoc id)
+ | DocMonospaced (HsDoc id)
+ | DocUnorderedList [HsDoc id]
+ | DocOrderedList [HsDoc id]
+ | DocDefList [(HsDoc id, HsDoc id)]
+ | DocCodeBlock (HsDoc id)
+ | DocURL String
+ | DocPic String
+ | DocAName String
+ deriving (Eq, Show)
+
+type LHsDoc id = Located (HsDoc id)
+#endif
+
data DocMarkup id a = Markup {
markupEmpty :: a,
markupString :: String -> a,
@@ -257,13 +311,33 @@
markupPic :: String -> a
}
+#if __GLASGOW_HASKELL__ >= 611
+data HaddockModInfo name = HaddockModInfo {
+ hmi_description :: Maybe (HsDoc name),
+ hmi_portability :: Maybe String,
+ hmi_stability :: Maybe String,
+ hmi_maintainer :: Maybe String
+}
+emptyHaddockModInfo :: HaddockModInfo a
+emptyHaddockModInfo = HaddockModInfo {
+ hmi_description = Nothing,
+ hmi_portability = Nothing,
+ hmi_stability = Nothing,
+ hmi_maintainer = Nothing
+}
+#endif
+
+
-- A monad which collects error messages, locally defined to avoid a dep on mtl
type ErrMsg = String
newtype ErrMsgM a = Writer { runWriter :: (a, [ErrMsg]) }
+instance Functor ErrMsgM where
+ fmap f (Writer (a, msgs)) = Writer (f a, msgs)
+
instance Monad ErrMsgM where
return a = Writer (a, [])
m >>= k = Writer $ let
@@ -286,9 +360,48 @@
throwE :: String -> a
-#if __GLASGOW_HASKELL__ >= 609
instance Exception HaddockException
throwE str = throw (HaddockException str)
-#else
-throwE str = throwDyn (HaddockException str)
-#endif
+
+-- In "Haddock.Interface.Create", we need to gather
+-- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does,
+-- but we can't just use @GhcT ErrMsgM@ because GhcT requires the
+-- transformed monad to be MonadIO.
+newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: (Ghc (a, [ErrMsg])) }
+--instance MonadIO ErrMsgGhc where
+-- liftIO = WriterGhc . fmap (\a->(a,[])) liftIO
+--er, implementing GhcMonad involves annoying ExceptionMonad and
+--WarnLogMonad classes, so don't bother.
+liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a
+liftGhcToErrMsgGhc = WriterGhc . fmap (\a->(a,[]))
+liftErrMsg :: ErrMsgM a -> ErrMsgGhc a
+liftErrMsg = WriterGhc . return . runWriter
+-- for now, use (liftErrMsg . tell) for this
+--tell :: [ErrMsg] -> ErrMsgGhc ()
+--tell msgs = WriterGhc $ return ( (), msgs )
+instance Functor ErrMsgGhc where
+ fmap f (WriterGhc x) = WriterGhc (fmap (\(a,msgs)->(f a,msgs)) x)
+instance Monad ErrMsgGhc where
+ return a = WriterGhc (return (a, []))
+ m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) ->
+ fmap (\ (b, msgs2) -> (b, msgs1 ++ msgs2)) (runWriterGhc (k a))
+
+-- When HsDoc syntax is part of the Haddock codebase, we'll just
+-- declare a Functor instance.
+fmapHsDoc :: (a->b) -> HsDoc a -> HsDoc b
+fmapHsDoc _ DocEmpty = DocEmpty
+fmapHsDoc f (DocAppend a b) = DocAppend (fmapHsDoc f a) (fmapHsDoc f b)
+fmapHsDoc _ (DocString s) = DocString s
+fmapHsDoc _ (DocModule s) = DocModule s
+fmapHsDoc _ (DocURL s) = DocURL s
+fmapHsDoc _ (DocPic s) = DocPic s
+fmapHsDoc _ (DocAName s) = DocAName s
+fmapHsDoc f (DocParagraph a) = DocParagraph (fmapHsDoc f a)
+fmapHsDoc f (DocEmphasis a) = DocEmphasis (fmapHsDoc f a)
+fmapHsDoc f (DocMonospaced a) = DocMonospaced (fmapHsDoc f a)
+fmapHsDoc f (DocCodeBlock a) = DocMonospaced (fmapHsDoc f a)
+fmapHsDoc f (DocIdentifier a) = DocIdentifier (map f a)
+fmapHsDoc f (DocOrderedList a) = DocOrderedList (map (fmapHsDoc f) a)
+fmapHsDoc f (DocUnorderedList a) = DocUnorderedList (map (fmapHsDoc f) a)
+fmapHsDoc f (DocDefList a) = DocDefList (map (\(b,c)->(fmapHsDoc f b, fmapHsDoc f c)) a)
+
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -76,13 +76,7 @@
import Distribution.Verbosity
import Distribution.ReadE
-#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
-- -----------------------------------------------------------------------------
diff --git a/src/Main.hs b/src/Main.hs
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -22,28 +22,23 @@
import Haddock.Backends.Html
import Haddock.Backends.Hoogle
import Haddock.Interface
+import Haddock.Interface.Lex
+import Haddock.Interface.Parse
import Haddock.Types
import Haddock.Version
import Haddock.InterfaceFile
import Haddock.Options
import Haddock.Utils
import Haddock.GhcUtils
-import Paths_haddock
import Control.Monad
-#if __GLASGOW_HASKELL__ >= 609
-import Control.OldException
-import qualified Control.Exception as NewException
-#else
import Control.Exception
-#endif
import Data.Maybe
import Data.IORef
import qualified Data.Map as Map
import System.IO
import System.Exit
import System.Environment
-import System.FilePath
import Distribution.Verbosity
#if defined(mingw32_HOST_OS)
@@ -52,19 +47,17 @@
import Data.Int
#endif
-#ifndef IN_GHC_TREE
+#ifdef IN_GHC_TREE
+import System.FilePath
+#else
import GHC.Paths
+import Paths_haddock
#endif
import GHC hiding (flags, verbosity)
import Config
import DynFlags hiding (flags, verbosity)
-#if __GLASGOW_HASKELL__ >= 609
import Panic (handleGhcException)
-import MonadUtils ( MonadIO(..) )
-#else
-import Util hiding (handle)
-#endif
--------------------------------------------------------------------------------
@@ -76,29 +69,25 @@
handleTopExceptions =
handleNormalExceptions . handleHaddockExceptions . handleGhcExceptions
-
+-- | Either returns normally or throws an ExitCode exception;
+-- all other exceptions are turned into exit exceptions.
handleNormalExceptions :: IO a -> IO a
handleNormalExceptions inner =
- handle (\exception -> do
- hFlush stdout
- case exception of
- AsyncException StackOverflow -> do
+ (inner `onException` hFlush stdout)
+ `catches`
+ [ Handler (\(code :: ExitCode) -> exitWith code)
+ , Handler (\(StackOverflow) -> do
putStrLn "stack overflow: use -g +RTS -K to increase it"
- exitFailure
- ExitException code -> exitWith code
- _other -> do
- putStrLn ("haddock: internal Haddock or GHC error: " ++ show exception)
- exitFailure
- ) inner
+ exitFailure)
+ , Handler (\(ex :: SomeException) -> do
+ putStrLn ("haddock: internal Haddock or GHC error: " ++ show ex)
+ exitFailure)
+ ]
handleHaddockExceptions :: IO a -> IO a
handleHaddockExceptions inner =
-#if __GLASGOW_HASKELL__ >= 609
- NewException.catches inner [NewException.Handler handler]
-#else
- handleDyn handler inner
-#endif
+ catches inner [Handler handler]
where
handler (e::HaddockException) = do
putStrLn $ "haddock: " ++ (show e)
@@ -107,21 +96,8 @@
handleGhcExceptions :: IO a -> IO a
handleGhcExceptions inner =
- -- compilation errors: messages with locations attached
-#if __GLASGOW_HASKELL__ < 609
- handleDyn (\e -> do
- putStrLn "haddock: Compilation error(s):"
- printBagOfErrors defaultDynFlags (unitBag e)
- exitFailure
- ) $
-#endif
-
-- error messages propagated as exceptions
-#if __GLASGOW_HASKELL__ >= 609
handleGhcException (\e -> do
-#else
- handleDyn (\e -> do
-#endif
hFlush stdout
case e of
PhaseFailed _ code -> exitWith code
@@ -155,23 +131,8 @@
if not (null fileArgs)
then do
- 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"
-#ifdef NEW_GHC_LAYOUT
- Just d -> return (d ".." "lib")
-#else
- Just d -> return (d "..")
-#endif
-#else
- return libdir -- from GHC.Paths
-#endif
+ libDir <- getGhcLibDir flags
-#if __GLASGOW_HASKELL__ >= 609
-- We have one global error handler for all GHC source errors. Other kinds
-- of exceptions will be propagated to the top-level error handler.
let handleSrcErrors action = flip handleSourceError action $ \err -> do
@@ -195,23 +156,7 @@
-- last but not least, dump the interface file
dumpInterfaceFile (map toInstalledIface interfaces) homeLinks flags
-#else
- -- initialize GHC
- (session, dynflags) <- startGhc libDir (ghcFlags flags)
- -- get packages supplied with --read-interface
- packages <- readInterfaceFiles (nameCacheFromGhc session) (ifacePairs flags)
-
- -- create the interfaces -- this is the core part of Haddock
- (interfaces, homeLinks) <- createInterfaces verbosity session fileArgs flags
- (map fst packages)
-
- -- render the interfaces
- renderStep packages interfaces
-
- -- last but not least, dump the interface file
- dumpInterfaceFile (map toInstalledIface interfaces) homeLinks flags
-#endif
else do
-- get packages supplied with --read-interface
packages <- readInterfaceFiles freshNameCache (ifacePairs flags)
@@ -241,21 +186,7 @@
,listToMaybe [str | Flag_WikiModuleURL str <- flags]
,listToMaybe [str | Flag_WikiEntityURL str <- flags])
- libDir <- case [str | Flag_Lib str <- flags] of
- [] ->
-#ifdef IN_GHC_TREE
- do m <- getExecDir
- case m of
- Nothing -> error "No libdir found"
-#ifdef NEW_GHC_LAYOUT
- Just d -> return (d ".." "lib")
-#else
- Just d -> return (d "..")
-#endif
-#else
- getDataDir -- provided by Cabal
-#endif
- fs -> return (last fs)
+ libDir <- getHaddockLibDir flags
let unicode = Flag_UseUnicode `elem` flags
let css_file = case [str | Flag_CSS str <- flags] of
[] -> Nothing
@@ -365,21 +296,12 @@
-- | 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
- do
-#endif
let dynflags' = dopt_set dynflags Opt_Haddock
let dynflags'' = dynflags' {
hscTarget = HscNothing,
@@ -388,23 +310,17 @@
}
dynflags''' <- parseGhcFlags dynflags'' restFlags flags
defaultCleanupHandler dynflags''' $ do
-#if __GLASGOW_HASKELL__ >= 609
- setSessionDynFlags dynflags'''
+ -- ignore the following return-value, which is a list of packages
+ -- that may need to be re-linked: Haddock doesn't do any
+ -- dynamic or static linking at all!
+ _ <- setSessionDynFlags dynflags'''
ghcActs dynflags'''
-#else
- setSessionDynFlags session dynflags'''
- return (session, dynflags''')
-#endif
where
parseGhcFlags :: Monad m => DynFlags -> [Located String]
-> [String] -> m DynFlags
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'
@@ -414,12 +330,27 @@
-- Misc
-------------------------------------------------------------------------------
+getHaddockLibDir :: [Flag] -> IO String
+getHaddockLibDir flags = do
+ case [str | Flag_Lib str <- flags] of
+ [] ->
+#ifdef IN_GHC_TREE
+ getInTreeLibDir
+#else
+ getDataDir -- provided by Cabal
+#endif
+ fs -> return (last fs)
-getGhcLibDir :: [Flag] -> Maybe String
-getGhcLibDir flags =
+getGhcLibDir :: [Flag] -> IO String
+getGhcLibDir flags = do
case [ dir | Flag_GhcLibDir dir <- flags ] of
- [] -> Nothing
- xs -> Just $ last xs
+ [] ->
+#ifdef IN_GHC_TREE
+ getInTreeLibDir
+#else
+ return libdir -- from GHC.Paths
+#endif
+ xs -> return $ last xs
getVerbosity :: Monad m => [Flag] -> m Verbosity
@@ -435,10 +366,14 @@
handleEasyFlags flags = do
usage <- getUsage
- when (Flag_Help `elem` flags) (bye usage)
- when (Flag_Version `elem` flags) byeVersion
- when (Flag_GhcVersion `elem` flags) byeGhcVersion
+ when (Flag_Help `elem` flags) (bye usage)
+ when (Flag_Version `elem` flags) byeVersion
+ when (Flag_GhcVersion `elem` flags) byeGhcVersion
+ when (Flag_PrintGhcLibDir `elem` flags) $ do
+ dir <- getGhcLibDir flags
+ bye $ dir ++ "\n"
+
when (Flag_UseUnicode `elem` flags && not (Flag_Html `elem` flags)) $
throwE ("Unicode can only be enabled for HTML output.")
@@ -467,12 +402,25 @@
[] -> return Nothing
[filename] -> do
str <- readFile filename
- case parseHaddockComment str of
- Left err -> throwE err
- Right doc -> return (Just doc)
+ case parseHaddockParagraphs (tokenise str) of
+ Nothing -> throwE "parsing haddock prologue failed"
+ Just doc -> return (Just doc)
_otherwise -> throwE "multiple -p/--prologue options"
+#ifdef IN_GHC_TREE
+
+getInTreeLibDir :: IO String
+getInTreeLibDir =
+ do m <- getExecDir
+ case m of
+ Nothing -> error "No GhcLibDir found"
+#ifdef NEW_GHC_LAYOUT
+ Just d -> return (d ".." "lib")
+#else
+ Just d -> return (d "..")
+#endif
+
getExecDir :: IO (Maybe String)
#if defined(mingw32_HOST_OS)
getExecDir = allocaArray len $ \buf -> do
@@ -487,5 +435,7 @@
getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
#else
getExecDir = return Nothing
+#endif
+
#endif