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/Interface/AttachInstances.hs | 5 ++-- src/Haddock/Interface/Create.hs | 44 +++++++++++++++++---------- src/Haddock/Interface/ExtractFnArgDocs.hs | 50 +++++++++++++++++++++++++++++++ src/Haddock/Interface/Rename.hs | 21 +++++++++---- 4 files changed, 98 insertions(+), 22 deletions(-) create mode 100644 src/Haddock/Interface/ExtractFnArgDocs.hs (limited to 'src/Haddock/Interface') 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') -- cgit v1.2.3