Merge branch 'master' of darcs.haskell.org:/srv/darcs//haddock

4 files changed, 262 insertions, 179 deletions

diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index c3d5d291..4bb46cba 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -28,13 +28,18 @@ import Data.Monoid
 import Data.Ord
 import Control.Applicative
 import Control.Monad
-import qualified Data.Traversable as Traversable
+import qualified Data.Traversable as T
 
+import qualified Packages
+import qualified Module
+import qualified SrcLoc
 import GHC hiding (flags)
 import HscTypes
 import Name
 import Bag
-import RdrName (GlobalRdrEnv)
+import RdrName
+import TcRnTypes
+import FastString (unpackFS)
 
 
 -- | Use a 'TypecheckedModule' to produce an 'Interface'.
@@ -51,6 +56,8 @@ createInterface tm flags modMap instIfaceMap = do
       instances     = modInfoInstances mi
       exportedNames = modInfoExports mi
 
+      (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, _) = tm_internals_ tm
+
   -- The renamed source should always be available to us, but it's best
   -- to be on the safe side.
   (group_, mayExports, mayDocHeader) <-
@@ -60,23 +67,19 @@ createInterface tm flags modMap instIfaceMap = do
         return (emptyRnGroup, Nothing, Nothing)
       Just (x, _, y, z) -> return (x, y, z)
 
-  -- The pattern-match should not fail, because createInterface is only
-  -- done on loaded modules.
-  Just gre <- liftGhcToErrMsgGhc $ lookupLoadedHomeModuleGRE (moduleName mdl)
-
   opts0 <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl
   let opts
         | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0
         | otherwise = opts0
 
