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.

1 files changed, 29 insertions, 15 deletions

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