Accumulate Haddock comments in P (#17544, #17561)wip/haddock-accum

Haddock comments are, first and foremost, comments. It's very annoying
to incorporate them into the grammar. We can take advantage of an
important property: adding a Haddock comment does not change the parse
tree in any way other than wrapping some nodes in HsDocTy and the like
(and if it does, that's a bug).

This patch implements the following:

* Accumulate Haddock comments with their locations in the P monad.
  This is handled in the lexer.

* After parsing, do a pass over the AST to associate Haddock comments
  with AST nodes using location info.

* Report the leftover comments to the user as a warning (-Wignored-haddock).

With this machinery in place, a follow-up patch can simply remove the
handling of comments from Parser.y

15 files changed, 750 insertions, 124 deletions

diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index 2146cc0..60589ce 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -84,8 +84,8 @@ module GHC.Hs.Decls (
   resultVariableName,
 
   -- * Grouping
-  HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups, hsGroupInstDecls
-
+  HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups, hsGroupInstDecls,
+  partitionBindsAndSigs, flattenBindsAndSigs,
     ) where
 
 -- friends:
@@ -167,6 +167,61 @@ type instance XDocD       (GhcPass _) = NoExtField
 type instance XRoleAnnotD (GhcPass _) = NoExtField
 type instance XXHsDecl    (GhcPass _) = NoExtCon
 
+partitionBindsAndSigs
+  :: ((LHsBind GhcPs, [LHsDecl GhcPs]) -> (LHsBind GhcPs, [LHsDecl GhcPs]))
+  -> [LHsDecl GhcPs]
+  -> (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
+      [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
+partitionBindsAndSigs getMonoBind = go
+  where
+    go [] = (emptyBag, [], [], [], [], [])
+    go ((L l (ValD _ b)) : ds) =
+      let (b', ds') = getMonoBind (L l b, ds)
+          (bs, ss, ts, tfis, dfis, docs) = go ds'
+      in (b' `consBag` bs, ss, ts, tfis, dfis, docs)
+    go ((L l decl) : ds) =
+      let (bs, ss, ts, tfis, dfis, docs) = go ds in
+      case decl of
+        SigD _ s
+          -> (bs, L l s : ss, ts, tfis, dfis, docs)
+        TyClD _ (FamDecl _ t)
+          -> (bs, ss, L l t : ts, tfis, dfis, docs)
+        InstD _ (TyFamInstD { tfid_inst = tfi })
+          -> (bs, ss, ts, L l tfi : tfis, dfis, docs)
+        InstD _ (DataFamInstD { dfid_inst = dfi })
+          -> (bs, ss, ts, tfis, L l dfi : dfis, docs)
+        DocD _ d
+          -> (bs, ss, ts, tfis, dfis, L l d : docs)
+        _ -> pprPanic "partitionBindsAndSigs" (ppr decl)
+
+flattenBindsAndSigs
+  :: (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
+      [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
+  -> [LHsDecl GhcPs]
+flattenBindsAndSigs (all_bs, all_ss, all_ts, all_tfis, all_dfis, all_docs) =
+  sortLocated $ go (bagToList all_bs) all_ss all_ts all_tfis all_dfis all_docs
+  where
+    go (L l b : bs) ss ts tfis dfis docs =
+      L l (ValD noExtField b)
+        : go bs ss ts tfis dfis docs
+    go bs (L l s : ss) ts tfis dfis docs =
+      L l (SigD noExtField s)
+        : go bs ss ts tfis dfis docs
+    go bs ss (L l t : ts) tfis dfis docs =
+      L l (TyClD noExtField (FamDecl noExtField t))
+        : go bs ss ts tfis dfis docs
+    go bs ss ts (L l tfi : tfis) dfis docs =
+      L l (InstD noExtField (TyFamInstD noExtField tfi))
+        : go bs ss ts tfis dfis docs
+    go bs ss ts tfis (L l dfi : dfis) docs =
+      L l (InstD noExtField (DataFamInstD noExtField dfi))
+        : go bs ss ts tfis dfis docs
+    go bs ss ts tfis dfis (L l d : docs) =
+      L l (DocD noExtField d)
+        : go bs ss ts tfis dfis docs
+
+    go [] [] [] [] [] [] = []
+
 -- NB: all top-level fixity decls are contained EITHER
 -- EITHER SigDs
 -- OR     in the ClassDecls in TyClDs
diff --git a/compiler/basicTypes/SrcLoc.hs b/compiler/basicTypes/SrcLoc.hs
index 57915fd..94f66be 100644
--- a/compiler/basicTypes/SrcLoc.hs
+++ b/compiler/basicTypes/SrcLoc.hs
@@ -100,6 +100,7 @@ import Data.Bits
 import Data.Data
 import Data.List
 import Data.Ord
+import qualified Data.Semigroup
 
 {-
 ************************************************************************
@@ -347,6 +348,12 @@ srcSpanFirstCharacter (RealSrcSpan span) = RealSrcSpan $ mkRealSrcSpan loc1 loc2
     loc1@(SrcLoc f l c) = realSrcSpanStart span
     loc2 = SrcLoc f l (c+1)
 
+instance Semigroup SrcSpan where
+  (<>) = combineSrcSpans
+
+instance Monoid SrcSpan where
+  mempty = noSrcSpan
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 94cee4a..f679a6c 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -926,6 +926,7 @@ data WarningFlag =
    | Opt_WarnInferredSafeImports          -- Since 8.10
    | Opt_WarnMissingSafeHaskellMode       -- Since 8.10
    | Opt_WarnDerivingDefaults
+   | Opt_WarnIgnoredHaddock
    deriving (Eq, Show, Enum)
 
 data Language = Haskell98 | Haskell2010
@@ -4148,7 +4149,8 @@ wWarningFlagsDeps = [
   flagSpec "partial-fields"              Opt_WarnPartialFields,
   flagSpec "prepositive-qualified-module"
                                          Opt_WarnPrepositiveQualifiedModule,
-  flagSpec "unused-packages"             Opt_WarnUnusedPackages
+  flagSpec "unused-packages"             Opt_WarnUnusedPackages,
+  flagSpec "ignored-haddock"             Opt_WarnIgnoredHaddock
  ]
 
 -- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@
diff --git a/compiler/parser/HaddockUtils.hs b/compiler/parser/HaddockUtils.hs
index d1d41a3..a4cdb25 100644
--- a/compiler/parser/HaddockUtils.hs
+++ b/compiler/parser/HaddockUtils.hs
@@ -1,12 +1,533 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ApplicativeDo #-}
 
-module HaddockUtils where
+module HaddockUtils
+  ( addFieldDoc,
+    addFieldDocs,
+    addConDoc,
+    addConDocs,
+    addConDocFirst,
+
+    addModuleHaddock,
+  ) where
 
 import GhcPrelude
 
 import GHC.Hs
 import SrcLoc
+import DynFlags ( WarningFlag(..) )
+import Outputable hiding ( (<>) )
 
+import Data.Semigroup
+import Data.Foldable
+import Data.Traversable
 import Control.Monad
+import Control.Monad.Trans.State.Strict
+import Control.Monad.Trans.Reader
+import Data.Functor.Identity
+import Data.Coerce
+
+import Lexer
+
+addModuleHaddock :: Located (HsModule GhcPs) -> P (Located (HsModule GhcPs))
+addModuleHaddock lmod = runAddHaddock (addHaddockModule lmod)
+
+newtype HdkM a = MkHdkM (ReaderT LocRange (State [RealLocated HdkComment]) a)
+  deriving (Functor, Applicative, Monad)
+  -- The state of HdkM is a list of pending (unassociated with an AST node)
+  -- Haddock comments, sorted by location, in ascending order.
+  --
+  -- We go over the AST, looking up these comments using 'takeHdkComments'.
+  -- The remaining ones are ignored with a warning (-Wignored-haddock).
+
+mkHdkM :: (LocRange -> [RealLocated HdkComment] -> (a, [RealLocated HdkComment])) -> HdkM a
+unHdkM :: HdkM a -> (LocRange -> [RealLocated HdkComment] -> (a, [RealLocated HdkComment]))
+mkHdkM = coerce
+unHdkM = coerce
+
+data HdkA a = MkHdkA SrcSpan (HdkM a)
+
+instance Functor HdkA where
+  fmap f (MkHdkA l m) = MkHdkA l (fmap f m)
+
+instance Applicative HdkA where
+  pure a = MkHdkA mempty (pure a)
+  MkHdkA l1 m1 <*> MkHdkA l2 m2 =
+    MkHdkA (l1 <> l2) (delim1 m1 <*> delim2 m2)
+    where
+      delim1 m = m `inLocRange` locRangeTo (srcSpanStart l2)
+      delim2 m = m `inLocRange` locRangeFrom (srcSpanEnd l1)
+
+mkHdkA :: (Located a -> HdkM b) -> Located a -> HdkA b
+mkHdkA f a = MkHdkA (getLoc a) (f a)
+
+registerHdkA :: Located a -> HdkA ()
+registerHdkA a = MkHdkA (getLoc a) (pure ())
+
+sepHdkA :: SrcLoc -> HdkA ()
+sepHdkA l = MkHdkA (srcLocSpan l) (pure ())
+
+delimitHdkA :: SrcSpan -> HdkA a -> HdkA a
+delimitHdkA l' (MkHdkA l m) = MkHdkA (l' <> l) m
+
+runAddHaddock :: HdkA a -> P a
+runAddHaddock (MkHdkA _ m) = do
+  pState <- getPState
+  let (a, other_hdk_comments) = unHdkM m mempty (reverse (hdk_comments pState))
+  mapM_ reportHdkComment other_hdk_comments
+  return a
+  where
+    reportHdkComment :: RealLocated HdkComment -> P ()
+    reportHdkComment (L l _) =
+      addWarning Opt_WarnIgnoredHaddock (RealSrcSpan l) $
+        text "A Haddock comment cannot appear in this position and will be ignored."
+
+getLocStart, getLocEnd :: Located a -> SrcLoc
+getLocEnd   = srcSpanEnd   . getLoc
+getLocStart = srcSpanStart . getLoc
+
+concatLHsDocString :: [LHsDocString] -> Maybe LHsDocString
+concatLHsDocString [] = Nothing
+concatLHsDocString [a] = Just a
+concatLHsDocString (L l1 d1 : ds) = do
+  L l2 d2 <- concatLHsDocString ds
+  return $ L (combineSrcSpans l1 l2) (appendDocs d1 d2)
+
+addHaddockModule :: Located (HsModule GhcPs) -> HdkA (Located (HsModule GhcPs))
+addHaddockModule (L l_mod mod) = do
+  headerDocs <-
+    for @Maybe (hsmodName mod) $
+    mkHdkA $ \name -> do
+      docs <- takeHdkComments getDocNext `inLocRange` locRangeTo (getLocStart name)
+      pure $ concatLHsDocString docs
+  hsmodExports' <- traverse @Maybe addHaddockExports (hsmodExports mod)
+  traverse_ registerHdkA (hsmodImports mod)
+  hsmodDecls' <- addHaddockInterleaveItems getDocDecl addHaddockDecl (hsmodDecls mod)
+  pure $ L l_mod $
+    mod { hsmodExports = hsmodExports'
+        , hsmodDecls = hsmodDecls'
+        , hsmodHaddockModHeader = join @Maybe headerDocs }
+
+addHaddockExports
+  :: Located [LIE GhcPs]
+  -> HdkA (Located [LIE GhcPs])
+addHaddockExports (L l_exports exports) =
+  delimitHdkA l_exports $ do
+    exports' <- addHaddockInterleaveItems getDocIE (mkHdkA pure) exports
+    sepHdkA (srcSpanEnd l_exports)
+    pure $ L l_exports exports'
+
+-- Add Haddock items to a list of non-Haddock items.
+-- Used to process export lists (with getDocIE) and declarations (with getDocDecl).
+addHaddockInterleaveItems
+  :: forall a.
+     (RealLocated HdkComment -> Maybe a) -- Get a documentation item
+  -> (a -> HdkA a) -- Process a non-documentation item
+  -> [a]           -- Unprocessed (non-documentation) items
+  -> HdkA [a]      -- Documentation items & processed non-documentation items
+addHaddockInterleaveItems getDocItem processItem = go
+  where
+    go :: [a] -> HdkA [a]
+    go [] = MkHdkA mempty (takeHdkComments getDocItem)
+    go (item : items) = do
+      docItems <- MkHdkA mempty (takeHdkComments getDocItem)
+      item' <- processItem item
+      other_items <- go items
+      pure $ docItems ++ item':other_items
+
+getDocDecl :: RealLocated HdkComment -> Maybe (LHsDecl GhcPs)
+getDocDecl a = mapLoc (DocD noExtField) <$> getDocDecl' a
+
+getDocDecl' :: RealLocated HdkComment -> Maybe LDocDecl
+getDocDecl' (L l_comment hdk_comment) =
+  Just $ L (RealSrcSpan l_comment) $
+    case hdk_comment of
+      HdkCommentNext doc -> DocCommentNext doc
+      HdkCommentPrev doc -> DocCommentPrev doc
+      HdkCommentNamed s doc -> DocCommentNamed s doc
+      HdkCommentSection n doc -> DocGroup n doc
+
+getDocIE :: RealLocated HdkComment -> Maybe (LIE GhcPs)
+getDocIE (L l_comment hdk_comment) =
+  case hdk_comment of
+    HdkCommentSection n doc -> Just $ L l (IEGroup noExtField n doc)
+    HdkCommentNamed s _doc -> Just $ L l (IEDocNamed noExtField s)
+    HdkCommentNext doc -> Just $ L l (IEDoc noExtField doc)
+    _ -> Nothing
+  where l = RealSrcSpan l_comment
+
+getDocNext :: RealLocated HdkComment -> Maybe LHsDocString
+getDocNext (L l (HdkCommentNext doc)) = Just $ L (RealSrcSpan l) doc
+getDocNext _ = Nothing
+
+getDocPrev :: RealLocated HdkComment -> Maybe LHsDocString
+getDocPrev (L l (HdkCommentPrev doc)) = Just $ L (RealSrcSpan l) doc
+getDocPrev _ = Nothing
+
+addHaddockDecl :: LHsDecl GhcPs -> HdkA (LHsDecl GhcPs)
+addHaddockDecl (L l_decl (SigD _ (TypeSig _ names t))) =
+  delimitHdkA l_decl $ do
+    traverse_ registerHdkA names
+    t' <- addHaddockSigWcType t
+    pure (L l_decl (SigD noExtField (TypeSig noExtField names t')))
+addHaddockDecl (L l_decl (SigD _ (ClassOpSig _ is_dflt names t))) =
+  delimitHdkA l_decl $ do
+    traverse_ registerHdkA names
+    t' <- addHaddockSigType t
+    pure (L l_decl (SigD noExtField (ClassOpSig noExtField is_dflt names t')))
+addHaddockDecl (L l_decl (TyClD _ decl))
+  | DataDecl { tcdLName, tcdTyVars, tcdFixity, tcdDataDefn = defn } <- decl
+  , HsDataDefn { dd_ND, dd_ctxt, dd_cType, dd_kindSig, dd_cons, dd_derivs } <- defn
+  = delimitHdkA l_decl $ do
+      registerHdkA tcdLName
+      traverse_ registerHdkA dd_kindSig
+      dd_cons' <- traverse addHaddockConDecl dd_cons
+      dd_derivs' <- addHaddockDeriving dd_derivs
+      pure $
+        let defn' = HsDataDefn
+                      { dd_ext = noExtField
+                      , dd_ND, dd_ctxt, dd_cType, dd_kindSig
+                      , dd_derivs = dd_derivs'
+                      , dd_cons = dd_cons' }
+            decl' = DataDecl
+                      { tcdDExt = noExtField
+                      , tcdLName, tcdTyVars, tcdFixity
+                      , tcdDataDefn = defn' }
+        in L l_decl (TyClD noExtField decl')
+  | ClassDecl { tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs,
+                tcdSigs, tcdMeths, tcdATs, tcdATDefs } <- decl
+  = delimitHdkA l_decl $ do
+      where_cls' <-
+        addHaddockInterleaveItems getDocDecl addHaddockDecl $
+        flattenBindsAndSigs (tcdMeths, tcdSigs, tcdATs, tcdATDefs, [], [])
+      sepHdkA (srcSpanEnd l_decl)
+      pure $
+        let (tcdMeths', tcdSigs', tcdATs', tcdATDefs', _, tcdDocs) = partitionBindsAndSigs id where_cls'
+            decl' = ClassDecl { tcdCExt = noExtField
+                              , tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs
+                              , tcdSigs = tcdSigs'
+                              , tcdMeths = tcdMeths'
+                              , tcdATs = tcdATs'
+                              , tcdATDefs = tcdATDefs'
+                              , tcdDocs }
+        in L l_decl (TyClD noExtField decl')
+addHaddockDecl (L l_decl (InstD _ decl))
+  | DataFamInstD { dfid_inst } <- decl
+  , DataFamInstDecl { dfid_eqn } <- dfid_inst
+  = delimitHdkA l_decl $ do
+    dfid_eqn' <- addHaddockImplicitBndrs (\fam_eqn -> case fam_eqn of
+      FamEqn { feqn_tycon, feqn_bndrs, feqn_pats, feqn_fixity, feqn_rhs }
+        | HsDataDefn { dd_ND, dd_ctxt, dd_cType, dd_kindSig, dd_cons, dd_derivs } <- feqn_rhs
+        -> do
+          registerHdkA feqn_tycon
+          traverse_ registerHdkA dd_kindSig
+          dd_cons' <- traverse addHaddockConDecl dd_cons
+          dd_derivs' <- addHaddockDeriving dd_derivs
+          pure $
+            let defn' = HsDataDefn
+                          { dd_ext = noExtField
+                          , dd_ND, dd_ctxt, dd_cType, dd_kindSig
+                          , dd_derivs = dd_derivs'
+                          , dd_cons = dd_cons' }
+            in FamEqn { feqn_ext = noExtField,
+                        feqn_tycon, feqn_bndrs, feqn_pats, feqn_fixity,
+                        feqn_rhs = defn' }
+      FamEqn { feqn_rhs = XHsDataDefn x } -> noExtCon x
+      XFamEqn x -> noExtCon x
+      ) dfid_eqn
+    pure $ L l_decl (InstD noExtField (DataFamInstD {
+      dfid_ext = noExtField,
+      dfid_inst = DataFamInstDecl { dfid_eqn = dfid_eqn' } }))
+addHaddockDecl (L l_decl (ForD _ decl))
+  = delimitHdkA l_decl $ do
+    decl' <-
+      case decl of
+        ForeignImport { fd_name, fd_sig_ty, fd_fi } -> do
+          registerHdkA fd_name
+          fd_sig_ty' <- addHaddockSigType fd_sig_ty
+          pure ForeignImport { fd_i_ext = noExtField,
+                               fd_sig_ty = fd_sig_ty',
+                               fd_name, fd_fi }
+        ForeignExport { fd_name, fd_sig_ty, fd_fe } -> do
+          registerHdkA fd_name
+          fd_sig_ty' <- addHaddockSigType fd_sig_ty
+          pure ForeignExport { fd_e_ext = noExtField,
+                               fd_sig_ty = fd_sig_ty',
+                               fd_name, fd_fe }
+        XForeignDecl x -> noExtCon x
+    pure $ L l_decl (ForD noExtField decl')
+addHaddockDecl d = delimitHdkA (getLoc d) (pure d)
+
+addHaddockDeriving :: HsDeriving GhcPs -> HdkA (HsDeriving GhcPs)
+addHaddockDeriving lderivs =
+  delimitHdkA (getLoc lderivs) $
+  for @Located lderivs $ \derivs ->
+    traverse addHaddockDerivingClause derivs
+
+addHaddockDerivingClause :: LHsDerivingClause GhcPs -> HdkA (LHsDerivingClause GhcPs)
+addHaddockDerivingClause lderiv =
+  delimitHdkA (getLoc lderiv) $
+  for @Located lderiv $ \deriv ->
+  case deriv of
+    HsDerivingClause { deriv_clause_strategy, deriv_clause_tys } -> do
+      traverse_ @Maybe registerHdkA deriv_clause_strategy
+      deriv_clause_tys' <-
+        delimitHdkA (getLoc deriv_clause_tys) $
+        for @Located (deriv_clause_tys) $ \tys ->
+          traverse addHaddockSigType tys
+      pure HsDerivingClause
+        { deriv_clause_ext = noExtField,
+          deriv_clause_strategy,
+          deriv_clause_tys = deriv_clause_tys' }
+    XHsDerivingClause x -> noExtCon x
+
+addHaddockConDecl :: LConDecl GhcPs -> HdkA (LConDecl GhcPs)
+addHaddockConDecl = mkHdkA $ \(L l_con con) -> do
+  trailingConDocs <- do
+    nextDocs <- peekHdkComments getDocNext `inLocRange` locRangeTo (srcSpanStart l_con)
+    -- See Note [Trailing comment on constructor declaration]
+    innerDocs <- peekHdkComments Just `inLocRange` locRangeFrom (srcSpanStart l_con)
+                                      `inLocRange` locRangeTo (srcSpanEnd l_con)
+    if null innerDocs && null nextDocs
+      then takeHdkComments getDocPrev `inLocRange` locRangeFrom (srcSpanEnd l_con)
+      else return []
+  let getConDoc = mkHdkA $ \(L l _) -> do
+        nextDocs <- takeHdkComments getDocNext `inLocRange` locRangeTo (srcSpanStart l)
+        prevDocs <- takeHdkComments getDocPrev `inLocRange` locRangeFrom (srcSpanEnd l)
+        return $ concatLHsDocString (nextDocs ++ prevDocs ++ trailingConDocs)
+      hdk_a_m (MkHdkA _ m) = m
+  hdk_a_m $ case con of
+    ConDeclGADT { con_g_ext, con_names, con_forall, con_qvars, con_mb_cxt, con_args, con_res_ty } -> do
+      con_doc' <- getConDoc (head con_names)
+      con_args' <-
+        case con_args of
+          PrefixCon ts -> do
+            ts' <- traverse addHaddockType ts
+            pure $ PrefixCon ts'
+          RecCon (L l_rec flds) -> do
+            flds' <- traverse addHaddockConDeclField flds
+            pure $ RecCon (L l_rec flds')
+          InfixCon _ _ -> panic "ConDeclGADT InfixCon"
+      con_res_ty' <- addHaddockType con_res_ty
+      pure $ L l_con $
+        ConDeclGADT { con_g_ext, con_names, con_forall, con_qvars, con_mb_cxt,
+                      con_doc = con_doc',
+                      con_args = con_args',
+                      con_res_ty = con_res_ty' }
+    ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, con_args } -> do
+      case con_args of
+        PrefixCon ts -> do
+          con_doc' <- getConDoc con_name
+          ts' <- traverse addHaddockType ts
+          pure $ L l_con $
+            ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,
+                         con_doc = con_doc',
+                         con_args = PrefixCon ts' }
+        InfixCon t1 t2 -> do
+          t1' <- addHaddockType t1
+          con_doc' <- getConDoc con_name
+          t2' <- addHaddockType t2
+          pure $ L l_con $
+            ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,
+                         con_doc = con_doc',
+                         con_args = InfixCon t1' t2' }
+        RecCon (L l_rec flds) -> do
+          con_doc' <- getConDoc con_name
+          flds' <- traverse addHaddockConDeclField flds
+          pure $ L l_con $
+            ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,
+                         con_doc = con_doc',
+                         con_args = RecCon (L l_rec flds') }
+    XConDecl x -> noExtCon x
+
+{- Note [Trailing comment on constructor declaration]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The trailing comment after a constructor declaration is associated with the
+constructor itself when there are no other comments inside the declaration:
+
+   data T = MkT A B        -- ^ Comment on MkT
+   data T = MkT { x :: A } -- ^ Comment on MkT
+
+When there are other comments, the trailing comment applies to the last field:
+
+   data T = MkT -- ^ Comment on MkT
+            A   -- ^ Comment on A
+            B   -- ^ Comment on B
+
+   data T =
+     MkT { a :: A   -- ^ Comment on a
+         , b :: B   -- ^ Comment on b
+         , c :: C } -- ^ Comment on c
+-}
+
+addHaddockConDeclField :: LConDeclField GhcPs -> HdkA (LConDeclField GhcPs)
+addHaddockConDeclField = mkHdkA $ \(L l_fld fld) -> do
+  nextDocs <- takeHdkComments getDocNext `inLocRange` locRangeTo (srcSpanStart l_fld)
+  prevDocs <- takeHdkComments getDocPrev `inLocRange` locRangeFrom (srcSpanEnd l_fld)
+  let cd_fld_doc = concatLHsDocString (nextDocs ++ prevDocs)
+  return $ L l_fld $ case fld of
+    ConDeclField { cd_fld_ext, cd_fld_names, cd_fld_type } ->
+      ConDeclField { cd_fld_ext, cd_fld_names, cd_fld_type, cd_fld_doc }
+    XConDeclField x -> noExtCon x
+
+addHaddockWildCardBndrs
+  :: (a -> HdkA a)
+  -> HsWildCardBndrs GhcPs a
+  -> HdkA (HsWildCardBndrs GhcPs a)
+addHaddockWildCardBndrs f (HsWC _ t) = HsWC noExtField <$> f t
+addHaddockWildCardBndrs _ (XHsWildCardBndrs x) = noExtCon x
+
+addHaddockImplicitBndrs
+  :: (a -> HdkA a)
+  -> HsImplicitBndrs GhcPs a
+  -> HdkA (HsImplicitBndrs GhcPs a)
+addHaddockImplicitBndrs f (HsIB _ t) = HsIB noExtField <$> f t
+addHaddockImplicitBndrs _ (XHsImplicitBndrs x) = noExtCon x
+
+addHaddockSigType :: LHsSigType GhcPs -> HdkA (LHsSigType GhcPs)
+addHaddockSigType = addHaddockImplicitBndrs addHaddockType
+
+addHaddockSigWcType :: LHsSigWcType GhcPs -> HdkA (LHsSigWcType GhcPs)
+addHaddockSigWcType = addHaddockWildCardBndrs addHaddockSigType
+
+addHaddockType :: LHsType GhcPs -> HdkA (LHsType GhcPs)
+addHaddockType (L l_t (HsForAllTy _ fvf bndrs body)) =
+  delimitHdkA l_t $ do
+    body' <- addHaddockType body
+    pure (L l_t (HsForAllTy noExtField fvf bndrs body'))
+addHaddockType (L l_t (HsQualTy _ lhs rhs)) =
+  delimitHdkA l_t $ do
+    rhs' <- addHaddockType rhs
+    pure (L l_t (HsQualTy noExtField lhs rhs'))
+addHaddockType (L l_t (HsFunTy _ lhs rhs)) =
+  delimitHdkA l_t $ do
+    lhs' <- addHaddockType lhs
+    rhs' <- addHaddockType rhs
+    pure (L l_t (HsFunTy noExtField lhs' rhs'))
+addHaddockType t = mkHdkA go t where
+  go t' = do
+    nextDocs <- takeHdkComments getDocNext `inLocRange` locRangeTo (getLocStart t')
+    prevDocs <- takeHdkComments getDocPrev `inLocRange` locRangeFrom (getLocEnd t')
+    let mDoc = concatLHsDocString (nextDocs ++ prevDocs)
+    return $ mkLHsDocTyMaybe t mDoc
+
+data LowerLocBound = StartOfFile | StartLoc RealSrcLoc
+
+instance Semigroup LowerLocBound where
+  StartOfFile <> l = l
+  l <> StartOfFile = l
+  StartLoc l1 <> StartLoc l2 = StartLoc (max l1 l2)
+
+instance Monoid LowerLocBound where
+  mempty = StartOfFile
+
+data UpperLocBound = EndOfFile | EndLoc RealSrcLoc
+
+instance Semigroup UpperLocBound where
+  EndOfFile <> l = l
+  l <> EndOfFile = l
+  EndLoc l1 <> EndLoc l2 = EndLoc (min l1 l2)
+
+instance Monoid UpperLocBound where
+  mempty = EndOfFile
+
+-- | A location range for extracting documentation comments.
+data LocRange =
+  LocRange
+    LowerLocBound  -- from
+    UpperLocBound  -- to
+
+instance Semigroup LocRange where
+  LocRange from1 to1 <> LocRange from2 to2 =
+    LocRange (from1 <> from2) (to1 <> to2)
+
+instance Monoid LocRange where
+  mempty = LocRange mempty mempty
+
+locRangeFrom :: SrcLoc -> LocRange
+locRangeFrom (UnhelpfulLoc _) = mempty
+locRangeFrom (RealSrcLoc l) = LocRange (StartLoc l) EndOfFile
+
+locRangeTo :: SrcLoc -> LocRange
+locRangeTo (UnhelpfulLoc _) = mempty
+locRangeTo (RealSrcLoc l) = LocRange StartOfFile (EndLoc l)
+
+inLocRange :: HdkM a -> LocRange -> HdkM a
+m `inLocRange` r = mkHdkM $ \range -> unHdkM m (r <> range)
+
+-- | The state monad but without newtype wrapping/unwrapping.
+type InlineState s a = s -> (a, s)
+
+-- Take the Haddock comments that satisfy the matching function,
+-- leaving the rest pending.
+takeHdkComments :: forall a. (RealLocated HdkComment -> Maybe a) -> HdkM [a]
+takeHdkComments f =
+  mkHdkM $ \range ->
+  case range of
+    LocRange hdk_from hdk_to ->
+      zoom_after hdk_from $
+      zoom_before hdk_to $
+      foldr add_comment ([], [])
+  where
+    add_comment
+      :: RealLocated HdkComment
+      -> ([a], [RealLocated HdkComment])
+      -> ([a], [RealLocated HdkComment])
+    add_comment hdk_comment (items, other_hdk_comments) =
+      case f hdk_comment of
+        Just item -> (item : items, other_hdk_comments)
+        Nothing -> (items, hdk_comment : other_hdk_comments)
+
+    zoom_after
+      :: LowerLocBound
+      -> InlineState [RealLocated e] x
+      -> InlineState [RealLocated e] x
+    zoom_after StartOfFile m = m
+    zoom_after (StartLoc l) m =
+      \comments ->
+        let
+          is_after (L l_comment _) = realSrcSpanStart l_comment >= l
+          (comments_before, comments_after) = break is_after comments
+          (result, other_comments) = m comments_after
+        in
+          -- 'comments_before' will typically include only incorrectly
+          -- positioned comments, so the concatenation cost is small.
+          (result, comments_before ++ other_comments)
+
+    zoom_before
+      :: UpperLocBound
+      -> InlineState [RealLocated e] x
+      -> InlineState [RealLocated e] x
+    zoom_before EndOfFile m = m
+    zoom_before (EndLoc l) m =
+      \comments ->
+        let
+          is_before (L l_comment _) = realSrcSpanStart l_comment <= l
+          (comments_before, comments_after) = span is_before comments
+          (result, other_comments) = m comments_before
+        in
+          -- 'other_comments' will typically include only incorrectly
+          -- positioned comments, so the concatenation cost is small.
+          (result, other_comments ++ comments_after)
+
+-- | Peek at the Haddock comments that satisfy the matching function. Unlike
+-- 'takeHdkComments', leave them pending.
+peekHdkComments :: (RealLocated HdkComment -> Maybe a) -> HdkM [a]
+peekHdkComments f =
+  mkHdkM $ \range comments ->
+    let (r, _) = unHdkM (takeHdkComments f) range comments
+    in (r, comments)
+
+mkLHsDocTy :: LHsType GhcPs -> LHsDocString -> LHsType GhcPs
+mkLHsDocTy t doc =
+  let loc = getLoc t `combineSrcSpans` getLoc doc
+  in L loc (HsDocTy noExtField t doc)
+
+mkLHsDocTyMaybe :: LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs
+mkLHsDocTyMaybe t = maybe t (mkLHsDocTy t)
 
 -- -----------------------------------------------------------------------------
 -- Adding documentation to record fields (used in parsing).
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index fc6779a..8598bdf 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -66,7 +66,8 @@ module Lexer (
    lexTokenStream,
    AddAnn(..),mkParensApiAnn,
    addAnnsAt,
-   commentToAnnotation
+   commentToAnnotation,
+   HdkComment(..),
   ) where
 
 import GhcPrelude
@@ -99,6 +100,7 @@ import Outputable
 import StringBuffer
 import FastString
 import UniqFM
+import Maybes
 import Util             ( readRational, readHexRational )
 
 -- compiler/main
@@ -111,6 +113,7 @@ import Module
 import BasicTypes     ( InlineSpec(..), RuleMatchInfo(..),
                         IntegralLit(..), FractionalLit(..),
                         SourceText(..) )
+import GHC.Hs.Doc
 
 -- compiler/parser
 import Ctype
@@ -1193,11 +1196,8 @@ nested_comment cont span buf len = do
   go (reverse $ lexemeToString buf len) (1::Int) input
   where
     go commentAcc 0 input = do
-      setInput input
-      b <- getBit RawTokenStreamBit
-      if b
-        then docCommentEnd input commentAcc ITblockComment buf span
-        else cont
+      let finalizeComment str = (Nothing, ITblockComment str)
+      commentEnd cont input commentAcc finalizeComment buf span
     go commentAcc n input = case alexGetChar' input of
       Nothing -> errBrace input span
       Just ('-',input) -> case alexGetChar' input of
@@ -1287,24 +1287,37 @@ return control to parseNestedPragma by returning the ITcomment_line_prag token.
 See #314 for more background on the bug this fixes.
 -}
 
-withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (RealLocated Token))
+withLexedDocType :: (AlexInput -> (String -> (HdkComment, Token)) -> Bool -> P (RealLocated Token))
                  -> P (RealLocated Token)
 withLexedDocType lexDocComment = do
   input@(AI _ buf) <- getInput
   case prevChar buf ' ' of
     -- The `Bool` argument to lexDocComment signals whether or not the next
     -- line of input might also belong to this doc comment.
-    '|' -> lexDocComment input ITdocCommentNext True
-    '^' -> lexDocComment input ITdocCommentPrev True
-    '$' -> lexDocComment input ITdocCommentNamed True
+    '|' -> lexDocComment input mkHdkCommentNext True
+    '^' -> lexDocComment input mkHdkCommentPrev True
+    '$' -> lexDocComment input mkHdkCommentNamed True
     '*' -> lexDocSection 1 input
     _ -> panic "withLexedDocType: Bad doc type"
  where
     lexDocSection n input = case alexGetChar' input of
       Just ('*', input) -> lexDocSection (n+1) input
-      Just (_,   _)     -> lexDocComment input (ITdocSection n) False
+      Just (_,   _)     -> lexDocComment input (mkHdkCommentSection n) False
       Nothing -> do setInput input; lexToken -- eof reached, lex it normally
 
+mkHdkCommentNext, mkHdkCommentPrev :: String -> (HdkComment, Token)
+mkHdkCommentNext str = (HdkCommentNext (mkHsDocString str), ITdocCommentNext str)
+mkHdkCommentPrev str = (HdkCommentPrev (mkHsDocString str), ITdocCommentPrev str)
+
+mkHdkCommentNamed :: String -> (HdkComment, Token)
+mkHdkCommentNamed str =
+  let (name, rest) = break isSpace str
+  in (HdkCommentNamed name (mkHsDocString rest), ITdocCommentNamed str)
+
+mkHdkCommentSection :: Int -> String -> (HdkComment, Token)
+mkHdkCommentSection n str =
+  (HdkCommentSection n (mkHsDocString str), ITdocSection n str)
+
 -- RULES pragmas turn on the forall and '.' keywords, and we turn them
 -- off again at the end of the pragma.
 rulePrag :: Action
@@ -1347,9 +1360,14 @@ endPrag span _buf _len = do
 -- it writes the wrong token length to the parser state. This function is
 -- called afterwards, so it can just update the state.
 
-docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer ->
-                 RealSrcSpan -> P (RealLocated Token)
-docCommentEnd input commentAcc docType buf span = do
+commentEnd :: P (RealLocated Token)
+           -> AlexInput
+           -> String
+           -> (String -> (Maybe HdkComment, Token))
+           -> StringBuffer
+           -> RealSrcSpan
+           -> P (RealLocated Token)
+commentEnd cont input commentAcc finalizeComment buf span = do
   setInput input
   let (AI loc nextBuf) = input
       comment = reverse commentAcc
@@ -1357,7 +1375,20 @@ docCommentEnd input commentAcc docType buf span = do
       last_len = byteDiff buf nextBuf
 
   span `seq` setLastToken span' last_len
-  return (L span' (docType comment))
+  let (m_hdk_comment, hdk_token) = finalizeComment comment
+  whenIsJust m_hdk_comment $ \hdk_comment ->
+    P $ \s -> POk (s {hdk_comments = L span' hdk_comment : hdk_comments s}) ()
+  b <- getBit RawTokenStreamBit
+  if b then return (L span' hdk_token)
+       else cont
+
+docCommentEnd :: AlexInput -> String -> (String -> (HdkComment, Token)) -> StringBuffer ->
+                 RealSrcSpan -> P (RealLocated Token)
+docCommentEnd input commentAcc docType buf span = do
+  let finalizeComment str =
+        let (hdk_comment, token) = docType str
+        in (Just hdk_comment, token)
+  commentEnd lexToken input commentAcc finalizeComment buf span
 
 errBrace :: AlexInput -> RealSrcSpan -> P a
 errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) end "unterminated `{-'"
@@ -2085,6 +2116,13 @@ data ParserFlags = ParserFlags {
   , pExtsBitmap     :: !ExtsBitmap -- ^ bitmap of permitted extensions
   }
 
+data HdkComment
+  = HdkCommentNext HsDocString
+  | HdkCommentPrev HsDocString
+  | HdkCommentNamed String HsDocString
+  | HdkCommentSection Int HsDocString
+  deriving Show
+
 data PState = PState {
         buffer     :: StringBuffer,
         options    :: ParserFlags,
@@ -2125,7 +2163,10 @@ data PState = PState {
         -- See note [Api annotations] in ApiAnnotation.hs
         annotations :: [(ApiAnnKey,[SrcSpan])],
         comment_q :: [Located AnnotationComment],
-        annotations_comments :: [(SrcSpan,[Located AnnotationComment])]
+        annotations_comments :: [(SrcSpan,[Located AnnotationComment])],
+
+        -- Haddock comments
+        hdk_comments :: [RealLocated HdkComment]
      }
         -- last_loc and last_len are used when generating error messages,
         -- and in pushCurrentContext only.  Sigh, if only Happy passed the
@@ -2599,7 +2640,8 @@ mkPStatePure options buf loc =
       alr_justClosedExplicitLetBlock = False,
       annotations = [],
       comment_q = [],
-      annotations_comments = []
+      annotations_comments = [],
+      hdk_comments = []
     }
 
 -- | An mtl-style class for monads that support parsing-related operations.
@@ -2819,10 +2861,6 @@ lexer queueComments cont = do
     ITeof -> addAnnotationOnly noSrcSpan AnnEofPos (RealSrcSpan span)
     _ -> return ()
 
-  if (queueComments && isDocComment tok)
-    then queueComment (L (RealSrcSpan span) tok)
-    else return ()
-
   if (queueComments && isComment tok)
     then queueComment (L (RealSrcSpan span) tok) >> lexer queueComments cont
     else cont (L (RealSrcSpan span) tok)
@@ -3269,13 +3307,10 @@ commentToAnnotation _                           = panic "commentToAnnotation"
 isComment :: Token -> Bool
 isComment (ITlineComment     _)   = True
 isComment (ITblockComment    _)   = True
+isComment (ITdocCommentNext  _)   = True
+isComment (ITdocCommentPrev  _)   = True
+isComment (ITdocCommentNamed _)   = True
+isComment (ITdocSection      _ _) = True
+isComment (ITdocOptions      _)   = True
 isComment _ = False
-
-isDocComment :: Token -> Bool
-isDocComment (ITdocCommentNext  _)   = True
-isDocComment (ITdocCommentPrev  _)   = True
-isDocComment (ITdocCommentNamed _)   = True
-isDocComment (ITdocSection      _ _) = True
-isDocComment (ITdocOptions      _)   = True
-isDocComment _ = False
 }
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index ce4d277..769f9eb 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -67,6 +67,7 @@ import DataCon          ( DataCon, dataConName )
 import SrcLoc
 import Module
 import BasicTypes
+import GHC.Hs.Doc
 
 -- compiler/types
 import Type             ( funTyCon )
@@ -621,7 +622,7 @@ TH_QQUASIQUOTE  { L _ (ITqQuasiQuote _) }
 %tokentype { (Located Token) }
 
 -- Exported parsers
-%name parseModule module
+%name parseModuleNoHaddock module
 %name parseSignature signature
 %name parseImport importdecl
 %name parseStatement e_stmt
@@ -4126,4 +4127,7 @@ oll l =
 asl :: [Located a] -> Located b -> Located a -> P ()
 asl [] (L ls _) (L l _) = addAnnotation l          AnnSemi ls
 asl (x:_xs) (L ls _) _x = addAnnotation (getLoc x) AnnSemi ls
+
+parseModule :: P (Located (HsModule GhcPs))
+parseModule = parseModuleNoHaddock >>= addModuleHaddock
 }
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 75ce613..f93e12a 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -124,7 +124,6 @@ import PrelNames        ( allNameStrings )
 import SrcLoc
 import Unique           ( hasKey )
 import OrdList          ( OrdList, fromOL )
-import Bag              ( emptyBag, consBag )
 import Outputable
 import FastString
 import Maybes
@@ -417,33 +416,18 @@ cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
 -- Input decls contain just value bindings and signatures
 -- and in case of class or instance declarations also
 -- associated type declarations. They might also contain Haddock comments.
-cvBindsAndSigs fb = go (fromOL fb)
+cvBindsAndSigs fb = do
+  fb' <- drop_bad_decls (fromOL fb)
+  return (partitionBindsAndSigs (uncurry getMonoBind) fb')
   where
-    go []              = return (emptyBag, [], [], [], [], [])
-    go ((L l (ValD _ b)) : ds)
-      = do { (bs, ss, ts, tfis, dfis, docs) <- go ds'
-           ; return (b' `consBag` bs, ss, ts, tfis, dfis, docs) }
-      where
-        (b', ds') = getMonoBind (L l b) ds
-    go ((L l decl) : ds)
-      = do { (bs, ss, ts, tfis, dfis, docs) <- go ds
-           ; case decl of
-               SigD _ s
-                 -> return (bs, L l s : ss, ts, tfis, dfis, docs)
-               TyClD _ (FamDecl _ t)
-                 -> return (bs, ss, L l t : ts, tfis, dfis, docs)
-               InstD _ (TyFamInstD { tfid_inst = tfi })
-                 -> return (bs, ss, ts, L l tfi : tfis, dfis, docs)
-               InstD _ (DataFamInstD { dfid_inst = dfi })
-                 -> return (bs, ss, ts, tfis, L l dfi : dfis, docs)
-               DocD _ d
-                 -> return (bs, ss, ts, tfis, dfis, L l d : docs)
-               SpliceD _ d
-                 -> addFatalError l $
-                    hang (text "Declaration splices are allowed only" <+>
-                          text "at the top level:")
-                       2 (ppr d)
-               _ -> pprPanic "cvBindsAndSigs" (ppr decl) }
+    drop_bad_decls [] = return []
+    drop_bad_decls (L l (SpliceD _ d) : ds) = do
+      addError l $
+        hang (text "Declaration splices are allowed only" <+>
+              text "at the top level:")
+           2 (ppr d)
+      drop_bad_decls ds
+    drop_bad_decls (d:ds) = (d:) <$> drop_bad_decls ds
 
 -----------------------------------------------------------------------------
 -- Group function bindings into equation groups
diff --git a/testsuite/tests/ghc-api/T11579.hs b/testsuite/tests/ghc-api/T11579.hs
index 3294f99..78ec7d3 100644
--- a/testsuite/tests/ghc-api/T11579.hs
+++ b/testsuite/tests/ghc-api/T11579.hs
@@ -13,14 +13,14 @@ main = do
     let stringBuffer = stringToStringBuffer "-- $bar some\n-- named chunk"
         loc = mkRealSrcLoc (mkFastString "Foo.hs") 1 1
 
-    token <- runGhc (Just libdir) $ do
+    hdk_comments <- runGhc (Just libdir) $ do
         dflags <- getSessionDynFlags
         let pstate = mkPState (dflags `gopt_set` Opt_Haddock) stringBuffer loc
         case unP (lexer False return) pstate of
-            POk _ token -> return (unLoc token)
-            _           -> error "No token"
+            POk s (L _ ITeof) -> return (map unLoc (hdk_comments s))
+            _                 -> error "No token"
 
     -- #11579
     -- Expected:                    "ITdocCommentNamed "bar some\n named chunk"
     -- Actual (with ghc-8.0.1-rc2): "ITdocCommentNamed "bar some"
-    print token
+    mapM_ print hdk_comments
diff --git a/testsuite/tests/ghc-api/T11579.stdout b/testsuite/tests/ghc-api/T11579.stdout
index 7603e53..24f3bf5 100644
--- a/testsuite/tests/ghc-api/T11579.stdout
+++ b/testsuite/tests/ghc-api/T11579.stdout
@@ -1 +1 @@
-ITdocCommentNamed "bar some\n named chunk"
+HdkCommentNamed "bar" (HsDocString " some\n named chunk")
diff --git a/testsuite/tests/ghc-api/annotations/comments.stdout b/testsuite/tests/ghc-api/annotations/comments.stdout
index 06273ba..e5ff216 100644
--- a/testsuite/tests/ghc-api/annotations/comments.stdout
+++ b/testsuite/tests/ghc-api/annotations/comments.stdout
@@ -1,12 +1,11 @@
 [
-( CommentsTest.hs:11:1-33 =
-[(CommentsTest.hs:11:1-33,AnnDocCommentNext " The function @foo@ does blah")])
-
 ( CommentsTest.hs:(12,7)-(15,14) =
 [(CommentsTest.hs:14:15-24,AnnLineComment "-- value 2")])
 
 ( <no location info> =
-[(CommentsTest.hs:(3,1)-(7,2),AnnBlockComment "{-\nAn opening comment\n  {- with a nested one -}\n  {-# nested PRAGMA #-}\n-}"),
+[(CommentsTest.hs:11:1-33,AnnDocCommentNext " The function @foo@ does blah"),
+
+(CommentsTest.hs:(3,1)-(7,2),AnnBlockComment "{-\nAn opening comment\n  {- with a nested one -}\n  {-# nested PRAGMA #-}\n-}"),
 
 (CommentsTest.hs:1:1-31,AnnBlockComment "{-# LANGUAGE DeriveFoldable #-}")])
 ]
diff --git a/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr b/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr
index d230d58..7e88893 100644
--- a/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr
+++ b/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr
@@ -62,7 +62,7 @@ data T a b
   = " This comment describes the 'A' constructor"
     A Int (Maybe Float) |
     " This comment describes the 'B' constructor"
-    B (T a b, T Int Float)
+    B (T a b, T Int Float) ""
 <document comment>
 data T2 a b = T2 a b
 <document comment>
@@ -89,7 +89,7 @@ newtype N6 a b = " docs on the constructor only" N6 {n6 :: a b}
 newtype N7 a b = " The 'N7' constructor" N7 {n7 :: a b}
 class (D a) => C a where
   a :: IO a
-  b :: [a]
+  b :: [a] " this is a description of the 'b' method"
   c :: a
 <document comment>
 class D a where
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/all.T b/testsuite/tests/haddock/should_compile_flag_haddock/all.T
index c7b9d91..554c621 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/all.T
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/all.T
@@ -7,53 +7,53 @@
 # When adding a new test here, think about adding it to the
 # should_compile_noflag_haddock directory as well.
 
-test('haddockA001', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA002', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA003', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA004', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA005', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA006', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA007', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA008', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA009', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA010', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA011', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA012', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA013', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA014', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA015', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA016', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA017', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA018', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA019', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA020', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA021', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA022', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA023', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA024', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA025', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA026', normal, compile, ['-haddock -ddump-parsed -XRankNTypes'])
-test('haddockA027', normal, compile, ['-haddock -ddump-parsed -XRankNTypes'])
-test('haddockA028', normal, compile, ['-haddock -ddump-parsed -XTypeOperators'])
-test('haddockA029', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA030', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA031', normal, compile, ['-haddock -ddump-parsed -XExistentialQuantification'])
-test('haddockA032', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA035', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA036', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA037', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA038', normal, compile, ['-haddock -ddump-parsed'])
+test('haddockA001', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA002', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA003', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA004', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA005', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA006', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA007', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA008', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA009', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA010', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA011', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA012', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA013', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA014', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA015', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA016', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA017', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA018', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA019', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA020', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA021', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA022', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA023', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA024', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA025', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA026', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed -XRankNTypes'])
+test('haddockA027', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed -XRankNTypes'])
+test('haddockA028', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed -XTypeOperators'])
+test('haddockA029', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA030', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA031', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed -XExistentialQuantification'])
+test('haddockA032', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA035', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA036', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA037', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA038', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
 
 # The tests below this line are not duplicated in
 # should_compile_noflag_haddock.
 
-test('haddockA033', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA034', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA039', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA040', normal, compile, ['-haddock -ddump-parsed'])
-test('haddockA041', [extra_files(['IncludeMe.hs'])], compile, ['-haddock -ddump-parsed'])
-test('T10398', normal, compile, ['-haddock -ddump-parsed'])
-test('T11768', normal, compile, ['-haddock -ddump-parsed'])
-test('T15206', normal, compile, ['-haddock -ddump-parsed'])
-test('T16585', normal, compile, ['-haddock -ddump-parsed'])
-test('T17561', expect_broken(17561), compile, ['-haddock -ddump-parsed'])
+test('haddockA033', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA034', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA039', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA040', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('haddockA041', [expect_broken(17632), extra_files(['IncludeMe.hs'])], compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('T10398', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('T11768', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('T15206', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('T16585', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
+test('T17561', normal, compile, ['-haddock -Wignored-haddock -ddump-parsed'])
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA022.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA022.stderr
index 6e6c5c6..66ea563 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA022.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA022.stderr
@@ -1,9 +1,19 @@
 
 ==================== Parser ====================
-main = print (test :: Int)
-     where
-	 test = 0
-	 test2 = 1
-	 test3 = 2
+main
+  = print (test :: Int)
+  where
+      test = 0
+      test2 = 1
+      test3 = 2
 
 
+
+haddockA022.hs:4:5: warning: [-Wignored-haddock]
+    A Haddock comment cannot appear in this position and will be ignored.
+
+haddockA022.hs:6:5: warning: [-Wignored-haddock]
+    A Haddock comment cannot appear in this position and will be ignored.
+
+haddockA022.hs:10:5: warning: [-Wignored-haddock]
+    A Haddock comment cannot appear in this position and will be ignored.
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA030.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA030.stderr
index e09cfa2..470141a 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA030.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA030.stderr
@@ -2,7 +2,10 @@
 ==================== Parser ====================
 module ShouldCompile where
 data A
-  = " comment for A " A |
+  = " A comment that documents the first constructor
+
+ comment for A "
+    A |
     " comment for B " B |
     " comment for C  " C |
     D
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA033.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA033.stderr
index c1760c1..f0be310 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA033.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA033.stderr
@@ -9,3 +9,9 @@ f 3 = 6
 <document comment>
 
 
+
+haddockA033.hs:5:1: warning: [-Wignored-haddock]
+    A Haddock comment cannot appear in this position and will be ignored.
+
+haddockA033.hs:7:1: warning: [-Wignored-haddock]
+    A Haddock comment cannot appear in this position and will be ignored.