-  (info, mbDoc) <- liftErrMsg $ lexParseRnHaddockModHeader dflags gre safety mayDocHeader
+  (info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader
 
   let declsWithDocs = topDecls group_
       (decls, _) = unzip declsWithDocs
       localInsts = filter (nameIsLocalOrFrom mdl . getName) instances
 
   maps@(docMap, argMap, subMap, declMap) <-
-    liftErrMsg $ mkMaps dflags gre localInsts exportedNames declsWithDocs
+    liftErrMsg $ mkMaps dflags gre localInsts declsWithDocs
 
   let exports0 = fmap (reverse . map unLoc) mayExports
       exports
@@ -85,31 +88,33 @@ createInterface tm flags modMap instIfaceMap = do
 
   liftErrMsg $ warnAboutFilteredDecls dflags mdl decls
 
-  exportItems <- mkExportItems modMap mdl gre exportedNames decls maps exports
+  let warningMap = mkWarningMap warnings gre exportedNames
+  exportItems <- mkExportItems modMap mdl warningMap gre exportedNames decls maps exports
                    instances instIfaceMap dflags
 
   let visibleNames = mkVisibleNames exportItems opts
 
   -- Measure haddock documentation coverage.
-  let
-    prunedExportItems0 = pruneExportItems exportItems
-    haddockable = 1 + length exportItems -- module + exports
-    haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0
-    coverage = (haddockable, haddocked)
+  let prunedExportItems0 = pruneExportItems exportItems
+      haddockable = 1 + length exportItems -- module + exports
+      haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0
+      coverage = (haddockable, haddocked)
 
   -- Prune the export list to just those declarations that have
   -- documentation, if the 'prune' option is on.
-  let
-    prunedExportItems
-      | OptPrune `elem` opts = prunedExportItems0
-      | otherwise = exportItems
+  let prunedExportItems
+        | OptPrune `elem` opts = prunedExportItems0
+        | otherwise = exportItems
+
+  let aliases =
+        mkAliasMap dflags $ tm_renamed_source tm
 
   return Interface {
     ifaceMod             = mdl,
     ifaceOrigFilename    = msHsFilePath ms,
     ifaceInfo            = info,
-    ifaceDoc             = mbDoc,
-    ifaceRnDoc           = Nothing,
+    ifaceDoc             = Documentation mbDoc (moduleWarning warnings),
+    ifaceRnDoc           = Documentation Nothing Nothing,
     ifaceOptions         = opts,
     ifaceDocMap          = docMap,
     ifaceArgMap          = argMap,
@@ -121,10 +126,69 @@ createInterface tm flags modMap instIfaceMap = do
     ifaceVisibleExports  = visibleNames,
     ifaceDeclMap         = declMap,
     ifaceSubMap          = subMap,
+    ifaceModuleAliases   = aliases,
     ifaceInstances       = instances,
     ifaceHaddockCoverage = coverage
   }
 
+mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName
+mkAliasMap dflags mRenamedSource =
+  case mRenamedSource of
+    Nothing -> M.empty
+    Just (_,impDecls,_,_) ->
+      M.fromList $
+      mapMaybe (\(SrcLoc.L _ impDecl) -> do
+        alias <- ideclAs impDecl
+        return $
+          (lookupModuleDyn dflags
+             (fmap Module.fsToPackageId $
+              ideclPkgQual impDecl)
+             (case ideclName impDecl of SrcLoc.L _ name -> name),
+           alias))
+        impDecls
+
+-- similar to GHC.lookupModule
+lookupModuleDyn ::
+  DynFlags -> Maybe PackageId -> ModuleName -> Module
+lookupModuleDyn _ (Just pkgId) mdlName =
+  Module.mkModule pkgId mdlName
+lookupModuleDyn dflags Nothing mdlName =
+  flip Module.mkModule mdlName $
+  case filter snd $
+       Packages.lookupModuleInAllPackages dflags mdlName of
+    (pkgId,_):_ -> Packages.packageConfigId pkgId
+    [] -> Module.mainPackageId
+
+
+-------------------------------------------------------------------------------
+-- Warnings
+-------------------------------------------------------------------------------
+
+type WarningMap = DocMap Name
+
+mkWarningMap :: Warnings -> GlobalRdrEnv -> [Name] -> WarningMap
+mkWarningMap NoWarnings  _ _ = M.empty
+mkWarningMap (WarnAll _) _ _ = M.empty
+mkWarningMap (WarnSome ws) gre exps = M.fromList
+      [ (n, warnToDoc w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ
+      , let n = gre_name elt, n `elem` exps ]
+
+
+moduleWarning :: Warnings -> Maybe (Doc id)
+moduleWarning ws =
+  case ws of
+    NoWarnings -> Nothing
+    WarnSome _ -> Nothing
+    WarnAll w  -> Just (warnToDoc w)
+
+
+warnToDoc :: WarningTxt -> Doc id
+warnToDoc w = case w of
+  (DeprecatedTxt msg) -> format "Deprecated: " msg
+  (WarningTxt    msg) -> format "Warning: "    msg
+  where
+    format x xs = DocWarning . DocParagraph . DocString . concat $ x : map unpackFS xs
+
 
 -------------------------------------------------------------------------------
 -- Doc options
@@ -154,50 +218,50 @@ parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing
 
 
 --------------------------------------------------------------------------------
--- Declarations
+-- Maps
 --------------------------------------------------------------------------------
 
 
 type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap)
 
-mkMaps :: DynFlags -> GlobalRdrEnv -> [ClsInst] -> [Name] -> [(LHsDecl Name, [HsDocString])] -> ErrMsgM Maps
-mkMaps dflags gre instances exports decls = do
-  maps <- mapM f decls
-  let mergeMaps (a,b,c,d) (x,y,z,w) =
-        (M.unionWith mappend a x, M.unionWith mappend b y,
-         M.unionWith mappend c z, M.unionWith mappend d w)
-  let emptyMaps = (M.empty, M.empty, M.empty, M.empty)
-  return (foldl' mergeMaps emptyMaps maps)
+-- | Create 'Maps' by looping through the declarations. For each declaration,
+-- find its names, its subordinates, and its doc strings. Process doc strings
+-- into 'Doc's.
+mkMaps :: DynFlags
+       -> GlobalRdrEnv
+       -> [ClsInst]
+       -> [(LHsDecl Name, [HsDocString])]
+       -> ErrMsgM Maps
+mkMaps dflags gre instances decls = do
+  (a, b, c, d) <- unzip4 <$> mapM mappings decls
+  return (f a, f b, f c, f d)
   where
+    f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b
+    f = M.fromListWith (<>) . concat
+
+    mappings (ldecl, docStrs) = do
+      let decl = unLoc ldecl
+      let declDoc strs m = do
+            doc <- processDocStrings dflags gre strs
+            m' <- M.mapMaybe id <$> T.mapM (processDocStringParas dflags gre) m
+            return (doc, m')
+      (doc, args) <- declDoc docStrs (typeDocs decl)
+      let subs = subordinates decl
+      (subDocs, subArgs) <- unzip <$> mapM (\(_, strs, m) -> declDoc strs m) subs
+      let ns = names decl
+          subNs = [ n | (n, _, _) <- subs ]
+          dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ]
+          am = [ (n, args) | n <- ns ] ++ zip subNs subArgs
+          sm = [ (n, subNs) | n <- ns ]
+          cm = [ (n, [ldecl]) | n <- ns ++ subNs ]
+      return (dm, am, sm, cm)
+
+    instanceMap :: Map SrcSpan Name
     instanceMap = M.fromList [ (getSrcSpan n, n) | i <- instances, let n = getName i ]
 
-    f :: (LHsDecl Name, [HsDocString]) -> ErrMsgM Maps
-    f (decl@(L _ d), docs) = do
-      mayDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment gre docs
-      argDocs <- fmap (M.mapMaybe id) $ Traversable.forM (typeDocs d) $
-          \doc -> lexParseRnHaddockComment dflags NormalHaddockComment gre doc
-
-      let subs_ = subordinates d
-      let subs_' = filter (\(name, _, _) -> name `elem` exports) subs_
-
-      (subDocs, subArgMap) <- unzip <$> (forM subs_' $ \(name, mbSubDocStr, subFnArgsDocStr) -> do
-        mbSubDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment gre mbSubDocStr
-        subFnArgsDoc <- fmap (M.mapMaybe id) $ Traversable.forM subFnArgsDocStr $
-          \doc -> lexParseRnHaddockComment dflags NormalHaddockComment gre doc
-        return ((name, mbSubDoc), (name, subFnArgsDoc)))
-
-      let subNames = map fst subDocs
-
-      let names = case d of
-            InstD (ClsInstD { cid_poly_ty = L l _ }) -> maybeToList (M.lookup l instanceMap)  -- See note [2].
-            _ -> filter (`elem` exports) (getMainDeclBinder d)
-
-      let docMap' = M.fromList (mapMaybe (\(n,doc) -> fmap (n,) doc) ([ (n, mayDoc) | n <- names ] ++ subDocs))
-      let argMap' = M.fromList [ (n, argDocs) | n <- names ] `mappend` M.fromList subArgMap
-      let subMap' = M.fromList [ (n, subNames) | n <- names ]
-      let dclMap' = M.fromList [ (n, [decl]) | n <- names ++ subNames ]
-      return (docMap', argMap', subMap', dclMap')
-
+    names :: HsDecl Name -> [Name]
+    names (InstD (ClsInstD { cid_poly_ty = L l _ })) = maybeToList (M.lookup l instanceMap)  -- See note [2].
+    names decl = getMainDeclBinder decl
 
 -- Note [2]:
 ------------
@@ -208,6 +272,12 @@ mkMaps dflags gre instances exports decls = do
 -- with InstDecls).
 
 
+--------------------------------------------------------------------------------
+-- Declarations
+--------------------------------------------------------------------------------
+
+
+-- | Get all subordinate declarations inside a declaration, and their docs.
 subordinates :: HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)]
 subordinates (TyClD decl)
   | isClassDecl decl = classSubs
