haddock 2.5.0 → 2.6.0
raw patch · 26 files changed
+1730/−546 lines, 26 filesdep −haskell98dep ~basedep ~ghcPVP ok
version bump matches the API change (PVP)
Dependencies removed: haskell98
Dependency ranges changed: base, ghc
API changes (from Hackage documentation)
- Distribution.Haddock: InstalledInterface :: Module -> HaddockModInfo Name -> Map Name (HsDoc DocName) -> [Name] -> [Name] -> [DocOption] -> Map Name [Name] -> InstalledInterface
+ Distribution.Haddock: InstalledInterface :: Module -> HaddockModInfo Name -> Map Name (DocForDecl Name) -> [Name] -> [Name] -> [DocOption] -> Map Name [Name] -> InstalledInterface
- Distribution.Haddock: instDocMap :: InstalledInterface -> Map Name (HsDoc DocName)
+ Distribution.Haddock: instDocMap :: InstalledInterface -> Map Name (DocForDecl Name)
Files
- CHANGES +22/−0
- doc/haddock.xml +1/−1
- haddock.cabal +11/−4
- haddock.spec +1/−1
- src/Haddock/Backends/DevHelp.hs +0/−3
- src/Haddock/Backends/Hoogle.hs +14/−12
- src/Haddock/Backends/Html.hs +97/−95
- src/Haddock/Convert.hs +284/−0
- src/Haddock/GhcUtils.hs +28/−6
- src/Haddock/HsDoc.hs +73/−0
- src/Haddock/Interface.hs +12/−87
- src/Haddock/Interface/AttachInstances.hs +27/−78
- src/Haddock/Interface/Create.hs +250/−68
- src/Haddock/Interface/ExtractFnArgDocs.hs +51/−0
- src/Haddock/Interface/Lex.x +171/−0
- src/Haddock/Interface/LexParseRn.hs +89/−0
- src/Haddock/Interface/Parse.y +106/−0
- src/Haddock/Interface/ParseModuleHeader.hs +158/−0
- src/Haddock/Interface/Rename.hs +27/−8
- src/Haddock/Interface/Rn.hs +82/−0
- src/Haddock/InterfaceFile.hs +25/−40
- src/Haddock/ModuleTree.hs +3/−5
- src/Haddock/Options.hs +3/−0
- src/Haddock/Types.hs +127/−14
- src/Haddock/Utils.hs +0/−6
- src/Main.hs +68/−118
CHANGES view
@@ -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.*
doc/haddock.xml view
@@ -16,7 +16,7 @@ <holder>Simon Marlow</holder> </copyright> <abstract>- <para>This document describes Haddock version 2.5.0, a Haskell+ <para>This document describes Haddock version 2.6.0, a Haskell documentation tool.</para> </abstract> </bookinfo>
haddock.cabal view
@@ -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)
haddock.spec view
@@ -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}
src/Haddock/Backends/DevHelp.hs view
@@ -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
src/Haddock/Backends/Hoogle.hs view
@@ -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 ""
src/Haddock/Backends/Html.hs view
@@ -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))
+ src/Haddock/Convert.hs view
@@ -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+ )
src/Haddock/GhcUtils.hs view
@@ -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
+ src/Haddock/HsDoc.hs view
@@ -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+
src/Haddock/Interface.hs view
@@ -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
src/Haddock/Interface/AttachInstances.hs view
@@ -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)
src/Haddock/Interface/Create.hs view
@@ -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
+ src/Haddock/Interface/ExtractFnArgDocs.hs view
@@ -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+
+ src/Haddock/Interface/Lex.x view
@@ -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+<line> {+ $ws* \> { begin birdtrack }+ $ws* \n { token TokPara `andBegin` para }+ -- Here, we really want to be able to say+ -- $ws* (\n | <eof>) { 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 <eof>,+ -- though (NOW I realise what it was for :-). To get around this, we always+ -- append \n to the end of a docstring.+ () { begin string }+}++<birdtrack> .* \n? { strtokenNL TokBirdTrack `andBegin` line }++<string,def> {+ $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 }+}++<def> {+ \] { token TokDefEnd `andBegin` string }+}++-- ']' doesn't have any special meaning outside of the [...] at the beginning+-- of a definition paragraph.+<string> {+ \] { 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+}
+ src/Haddock/Interface/LexParseRn.hs view
@@ -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+
+ src/Haddock/Interface/Parse.y view
@@ -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+}
+ src/Haddock/Interface/ParseModuleHeader.hs view
@@ -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+
src/Haddock/Interface/Rename.hs view
@@ -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')
+ src/Haddock/Interface/Rn.hs view
@@ -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)
src/Haddock/InterfaceFile.hs view
@@ -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
src/Haddock/ModuleTree.hs view
@@ -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]
src/Haddock/Options.hs view
@@ -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" ]
src/Haddock/Types.hs view
@@ -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)+
src/Haddock/Utils.hs view
@@ -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 -- -----------------------------------------------------------------------------
src/Main.hs view
@@ -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<size> 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