From 3a51468aabab2a3f4b9e06e7e0025f2421e07469 Mon Sep 17 00:00:00 2001 From: Isaac Dupree Date: Sun, 23 Aug 2009 06:26:36 +0000 Subject: re-implement function-argument docs ..on top of the lexParseRn work. This patch doesn't change the InstalledInterface format, and thus, it does not work cross-package, but that will be easy to add subsequently. --- src/Haddock/Backends/Hoogle.hs | 12 +-- src/Haddock/Backends/Html.hs | 120 +++++++++++++++--------------- src/Haddock/Interface/AttachInstances.hs | 5 +- src/Haddock/Interface/Create.hs | 44 +++++++---- src/Haddock/Interface/ExtractFnArgDocs.hs | 50 +++++++++++++ src/Haddock/Interface/Rename.hs | 21 ++++-- src/Haddock/Types.hs | 23 ++++-- 7 files changed, 182 insertions(+), 93 deletions(-) create mode 100644 src/Haddock/Interface/ExtractFnArgDocs.hs (limited to 'src') diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index b96dfc45..75b97442 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -109,7 +109,7 @@ operator x = x -- How to print each export ppExport :: ExportItem Name -> [String] -ppExport (ExportDecl decl dc subdocs _) = doc dc ++ f (unL decl) +ppExport (ExportDecl decl dc subdocs _) = doc (fst dc) ++ f (unL decl) where f (TyClD d@TyData{}) = ppData d subdocs f (TyClD d@ClassDecl{}) = ppClass d @@ -156,7 +156,7 @@ ppInstance :: Instance -> [String] ppInstance x = [dropComment $ out x] -ppData :: TyClDecl Name -> [(Name, Maybe (HsDoc Name))] -> [String] +ppData :: TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] ppData x subdocs = showData x{tcdCons=[],tcdDerivs=Nothing} : concatMap (ppCtor x subdocs . unL) (tcdCons x) where @@ -169,10 +169,12 @@ ppData x subdocs = showData x{tcdCons=[],tcdDerivs=Nothing} : f w = if w == nam then operator nam else w -- | for constructors, and named-fields... -lookupCon :: [(Name, Maybe (HsDoc Name))] -> Located Name -> Maybe (HsDoc Name) -lookupCon subdocs (L _ name) = join{-Maybe-} $ lookup name subdocs +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 -> [(Name, Maybe (HsDoc Name))] -> ConDecl Name -> [String] +ppCtor :: TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String] ppCtor dat subdocs con = doc (lookupCon subdocs (con_name con)) ++ f (con_details con) where diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs index d1b643cf..70cf5b02 100644 --- a/src/Haddock/Backends/Html.hs +++ b/src/Haddock/Backends/Html.hs @@ -23,7 +23,7 @@ import Haddock.Backends.DevHelp 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 ) @@ -60,10 +60,6 @@ type SourceURLs = (Maybe String, Maybe String, Maybe String) type WikiURLs = (Maybe String, Maybe String, Maybe String) --- convenient short-hands -type Doc = HsDoc DocName - - -- ----------------------------------------------------------------------------- -- Generating HTML documentation @@ -659,7 +655,9 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode where 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 @@ -815,71 +813,63 @@ declWithDoc False links loc nm (Just doc) html_decl = -- TODO: use DeclInfo DocName or something ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> - Maybe (HsDoc DocName) -> [InstHead DocName] -> [(DocName, Maybe (HsDoc DocName))] -> Bool -> HtmlTable -ppDecl summ links (L loc decl) mbDoc instances 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 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 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 + 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 - - do_largs leader (L _ t) = do_args leader t - do_args :: Html -> (HsType DocName) -> HtmlTable - do_args leader (HsForAllTy Explicit tvs lctxt ltype) + argDocHtml n = case Map.lookup n argDocs of + Just adoc -> docToHtml adoc + Nothing -> noHtml + + 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 ---hacl --- 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] @@ -890,16 +880,16 @@ tyvarNames :: [LHsTyVarBndr DocName] -> [Name] 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) @@ -1032,10 +1022,10 @@ ppTyInstHeader _ _ decl unicode = -------------------------------------------------------------------------------- -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" @@ -1139,7 +1129,7 @@ ppFds fds unicode = 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 @@ -1150,11 +1140,11 @@ ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc 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 @@ -1165,7 +1155,7 @@ ppShortClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortC ppClassDecl :: Bool -> LinksInfo -> [InstHead DocName] -> SrcSpan - -> Maybe (HsDoc DocName) -> [(DocName, Maybe (HsDoc DocName))] + -> Maybe (HsDoc DocName) -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName -> Bool -> HtmlTable ppClassDecl summary links instances loc mbDoc subdocs decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode @@ -1193,10 +1183,10 @@ ppClassDecl summary links instances loc mbDoc subdocs 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 @@ -1216,6 +1206,14 @@ ppInstHead unicode ([], n, ts) = ppAppNameTypes n ts unicode 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,7 +1254,7 @@ ppShortDataDecl summary links loc dataDecl unicode resTy = (con_res . unLoc . head) cons ppDataDecl :: Bool -> LinksInfo -> [InstHead DocName] -> - [(DocName, Maybe (HsDoc DocName))] -> + [(DocName, DocForDecl DocName)] -> SrcSpan -> Maybe (HsDoc DocName) -> TyClDecl DocName -> Bool -> HtmlTable ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode @@ -1373,7 +1371,7 @@ ppConstrHdr forall tvs ctxt unicode Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> toHtml ". " Implicit -> empty -ppSideBySideConstr :: [(DocName, Maybe (HsDoc DocName))] -> Bool -> LConDecl DocName -> HtmlTable +ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LConDecl DocName -> HtmlTable ppSideBySideConstr subdocs unicode (L _ con) = case con_res con of ResTyH98 -> case con_details con of @@ -1418,17 +1416,19 @@ ppSideBySideConstr subdocs unicode (L _ con) = case con_res con of forall = con_explicit 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. - mbLDoc = fmap noLoc $ join $ lookup (unLoc $ con_name con) subdocs + -- 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 :: [(DocName, Maybe (HsDoc DocName))] -> Bool -> ConDeclField DocName -> HtmlTable +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 $ lookup name subdocs + mbLDoc = fmap noLoc $ join $ fmap fst $ lookup name subdocs {- ppHsFullConstr :: HsConDecl -> Html diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs index f9a951f3..122ea5d0 100644 --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -44,13 +44,14 @@ attachInstances = mapM attach attach iface = do newItems <- mapM attachExport $ ifaceExportItems iface return $ iface { ifaceExportItems = newItems } - attachExport (ExportDecl decl@(L _ (TyClD d)) doc subs _) = do + attachExport export@ExportDecl{expItemDecl = L _ (TyClD d)} = do mb_info <- getAllInfo (unLoc (tcdLName d)) - return $ ExportDecl decl doc subs $ case mb_info of + return $ export { expItemInstances = case mb_info of Just (_, _, instances) -> map toHsInstHead . sortImage instHead . map instanceHead $ instances Nothing -> [] + } attachExport export = return export diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 29391702..d919ab4b 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -19,6 +19,7 @@ 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) @@ -26,6 +27,7 @@ import Data.List import Data.Maybe import Data.Ord import Control.Monad +import qualified Data.Traversable as Traversable import GHC hiding (flags) import Name @@ -151,34 +153,46 @@ 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 subsStringy = subordinates d - subs <- forM subsStringy $ \(subName, mbSubDocString) -> do + let subs_ = subordinates d + subs <- forM subs_ $ \(subName, mbSubDocStr, subFnArgsDocStr) -> do mbSubDoc <- lexParseRnHaddockCommentList NormalHaddockComment - gre mbSubDocString - return (subName, mbSubDoc) + gre mbSubDocStr + subFnArgsDoc <- fmap (Map.mapMaybe id) $ + Traversable.forM subFnArgsDocStr $ + \doc -> lexParseRnHaddockComment NormalHaddockComment gre doc + return (subName, (mbSubDoc, subFnArgsDoc)) - return (parent, mbDoc, subs) + return (parent, (mbDoc, fnArgsDoc), subs) -subordinates :: HsDecl Name -> [(Name, MaybeDocStrings)] +subordinates :: HsDecl Name -> [(Name, MaybeDocStrings, Map Int HsDocString)] subordinates (TyClD d) = classDataSubs d subordinates _ = [] -classDataSubs :: TyClDecl Name -> [(Name, MaybeDocStrings)] +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, maybeToList $ fmap unL $ con_doc c) + -- 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) + fields = [ (unL n, maybeToList $ fmap unL doc, Map.empty) | RecCon flds <- map con_details cons , ConDeclField n _ doc <- flds ] @@ -495,12 +509,12 @@ mkExportItems modMap this_mod gre exported_names decls declMap let hsdecl = tyThingToHsSynSig tyThing return [ mkExportDecl t ( hsdecl - , fmap (fmapHsDoc getName) $ - Map.lookup t (instDocMap iface) + , (fmap (fmapHsDoc getName) $ + Map.lookup t (instDocMap iface), Map.empty{-todo-}) , map (\subt -> ( subt - , fmap (fmapHsDoc getName) $ - Map.lookup subt (instDocMap iface) + , (fmap (fmapHsDoc getName) $ + Map.lookup subt (instDocMap iface), Map.empty{-todo-}) ) ) subs @@ -637,7 +651,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) = -- 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 diff --git a/src/Haddock/Interface/ExtractFnArgDocs.hs b/src/Haddock/Interface/ExtractFnArgDocs.hs new file mode 100644 index 00000000..c5198598 --- /dev/null +++ b/src/Haddock/Interface/ExtractFnArgDocs.hs @@ -0,0 +1,50 @@ +{-# 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 _ = Map.empty + +getSigFnArgDocs :: Sig Name -> Map Int HsDocString +getSigFnArgDocs (TypeSig _ ty) = getTypeFnArgDocs ty +getSigFnArgDocs _ = Map.empty + +getTypeFnArgDocs :: LHsType Name -> Map Int HsDocString +getTypeFnArgDocs ty = getLTypeDocs 0 ty + + +getLTypeDocs :: Int -> LHsType Name -> Map Int HsDocString +getLTypeDocs n (L _ ty) = getTypeDocs n ty + +getTypeDocs :: Int -> HsType Name -> Map Int HsDocString +getTypeDocs n (HsForAllTy _ _ _ ty) = getLTypeDocs n ty +getTypeDocs n (HsFunTy (L _ (HsDocTy _arg_type (L _ doc))) res_type) = + Map.insert n doc $ getLTypeDocs (n+1) res_type +getTypeDocs n (HsFunTy _ res_type) = getLTypeDocs (n+1) res_type +getTypeDocs n (HsDocTy _res_type (L _ doc)) = Map.singleton n doc +getTypeDocs _ _res_type = Map.empty + diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index b377b4fb..0caf79ba 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -38,8 +38,8 @@ renameInterface renamingEnv warnings iface = 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,6 +141,13 @@ renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName] 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 @@ -199,6 +206,10 @@ renameDoc d = case d of DocAName str -> return (DocAName str) +renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName) +renameFnArgsDoc = mapM renameDoc + + renameLPred :: LHsPred Name -> RnM (LHsPred DocName) renameLPred = mapM renamePred @@ -434,7 +445,7 @@ renameExportItem item = case item of 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') @@ -447,8 +458,8 @@ renameExportItem item = case item of return (ExportDoc doc') -renameSub :: (Name, Maybe (HsDoc Name)) -> RnM (DocName, Maybe (HsDoc DocName)) +renameSub :: (Name, DocForDecl Name) -> RnM (DocName, DocForDecl DocName) renameSub (n,doc) = do n' <- rename n - doc' <- mapM renameDoc doc + doc' <- renameDocForDecl doc return (n', doc') diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index 494699e5..6d53f88d 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -30,6 +30,7 @@ module Haddock.Types ( import Control.Exception import Data.Typeable import Data.Map (Map) +import qualified Data.Map as Map import GHC hiding (NoLink) import Name @@ -43,9 +44,15 @@ type HsDocString = HsDoc Name type LHsDocString = Located HsDocString #endif +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' @@ -81,11 +88,12 @@ data ExportItem name -- | 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] @@ -178,7 +186,7 @@ data Interface = Interface { 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], @@ -248,7 +256,7 @@ toInstalledIface :: Interface -> InstalledInterface toInstalledIface interface = InstalledInterface { instMod = ifaceMod interface, instInfo = ifaceInfo interface, - instDocMap = ifaceRnDocMap interface, + instDocMap = Map.mapMaybe fst $ ifaceRnDocMap interface,--todo. instExports = ifaceExports interface, instVisibleExports = ifaceVisibleExports interface, instOptions = ifaceOptions interface, @@ -320,6 +328,9 @@ 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 -- cgit v1.2.3