@@ -302,7 +372,7 @@ warnAboutFilteredDecls dflags mdl decls = do
     tell [
       "Warning: " ++ modStr ++ ": Instances of type and data "
       ++ "families are not yet supported. Instances of the following families "
-      ++ "will be filtered out:\n  " ++ concat (intersperse ", "
+      ++ "will be filtered out:\n  " ++ (intercalate ", "
       $ map (occNameString . nameOccName) typeInstances) ]
 
   let instances = nub [ pretty dflags i | L _ (InstD (ClsInstD { cid_poly_ty = i, cid_fam_insts = ats })) <- decls
@@ -311,7 +381,7 @@ warnAboutFilteredDecls dflags mdl decls = do
   unless (null instances) $
     tell [
       "Warning: " ++ modStr ++ ": We do not support associated types in instances yet. "
-      ++ "These instances are affected:\n" ++ concat (intersperse ", " instances) ]
+      ++ "These instances are affected:\n" ++ intercalate ", " instances ]
 
 
 --------------------------------------------------------------------------------
@@ -323,7 +393,7 @@ warnAboutFilteredDecls dflags mdl decls = do
 
 -- | Filter out declarations that we don't handle in Haddock
 filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
-filterDecls decls = filter (isHandled . unL . fst) decls
+filterDecls = filter (isHandled . unL . fst)
   where
     isHandled (ForD (ForeignImport {})) = True
     isHandled (TyClD {}) = True
@@ -360,10 +430,10 @@ collectDocs = go Nothing []
   where
     go Nothing _ [] = []
     go (Just prev) docs [] = finished prev docs []
-    go prev docs ((L _ (DocD (DocCommentNext str))):ds)
+    go prev docs (L _ (DocD (DocCommentNext str)) : ds)
       | Nothing <- prev = go Nothing (str:docs) ds
       | Just decl <- prev = finished decl docs (go Nothing [str] ds)
-    go prev docs ((L _ (DocD (DocCommentPrev str))):ds) = go prev (str:docs) ds
+    go prev docs (L _ (DocD (DocCommentPrev str)) : ds) = go prev (str:docs) ds
     go Nothing docs (d:ds) = go (Just d) docs ds
     go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds)
 
