aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Interface
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock/Interface')
-rw-r--r--src/Haddock/Interface/AttachInstances.hs5
-rw-r--r--src/Haddock/Interface/Create.hs44
-rw-r--r--src/Haddock/Interface/ExtractFnArgDocs.hs50
-rw-r--r--src/Haddock/Interface/Rename.hs21
4 files changed, 98 insertions, 22 deletions
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')
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 05:30:20 +0000