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.

7 files changed, 182 insertions, 93 deletions

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