@@ -379,6 +449,7 @@ collectDocs = go Nothing []
 mkExportItems
   :: IfaceMap
   -> Module             -- this module
+  -> WarningMap
   -> GlobalRdrEnv
   -> [Name]             -- exported names (orig)
   -> [LHsDecl Name]
@@ -389,39 +460,31 @@ mkExportItems
   -> DynFlags
   -> ErrMsgGhc [ExportItem Name]
 mkExportItems
-  modMap thisMod gre exportedNames decls0
+  modMap thisMod warnings gre exportedNames decls0
   (maps@(docMap, argMap, subMap, declMap)) optExports _ instIfaceMap dflags =
   case optExports of
-    Nothing -> fullModuleContents dflags gre maps decls
-    Just exports -> liftM (nubBy commaDeclared . concat) $ mapM lookupExport exports
+    Nothing -> fullModuleContents dflags warnings gre maps decls
+    Just exports -> liftM concat $ mapM lookupExport exports
   where
     decls = filter (not . isInstD . unLoc) decls0
 
-    -- A type signature can have multiple names, like:
-    --   foo, bar :: Types..
-    -- When going throug the exported names we have to take care to detect such
-    -- situations and remove the duplicates.
-    commaDeclared (ExportDecl (L _ sig1) _ _ _) (ExportDecl (L _ sig2) _ _ _) =
-      getMainDeclBinder sig1 == getMainDeclBinder sig2
-    commaDeclared _ _ = False
-
 
     lookupExport (IEVar x)             = declWith x
     lookupExport (IEThingAbs t)        = declWith t
     lookupExport (IEThingAll t)        = declWith t
     lookupExport (IEThingWith t _)     = declWith t
     lookupExport (IEModuleContents m)  =
-      moduleExports thisMod m dflags gre exportedNames decls modMap instIfaceMap maps
+      moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps
     lookupExport (IEGroup lev docStr)  = liftErrMsg $
-      ifDoc (lexParseRnHaddockComment dflags DocSectionComment gre docStr)
+      ifDoc (processDocString dflags gre docStr)
             (\doc -> return [ ExportGroup lev "" doc ])
     lookupExport (IEDoc docStr)        = liftErrMsg $
-      ifDoc (lexParseRnHaddockComment dflags NormalHaddockComment gre docStr)
+      ifDoc (processDocStringParas dflags gre docStr)
             (\doc -> return [ ExportDoc doc ])
     lookupExport (IEDocNamed str)      = liftErrMsg $
       ifDoc (findNamedDoc str [ unL d | d <- decls ])
             (\docStr ->
-            ifDoc (lexParseRnHaddockComment dflags NormalHaddockComment gre docStr)
+            ifDoc (processDocStringParas dflags gre docStr)
                   (\doc -> return [ ExportDoc doc ]))
 
 
@@ -433,19 +496,12 @@ mkExportItems
 
     declWith :: Name -> ErrMsgGhc [ ExportItem Name ]
     declWith t =
-      let mdl = nameModule t
-          (doc, subs)
-            | mdl == thisMod =
-                exportDecl t docMap argMap subMap
-            | Just iface <- M.lookup mdl modMap =
-                exportDecl t (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface)
-            | otherwise = (noDocForDecl, []) in
       case findDecl t of
-        [L _ (ValD _)] -> do
+        ([L _ (ValD _)], (doc, _)) -> do
           -- Top-level binding without type signature
           export <- hiValExportItem dflags t doc
           return [export]
-        ds | decl : _ <- filter (not . isValD . unLoc) ds ->
+        (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->
           let declNames = getMainDeclBinder (unL decl)
           in case () of
             _
@@ -456,7 +512,7 @@ mkExportItems
 
               -- We should not show a subordinate by itself if any of its
               -- parents is also exported. See note [1].
-              | not $ t `elem` declNames,
+              | t `notElem` declNames,
                 Just p <- find isExported (parents t $ unL decl) ->
                 do liftErrMsg $ tell [
                      "Warning: " ++ moduleString thisMod ++ ": " ++
@@ -467,25 +523,24 @@ mkExportItems
                    return []
 
               -- normal case
-              | otherwise -> return [ mkExportDecl t newDecl (doc, subs) ]
+              | otherwise -> return [ mkExportDecl t newDecl docs_ ]
                   where
-                    -- Since a single signature might refer to many names, we
-                    -- need to filter the ones that are actually exported. This
-                    -- requires modifying the type signatures to "hide" the
-                    -- names that are not exported.
+                    -- A single signature might refer to many names, but we
+                    -- create an export item for a single name only.  So we
+                    -- modify the signature to contain only that single name.
                     newDecl = case decl of
                       (L loc (SigD sig)) ->
-                        L loc . SigD . fromJust $ filterSigNames isExported sig
+                        L loc . SigD . fromJust $ filterSigNames (== t) sig
                         -- fromJust is safe since we already checked in guards
                         -- that 't' is a name declared in this declaration.
                       _                  -> decl
 
         -- Declaration from another package
-        [] -> do
+        ([], _) -> do
           mayDecl <- hiDecl dflags t
           case mayDecl of
             Nothing -> return [ ExportNoDecl t [] ]
-            Just decl -> do
+            Just decl ->
               -- We try to get the subs and docs
               -- from the installed .haddock file for that package.
               case M.lookup (nameModule t) instIfaceMap of
@@ -494,8 +549,8 @@ mkExportItems
                       ["Warning: Couldn't find .haddock for export " ++ pretty dflags t]
                    let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ]
                    return [ mkExportDecl t decl (noDocForDecl, subs_) ]
-                Just iface -> do
-                   return [ mkExportDecl t decl (exportDecl t (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]
+                Just iface ->
+                   return [ mkExportDecl t decl (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]
 
         _ -> return []
 
@@ -512,13 +567,15 @@ mkExportItems
     isExported = (`elem` exportedNames)
 
 
-    findDecl :: Name -> [LHsDecl Name]
-    findDecl name
-      | mdl == thisMod = maybe [] id (M.lookup name declMap)
-      | Just iface <- M.lookup mdl modMap = maybe [] id (M.lookup name (ifaceDeclMap iface))
-      | otherwise = []
+    findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)]))
+    findDecl n
+      | m == thisMod, Just ds <- M.lookup n declMap =
+          (ds, lookupDocs n warnings docMap argMap subMap)
+      | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) =
+          (ds, lookupDocs n warnings (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface))
+      | otherwise = ([], (noDocForDecl, []))
       where
-        mdl = nameModule name
+        m = nameModule n
 
 
 hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name))
@@ -539,12 +596,16 @@ hiValExportItem dflags name doc = do
     Just decl -> return (ExportDecl decl doc [] [])
 
 
-exportDecl :: Name -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)])
-exportDecl name docMap argMap subMap =
-  let lookupArgMap x = maybe M.empty id (M.lookup x argMap) in
-  let doc = (M.lookup name docMap, lookupArgMap name) in
-  let subs = [ (sub, (M.lookup sub docMap, lookupArgMap sub)) | sub <- maybe [] id (M.lookup name subMap) ] in
-  (doc, subs)
+-- | Lookup docs for a declaration from maps.
+lookupDocs :: Name -> WarningMap -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)])
+lookupDocs n warnings docMap argMap subMap =
+  let lookupArgDoc x = M.findWithDefault M.empty x argMap in
+  let doc = (lookupDoc n, lookupArgDoc n) in
+  let subs = M.findWithDefault [] n subMap in
+  let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) | s <- subs ] in
+  (doc, subDocs)
+  where
+    lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warnings)
 
 
 -- | Return all export items produced by an exported module. That is, we're
@@ -563,6 +624,7 @@ exportDecl name docMap argMap subMap =
 moduleExports :: Module           -- ^ Module A
               -> ModuleName       -- ^ The real name of B, the exported module
               -> DynFlags         -- ^ The flags used when typechecking A
+              -> WarningMap
               -> GlobalRdrEnv     -- ^ The renaming environment used for A
               -> [Name]           -- ^ All the exports of A
               -> [LHsDecl Name]   -- ^ All the declarations in A
@@ -570,8 +632,8 @@ moduleExports :: Module           -- ^ Module A
               -> InstIfaceMap     -- ^ Interfaces in other packages
               -> Maps
               -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items
-moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap maps
-  | m == thisMod = fullModuleContents dflags gre maps decls
+moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps
+  | m == thisMod = fullModuleContents dflags warnings gre maps decls
   | otherwise =
     case M.lookup m ifaceMap of
       Just iface
@@ -609,25 +671,38 @@ moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap map
 -- (For more information, see Trac #69)
 
 
-fullModuleContents :: DynFlags -> GlobalRdrEnv -> Maps -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name]
-fullModuleContents dflags gre (docMap, argMap, subMap, declMap) decls =
-  liftM catMaybes $ mapM mkExportItem decls
+fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name]
+fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap) decls =
+  liftM catMaybes $ mapM mkExportItem (expandSig decls)
   where
+    -- A type signature can have multiple names, like:
+    --   foo, bar :: Types..
+    --
+    -- We go through the list of declarations and expand type signatures, so
+    -- that every type signature has exactly one name!
+    expandSig :: [LHsDecl name] -> [LHsDecl name]
+    expandSig = foldr f []
+      where
+        f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name]
+        f (L l (SigD (TypeSig    names t))) xs = foldr (\n acc -> L l (SigD (TypeSig    [n] t)) : acc) xs names
+        f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names
+        f x xs = x : xs
+
     mkExportItem (L _ (DocD (DocGroup lev docStr))) = do
-      mbDoc <- liftErrMsg $ lexParseRnHaddockComment dflags DocSectionComment gre docStr
+      mbDoc <- liftErrMsg $ processDocString dflags gre docStr
       return $ fmap (ExportGroup lev "") mbDoc
     mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do
-      mbDoc <- liftErrMsg $ lexParseRnHaddockComment dflags NormalHaddockComment gre docStr
+      mbDoc <- liftErrMsg $ processDocStringParas dflags gre docStr
       return $ fmap ExportDoc mbDoc
     mkExportItem (L _ (ValD d))
       | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap =
           -- Top-level binding without type signature.
-          let (doc, _) = exportDecl name docMap argMap subMap in
+          let (doc, _) = lookupDocs name warnings docMap argMap subMap in
           fmap Just (hiValExportItem dflags name doc)
       | otherwise = return Nothing
     mkExportItem decl
       | name:_ <- getMainDeclBinder (unLoc decl) =
-        let (doc, subs) = exportDecl name docMap argMap subMap in
+        let (doc, subs) = lookupDocs name warnings docMap argMap subMap in
         return $ Just (ExportDecl decl doc subs [])
       | otherwise = return Nothing
 
@@ -687,11 +762,11 @@ extractRecSel nm mdl t tvs (L _ con : rest) =
   data_ty = foldl (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) (map toTypeNoLoc tvs)
 
 
--- Pruning
+-- | Keep exprt items with docs.
 pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
-pruneExportItems items = filter hasDoc items
+pruneExportItems = filter hasDoc
   where
-    hasDoc (ExportDecl{expItemMbDoc = (d, _)}) = isJust d
+    hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d
     hasDoc _ = True
 
 
@@ -709,12 +784,12 @@ mkVisibleNames exports opts
 
 -- | Find a stand-alone documentation comment by its name.
 findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString)
-findNamedDoc name decls = search decls
+findNamedDoc name = search
   where
     search [] = do
       tell ["Cannot find documentation for: $" ++ name]
       return Nothing
-    search ((DocD (DocCommentNamed name' doc)):rest)
+    search (DocD (DocCommentNamed name' doc) : rest)
       | name == name' = return (Just doc)
       | otherwise = search rest
     search (_other_decl : rest) = search rest
diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs
index c13e57be..d68f78f8 100644
--- a/src/Haddock/Interface/LexParseRn.hs
+++ b/src/Haddock/Interface/LexParseRn.hs
@@ -1,4 +1,4 @@
------------------------------------------------------------------------------
+  -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Interface.LexParseRn
 -- Copyright   :  (c) Isaac Dupree 2009,
@@ -9,11 +9,10 @@
 -- Portability :  portable
 -----------------------------------------------------------------------------
 module Haddock.Interface.LexParseRn
-  ( HaddockCommentType(..)
-  , lexParseRnHaddockComment
-  , lexParseRnHaddockCommentList
-  , lexParseRnMbHaddockComment
-  , lexParseRnHaddockModHeader
+  ( processDocString
+  , processDocStringParas
+  , processDocStrings
+  , processModuleHeader
   ) where
 
 
@@ -24,6 +23,7 @@ import Haddock.Interface.ParseModuleHeader
 import Haddock.Doc
 
 import Control.Applicative
+import Data.List
 import Data.Maybe
 import FastString
 import GHC
@@ -33,62 +33,59 @@ import RdrName
 import RnEnv
 
 
-data HaddockCommentType = NormalHaddockComment | DocSectionComment
-
-
-lexParseRnHaddockCommentList :: DynFlags -> HaddockCommentType -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (Doc Name))
-lexParseRnHaddockCommentList dflags hty gre docStrs = do
-  docMbs <- mapM (lexParseRnHaddockComment dflags hty gre) docStrs
-  let docs = catMaybes docMbs
-  let doc = foldl docAppend DocEmpty docs
+processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (Doc Name))
+processDocStrings dflags gre strs = do
+  docs <- catMaybes <$> mapM (processDocStringParas dflags gre) strs
+  let doc = foldl' docAppend DocEmpty docs
   case doc of
     DocEmpty -> return Nothing
     _ -> return (Just doc)
 
 
-lexParseRnHaddockComment :: DynFlags -> HaddockCommentType ->
-    GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name))
-lexParseRnHaddockComment dflags hty gre (HsDocString fs) = do
+processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name))
+processDocStringParas = process parseParas
+
+
+processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name))
+processDocString = process parseString
+
+process :: ([LToken] -> Maybe (Doc RdrName))
+        -> DynFlags
+        -> GlobalRdrEnv
+        -> HsDocString
+        -> ErrMsgM (Maybe (Doc Name))
+process parse dflags gre (HsDocString fs) = do
    let str = unpackFS fs
-   let toks = tokenise dflags str (0,0) -- TODO: real position
-   let parse = case hty of
-         NormalHaddockComment -> parseParas
-         DocSectionComment -> parseString
+   let toks = tokenise dflags str (0,0)  -- TODO: real position
    case parse toks of
      Nothing -> do
-       tell ["doc comment parse failed: "++str]
+       tell [ "doc comment parse failed: " ++ str ]
        return Nothing
      Just doc -> return (Just (rename dflags gre doc))
 
 
-lexParseRnMbHaddockComment :: DynFlags -> HaddockCommentType -> GlobalRdrEnv -> Maybe HsDocString -> ErrMsgM (Maybe (Doc Name))
-lexParseRnMbHaddockComment _ _ _ Nothing = return Nothing
-lexParseRnMbHaddockComment dflags hty gre (Just d) = lexParseRnHaddockComment dflags hty gre d
-
+processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString
+                    -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name))
+processModuleHeader dflags gre safety mayStr = do
+  (hmi, doc) <-
+    case mayStr of
 
--- yes, you always get a HaddockModInfo though it might be empty
-lexParseRnHaddockModHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> GhcDocHdr
-                           -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name))
-lexParseRnHaddockModHeader dflags gre safety mbStr = do
-  (hmi, docn) <-
-    case mbStr of
       Nothing -> return failure
       Just (L _ (HsDocString fs)) -> do
         let str = unpackFS fs
         case parseModuleHeader dflags str of
-          Left mess -> do
-            tell ["haddock module header parse failed: " ++ mess]
+          Left msg -> do
+            tell ["haddock module header parse failed: " ++ msg]
             return failure
-          Right (info, doc) -> return (renameHmi dflags gre info, Just (rename dflags gre doc))
-  return (hmi { hmi_safety = Just $ showPpr dflags safety }, docn)
+          Right (hmi, doc) -> do
+            let hmi' = hmi { hmi_description = rename dflags gre <$> hmi_description hmi }
+                doc' = rename dflags gre doc
+            return (hmi', Just doc')
+  return (hmi { hmi_safety = Just $ showPpr dflags safety }, doc)
   where
     failure = (emptyHaddockModInfo, Nothing)
 
 
-renameHmi :: DynFlags -> GlobalRdrEnv -> HaddockModInfo RdrName -> HaddockModInfo Name
-renameHmi dflags gre hmi = hmi { hmi_description = rename dflags gre <$> hmi_description hmi }
-
-
 rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name
 rename dflags gre = rn
   where
@@ -109,6 +106,7 @@ rename dflags gre = rn
           a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b
               -- If an id can refer to multiple things, we give precedence to type
               -- constructors.
+      DocWarning doc -> DocWarning (rn doc)
       DocEmphasis doc -> DocEmphasis (rn doc)
       DocMonospaced doc -> DocMonospaced (rn doc)
       DocUnorderedList docs -> DocUnorderedList (map rn docs)
diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs
index 35533d0d..411b6661 100644
--- a/src/Haddock/Interface/ParseModuleHeader.hs
+++ b/src/Haddock/Interface/ParseModuleHeader.hs
@@ -137,14 +137,14 @@ parseKey key toParse0 =
                (spaces1,cs1) = extractLeadingSpaces cs
             in
                (c:spaces1,cs1)
-         | True = ([],s)
+         | otherwise = ([],s)
 
       extractNextLine :: String -> (String,String)
       extractNextLine [] = ([],[])
       extractNextLine (c:cs)
          | c == '\n' =
             ([],cs)
-         | True =
+         | otherwise =
             let
                (line,rest) = extractNextLine cs
             in
@@ -156,5 +156,5 @@ parseKey key toParse0 =
       extractPrefix _ [] = Nothing
       extractPrefix (c1:cs1) (c2:cs2)
          | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2
-         | True = Nothing
+         | otherwise = Nothing
 
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 380147be..6109c341 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -12,18 +12,19 @@
 module Haddock.Interface.Rename (renameInterface) where
 
 
-import Haddock.Types
 import Haddock.GhcUtils
+import Haddock.Types
 
+import Bag (emptyBag)
 import GHC hiding (NoLink)
 import Name
-import Bag (emptyBag)
 
+import Control.Applicative
+import Control.Monad hiding (mapM)
 import Data.List
 import qualified Data.Map as Map hiding ( Map )
-import Prelude hiding (mapM)
 import Data.Traversable (mapM)
-import Control.Monad hiding (mapM)
+import Prelude hiding (mapM)
 
 
 renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface
@@ -45,7 +46,7 @@ renameInterface dflags renamingEnv warnings iface =
       (rnArgMap, missingNames3) = runRnFM localEnv (mapM (mapM renameDoc) (ifaceArgMap iface))
 
       (finalModuleDoc, missingNames4)
-        = runRnFM localEnv (renameMaybeDoc (ifaceDoc iface))
+        = runRnFM localEnv (renameDocumentation (ifaceDoc iface))
 
       -- combine the missing names and filter out the built-ins, which would
       -- otherwise allways be missing.
@@ -92,6 +93,13 @@ instance Monad (GenRnM n) where
   (>>=) = thenRn
   return = returnRn
 
+instance Functor (GenRnM n) where
+  fmap f x = do a <- x; return (f a)
+
+instance Applicative (GenRnM n) where
+  pure = return
+  (<*>) = ap
+
 returnRn :: a -> GenRnM n a
 returnRn a   = RnM (const (a,[]))
 thenRn :: GenRnM n a -> (a -> GenRnM n b) -> GenRnM n b
@@ -137,15 +145,14 @@ renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName]
 renameExportItems = mapM renameExportItem
 
 
-renameDocForDecl :: (Maybe (Doc Name), FnArgsDoc Name) -> RnM (Maybe (Doc DocName), FnArgsDoc DocName)
-renameDocForDecl (mbDoc, fnArgsDoc) = do
-  mbDoc' <- renameMaybeDoc mbDoc
-  fnArgsDoc' <- renameFnArgsDoc fnArgsDoc
-  return (mbDoc', fnArgsDoc')
+renameDocForDecl :: DocForDecl Name -> RnM (DocForDecl DocName)
+renameDocForDecl (doc, fnArgsDoc) =
+  (,) <$> renameDocumentation doc <*> renameFnArgsDoc fnArgsDoc
 
 
-renameMaybeDoc :: Maybe (Doc Name) -> RnM (Maybe (Doc DocName))
-renameMaybeDoc = mapM renameDoc
+renameDocumentation :: Documentation Name -> RnM (Documentation DocName)
+renameDocumentation (Documentation mDoc mWarning) =
+  Documentation <$> mapM renameDoc mDoc <*> mapM renameDoc mWarning
 
 
 renameLDocHsSyn :: LHsDocString -> RnM LHsDocString
@@ -168,6 +175,9 @@ renameDoc d = case d of
     return (DocIdentifier x')
   DocIdentifierUnchecked x -> return (DocIdentifierUnchecked x)
   DocModule str -> return (DocModule str)
+  DocWarning doc -> do
+    doc' <- renameDoc doc
+    return (DocWarning doc')
   DocEmphasis doc -> do
     doc' <- renameDoc doc
     return (DocEmphasis doc')
@@ -240,11 +250,11 @@ renameType t = case t of
 
   HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts
 
-  HsOpTy a (w, (L loc op)) b -> do
+  HsOpTy a (w, L loc op) b -> do
     op' <- rename op
     a'  <- renameLType a
     b'  <- renameLType b
-    return (HsOpTy a' (w, (L loc op')) b')
+    return (HsOpTy a' (w, L loc op') b')
 
   HsParTy ty -> return . HsParTy =<< renameLType ty