Serialize docstrings to ifaces, display them with new GHCi :doc command

If `-haddock` is set, we now extract docstrings from the renamed ast
and serialize them in the .hi-files.

This includes some of the changes from D4749 with the notable
exceptions of the docstring lexing and renaming.

A currently limited and experimental GHCi :doc command can be used
to display docstrings for declarations.

The formatting of pretty-printed docstrings is changed slightly,
causing some changes in testsuite/tests/haddock.

Test Plan: ./validate

Reviewers: alexbiehl, hvr, gershomb, harpocrates, bgamari

Reviewed By: alexbiehl

Subscribers: rwbarton, thomie, carter

Differential Revision: https://phabricator.haskell.org/D4758

42 files changed, 816 insertions, 91 deletions

diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs
index 2f3fead184..b987130802 100644
--- a/compiler/deSugar/Desugar.hs
+++ b/compiler/deSugar/Desugar.hs
@@ -60,6 +60,7 @@ import Coverage
 import Util
 import MonadUtils
 import OrdList
+import ExtractDocs
 
 import Data.List
 import Data.IORef
@@ -183,6 +184,8 @@ deSugar hsc_env
 
         ; foreign_files <- readIORef th_foreign_files_var
 
+        ; let (doc_hdr, decl_docs, arg_docs) = extractDocs tcg_env
+
         ; let mod_guts = ModGuts {
                 mg_module       = mod,
                 mg_hsc_src      = hsc_src,
@@ -209,7 +212,10 @@ deSugar hsc_env
                 mg_modBreaks    = modBreaks,
                 mg_safe_haskell = safe_mode,
                 mg_trust_pkg    = imp_trust_own_pkg imports,
-                mg_complete_sigs = complete_matches
+                mg_complete_sigs = complete_matches,
+                mg_doc_hdr      = doc_hdr,
+                mg_decl_docs    = decl_docs,
+                mg_arg_docs     = arg_docs
               }
         ; return (msgs, Just mod_guts)
         }}}}
diff --git a/compiler/deSugar/ExtractDocs.hs b/compiler/deSugar/ExtractDocs.hs
new file mode 100644
index 0000000000..fc57f98569
--- /dev/null
+++ b/compiler/deSugar/ExtractDocs.hs
@@ -0,0 +1,344 @@
+-- | Extract docs from the renamer output so they can be be serialized.
+{-# language LambdaCase #-}
+{-# language TypeFamilies #-}
+module ExtractDocs (extractDocs) where
+
+import GhcPrelude
+import Bag
+import HsBinds
+import HsDoc
+import HsDecls
+import HsExtension
+import HsTypes
+import HsUtils
+import Name
+import NameSet
+import SrcLoc
+import TcRnTypes
+
+import Control.Applicative
+import Data.List
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe
+import Data.Semigroup
+
+-- | Extract docs from renamer output.
+extractDocs :: TcGblEnv
+            -> (Maybe HsDocString, DeclDocMap, ArgDocMap)
+            -- ^
+            -- 1. Module header
+            -- 2. Docs on top level declarations
+            -- 3. Docs on arguments
+extractDocs TcGblEnv { tcg_semantic_mod = mod
+                     , tcg_rn_decls = mb_rn_decls
+                     , tcg_insts = insts
+                     , tcg_fam_insts = fam_insts
+                     , tcg_doc_hdr = mb_doc_hdr
+                     } =
+    (unLoc <$> mb_doc_hdr, DeclDocMap doc_map, ArgDocMap arg_map)
+  where
+    (doc_map, arg_map) = maybe (M.empty, M.empty)
+                               (mkMaps local_insts)
+                               mb_decls_with_docs
+    mb_decls_with_docs = topDecls <$> mb_rn_decls
+    local_insts = filter (nameIsLocalOrFrom mod)
+                         $ map getName insts ++ map getName fam_insts
+
+-- | Create decl and arg doc-maps by looping through the declarations.
+-- For each declaration, find its names, its subordinates, and its doc strings.
+mkMaps :: [Name]
+       -> [(LHsDecl GhcRn, [HsDocString])]
+       -> (Map Name (HsDocString), Map Name (Map Int (HsDocString)))
+mkMaps instances decls =
+    ( f' (map (nubByName fst) decls')
+    , f  (filterMapping (not . M.null) args)
+    )
+  where
+    (decls', args) = unzip (map mappings decls)
+
+    f :: (Ord a, Semigroup b) => [[(a, b)]] -> Map a b
+    f = M.fromListWith (<>) . concat
+
+    f' :: Ord a => [[(a, HsDocString)]] -> Map a HsDocString
+    f' = M.fromListWith appendDocs . concat
+
+    filterMapping :: (b -> Bool) ->  [[(a, b)]] -> [[(a, b)]]
+    filterMapping p = map (filter (p . snd))
+
+    mappings :: (LHsDecl GhcRn, [HsDocString])
+             -> ( [(Name, HsDocString)]
+                , [(Name, Map Int (HsDocString))]
+                )
+    mappings (L l decl, docStrs) =
+           (dm, am)
+      where
+        doc = concatDocs docStrs
+        args = declTypeDocs decl
+
+        subs :: [(Name, [(HsDocString)], Map Int (HsDocString))]
+        subs = subordinates instanceMap decl
+
+        (subDocs, subArgs) =
+          unzip (map (\(_, strs, m) -> (concatDocs strs, m)) subs)
+
+        ns = names l 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
+
+    instanceMap :: Map SrcSpan Name
+    instanceMap = M.fromList [(getSrcSpan n, n) | n <- instances]
+
+    names :: SrcSpan -> HsDecl GhcRn -> [Name]
+    names l (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See
+                                                                 -- Note [1].
+      where loc = case d of
+              TyFamInstD _ _ -> l -- The CoAx's loc is the whole line, but only
+                                  -- for TFs
+              _ -> getInstLoc d
+    names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See Note [1].
+    names _ decl = getMainDeclBinder decl
+
+{-
+Note [1]:
+---------
+We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried
+inside them. That should work for normal user-written instances (from
+looking at GHC sources). We can assume that commented instances are
+user-written. This lets us relate Names (from ClsInsts) to comments
+(associated with InstDecls and DerivDecls).
+-}
+
+getMainDeclBinder :: HsDecl pass -> [IdP pass]
+getMainDeclBinder (TyClD _ d) = [tcdName d]
+getMainDeclBinder (ValD _ d) =
+  case collectHsBindBinders d of
+    []       -> []
+    (name:_) -> [name]
+getMainDeclBinder (SigD _ d) = sigNameNoLoc d
+getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name]
+getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = []
+getMainDeclBinder _ = []
+
+sigNameNoLoc :: Sig pass -> [IdP pass]
+sigNameNoLoc (TypeSig    _   ns _)         = map unLoc ns
+sigNameNoLoc (ClassOpSig _ _ ns _)         = map unLoc ns
+sigNameNoLoc (PatSynSig  _   ns _)         = map unLoc ns
+sigNameNoLoc (SpecSig    _   n _ _)        = [unLoc n]
+sigNameNoLoc (InlineSig  _   n _)          = [unLoc n]
+sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns
+sigNameNoLoc _                             = []
+
+-- Extract the source location where an instance is defined. This is used
+-- to correlate InstDecls with their Instance/CoAxiom Names, via the
+-- instanceMap.
+getInstLoc :: InstDecl name -> SrcSpan
+getInstLoc = \case
+  ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc (hsSigType ty)
+  DataFamInstD _ (DataFamInstDecl
+    { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}}) -> l
+  TyFamInstD _ (TyFamInstDecl
+    -- Since CoAxioms' Names refer to the whole line for type family instances
+    -- in particular, we need to dig a bit deeper to pull out the entire
+    -- equation. This does not happen for data family instances, for some
+    -- reason.
+    { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}}) -> l
+  ClsInstD _ (XClsInstDecl _) -> error "getInstLoc"
+  DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc"
+  TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc"
+  XInstDecl _ -> error "getInstLoc"
+  DataFamInstD _ (DataFamInstDecl (XHsImplicitBndrs _)) -> error "getInstLoc"
+  TyFamInstD _ (TyFamInstDecl (XHsImplicitBndrs _)) -> error "getInstLoc"
+
+-- | Get all subordinate declarations inside a declaration, and their docs.
+-- A subordinate declaration is something like the associate type or data
+-- family of a type class.
+subordinates :: Map SrcSpan Name
+             -> HsDecl GhcRn
+             -> [(Name, [(HsDocString)], Map Int (HsDocString))]
+subordinates instMap decl = case decl of
+  InstD _ (ClsInstD _ d) -> do
+    DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+      FamEqn { feqn_tycon = L l _
+             , feqn_rhs   = defn }}} <- unLoc <$> cid_datafam_insts d
+    [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn
+
+  InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d })))
+    -> dataSubs (feqn_rhs d)
+  TyClD _ d | isClassDecl d -> classSubs d
+            | isDataDecl  d -> dataSubs (tcdDataDefn d)
+  _ -> []
+  where
+    classSubs dd = [ (name, doc, declTypeDocs d) | (L _ d, doc) <- classDecls dd
+                   , name <- getMainDeclBinder d, not (isValD d)
+                   ]
+    dataSubs :: HsDataDefn GhcRn
+             -> [(Name, [HsDocString], Map Int (HsDocString))]
+    dataSubs dd = constrs ++ fields ++ derivs
+      where
+        cons = map unLoc $ (dd_cons dd)
+        constrs = [ ( unLoc cname
+                    , maybeToList $ fmap unLoc $ con_doc c
+                    , conArgDocs c)
+                  | c <- cons, cname <- getConNames c ]
+        fields  = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty)
+                  | RecCon flds <- map getConArgs cons
+                  , L _ (ConDeclField _ ns _ doc) <- (unLoc flds)
+                  , L _ n <- ns ]
+        derivs  = [ (instName, [unLoc doc], M.empty)
+                  | HsIB { hsib_body = L l (HsDocTy _ _ doc) }
+                      <- concatMap (unLoc . deriv_clause_tys . unLoc) $
+                           unLoc $ dd_derivs dd
+                  , Just instName <- [M.lookup l instMap] ]
+
+-- | Extract constructor argument docs from inside constructor decls.
+conArgDocs :: ConDecl GhcRn -> Map Int (HsDocString)
+conArgDocs con = case getConArgs con of
+                   PrefixCon args -> go 0 (map unLoc args ++ ret)
+                   InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret)
+                   RecCon _ -> go 1 ret
+  where
+    go n (HsDocTy _ _ (L _ ds) : tys) = M.insert n ds $ go (n+1) tys
+    go n (_ : tys) = go (n+1) tys
+    go _ [] = M.empty
+
+    ret = case con of
+            ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ]
+            _ -> []
+
+isValD :: HsDecl a -> Bool
+isValD (ValD _ _) = True
+isValD _ = False
+
+-- | All the sub declarations of a class (that we handle), ordered by
+-- source location, with documentation attached if it exists.
+classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
+classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls
+  where
+    decls = docs ++ defs ++ sigs ++ ats
+    docs  = mkDecls tcdDocs (DocD noExt) class_
+    defs  = mkDecls (bagToList . tcdMeths) (ValD noExt) class_
+    sigs  = mkDecls tcdSigs (SigD noExt) class_
+    ats   = mkDecls tcdATs (TyClD noExt . FamDecl noExt) class_
+
+-- | Extract function argument docs from inside top-level decls.
+declTypeDocs :: HsDecl GhcRn -> Map Int (HsDocString)
+declTypeDocs = \case
+  SigD  _ (TypeSig _ _ ty)          -> typeDocs (unLoc (hsSigWcType ty))
+  SigD  _ (ClassOpSig _ _ _ ty)     -> typeDocs (unLoc (hsSigType ty))
+  SigD  _ (PatSynSig _ _ ty)        -> typeDocs (unLoc (hsSigType ty))
+  ForD  _ (ForeignImport _ _ ty _)  -> typeDocs (unLoc (hsSigType ty))
+  TyClD _ (SynDecl { tcdRhs = ty }) -> typeDocs (unLoc ty)
+  _                                 -> M.empty
+
+nubByName :: (a -> Name) -> [a] -> [a]
+nubByName f ns = go emptyNameSet ns
+  where
+    go _ [] = []
+    go s (x:xs)
+      | y `elemNameSet` s = go s xs
+      | otherwise         = let s' = extendNameSet s y
+                            in x : go s' xs
+      where
+        y = f x
+
+-- | Extract function argument docs from inside types.
+typeDocs :: HsType GhcRn -> Map Int (HsDocString)
+typeDocs = go 0
+  where
+    go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty)
+    go n (HsQualTy   { hst_body = ty }) = go n (unLoc ty)
+    go n (HsFunTy _ (L _ (HsDocTy _ _ (L _ x))) (L _ ty)) =
+       M.insert n x $ go (n+1) ty
+    go n (HsFunTy _ _ ty) = go (n+1) (unLoc ty)
+    go n (HsDocTy _ _ (L _ doc)) = M.singleton n doc
+    go _ _ = M.empty
+
+-- | The top-level declarations of a module that we care about,
+-- ordered by source location, with documentation attached if it exists.
+topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
+topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup
+
+-- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
+ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]
+ungroup group_ =
+  mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExt)  group_ ++
+  mkDecls hs_derivds             (DerivD noExt) group_ ++
+  mkDecls hs_defds               (DefD noExt)   group_ ++
+  mkDecls hs_fords               (ForD noExt)   group_ ++
+  mkDecls hs_docs                (DocD noExt)   group_ ++
+  mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExt)  group_ ++
+  mkDecls (typesigs . hs_valds)  (SigD noExt)   group_ ++
+  mkDecls (valbinds . hs_valds)  (ValD noExt)   group_
+  where
+    typesigs (XValBindsLR (NValBinds _ sigs)) = filter (isUserSig . unLoc) sigs
+    typesigs _ = error "expected ValBindsOut"
+
+    valbinds (XValBindsLR (NValBinds binds _)) =
+      concatMap bagToList . snd . unzip $ binds
+    valbinds _ = error "expected ValBindsOut"
+
+-- | Sort by source location
+sortByLoc :: [Located a] -> [Located a]
+sortByLoc = sortOn getLoc
+
+-- | Collect docs and attach them to the right declarations.
+--
+-- A declaration may have multiple doc strings attached to it.
+collectDocs :: [LHsDecl pass] -> [(LHsDecl pass, [HsDocString])]
+-- ^ This is an example.
+collectDocs = go Nothing []
+  where
+    go Nothing _ [] = []
+    go (Just prev) docs [] = finished prev docs []
+    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 Nothing docs (d:ds) = go (Just d) docs ds
+    go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds)
+
+    finished decl docs rest = (decl, reverse docs) : rest
+
+-- | Filter out declarations that we don't handle in Haddock
+filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
+filterDecls = filter (isHandled . unLoc . fst)
+  where
+    isHandled (ForD _ (ForeignImport {})) = True
+    isHandled (TyClD {})  = True
+    isHandled (InstD {})  = True
+    isHandled (DerivD {}) = True
+    isHandled (SigD _ d)  = isUserSig d
+    isHandled (ValD {})   = True
+    -- we keep doc declarations to be able to get at named docs
+    isHandled (DocD {})   = True
+    isHandled _ = False
+
+
+-- | Go through all class declarations and filter their sub-declarations
+filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
+filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x
+                      | x@(L loc d, doc) <- decls ]
+  where
+    filterClass (TyClD x c) =
+      TyClD x $ c { tcdSigs =
+        filter (liftA2 (||) (isUserSig . unLoc) isMinimalLSig) (tcdSigs c) }
+    filterClass _ = error "expected TyClD"
+
+-- | Was this signature given by the user?
+isUserSig :: Sig name -> Bool
+isUserSig TypeSig {}    = True
+isUserSig ClassOpSig {} = True
+isUserSig PatSynSig {}  = True
+isUserSig _             = False
+
+isClassD :: HsDecl a -> Bool
+isClassD (TyClD _ d) = isClassDecl d
+isClassD _ = False
+
+-- | Take a field of declarations from a data structure and create HsDecls
+-- using the given constructor
+mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c]
+mkDecls field con struct = [ L loc (con decl) | L loc decl <- field struct ]
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index a6e6149f9f..8f21f02123 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -310,6 +310,7 @@ Library
         DsMonad
         DsUsage
         DsUtils
+        ExtractDocs
         Match
         MatchCon
         MatchLit
diff --git a/compiler/hsSyn/HsDoc.hs b/compiler/hsSyn/HsDoc.hs
index cbe1d94bec..ed887636a6 100644
--- a/compiler/hsSyn/HsDoc.hs
+++ b/compiler/hsSyn/HsDoc.hs
@@ -1,4 +1,6 @@
-{-# LANGUAGE CPP, DeriveDataTypeable #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 module HsDoc
   ( HsDocString
@@ -8,33 +10,59 @@ module HsDoc
   , unpackHDS
   , hsDocStringToByteString
   , ppr_mbDoc
+
+  , appendDocs
+  , concatDocs
+
+  , DeclDocMap(..)
+  , emptyDeclDocMap
+
+  , ArgDocMap(..)
+  , emptyArgDocMap
   ) where
 
 #include "HsVersions.h"
 
 import GhcPrelude
 
+import Binary
 import Encoding
 import FastFunctions
+import Name
 import Outputable
 import SrcLoc
 
 import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as C8
 import qualified Data.ByteString.Internal as BS
 import Data.Data
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Maybe
 import Foreign
 
 -- | Haskell Documentation String
 --
 -- Internally this is a UTF8-Encoded 'ByteString'.
 newtype HsDocString = HsDocString ByteString
+  -- There are at least two plausible Semigroup instances for this type:
+  --
+  -- 1. Simple string concatenation.
+  -- 2. Concatenation as documentation paragraphs with newlines in between.
+  --
+  -- To avoid confusion, we pass on defining an instance at all.
   deriving (Eq, Show, Data)
 
 -- | Located Haskell Documentation String
 type LHsDocString = Located HsDocString
 
+instance Binary HsDocString where
+  put_ bh (HsDocString bs) = put_ bh bs
+  get bh = HsDocString <$> get bh
+
 instance Outputable HsDocString where
-  ppr = text . unpackHDS
+  ppr = doubleQuotes . text . unpackHDS
 
 mkHsDocString :: String -> HsDocString
 mkHsDocString s =
@@ -59,3 +87,63 @@ hsDocStringToByteString (HsDocString bs) = bs
 ppr_mbDoc :: Maybe LHsDocString -> SDoc
 ppr_mbDoc (Just doc) = ppr doc
 ppr_mbDoc Nothing    = empty
+
+-- | Join two docstrings.
+--
+-- Non-empty docstrings are joined with two newlines in between,
+-- resulting in separate paragraphs.
+appendDocs :: HsDocString -> HsDocString -> HsDocString
+appendDocs x y =
+  fromMaybe
+    (HsDocString BS.empty)
+    (concatDocs [x, y])
+
+-- | Concat docstrings with two newlines in between.
+--
+-- Empty docstrings are skipped.
+--
+-- If all inputs are empty, 'Nothing' is returned.
+concatDocs :: [HsDocString] -> Maybe HsDocString
+concatDocs xs =
+    if BS.null b
+      then Nothing
+      else Just (HsDocString b)
+  where
+    b = BS.intercalate (C8.pack "\n\n")
+      . filter (not . BS.null)
+      . map hsDocStringToByteString
+      $ xs
+
+-- | Docs for declarations: functions, data types, instances, methods etc.
+newtype DeclDocMap = DeclDocMap (Map Name HsDocString)
+
+instance Binary DeclDocMap where
+  put_ bh (DeclDocMap m) = put_ bh (Map.toAscList m)
+  get bh = DeclDocMap . Map.fromDistinctAscList <$> get bh
+
+instance Outputable DeclDocMap where
+  ppr (DeclDocMap m) = vcat (map pprPair (Map.toAscList m))
+    where
+      pprPair (name, doc) = ppr name Outputable.<> colon $$ nest 2 (ppr doc)
+
+emptyDeclDocMap :: DeclDocMap
+emptyDeclDocMap = DeclDocMap Map.empty
+
+-- | Docs for arguments. E.g. function arguments, method arguments.
+newtype ArgDocMap = ArgDocMap (Map Name (Map Int HsDocString))
+
+instance Binary ArgDocMap where
+  put_ bh (ArgDocMap m) = put_ bh (Map.toAscList (Map.toAscList <$> m))
+  get bh = ArgDocMap . fmap Map.fromDistinctAscList . Map.fromDistinctAscList
+             <$> get bh
+
+instance Outputable ArgDocMap where
+  ppr (ArgDocMap m) = vcat (map pprPair (Map.toAscList m))
+    where
+      pprPair (name, int_map) =
+        ppr name Outputable.<> colon $$ nest 2 (pprIntMap int_map)
+      pprIntMap im = vcat (map pprIPair (Map.toAscList im))
+      pprIPair (i, doc) = ppr i Outputable.<> colon $$ nest 2 (ppr doc)
+
+emptyArgDocMap :: ArgDocMap
+emptyArgDocMap = ArgDocMap Map.empty
diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs
index cc4a4241d5..20928d6ba5 100644
--- a/compiler/iface/LoadIface.hs
+++ b/compiler/iface/LoadIface.hs
@@ -1090,6 +1090,9 @@ pprModIface iface
         , pprTrustInfo (mi_trust iface)
         , pprTrustPkg (mi_trust_pkg iface)
         , vcat (map ppr (mi_complete_sigs iface))
+        , text "module header:" $$ nest 2 (ppr (mi_doc_hdr iface))
+        , text "declaration docs:" $$ nest 2 (ppr (mi_decl_docs iface))
+        , text "arg docs:" $$ nest 2 (ppr (mi_arg_docs iface))
         ]
   where
     pp_hsc_src HsBootFile = text "[boot]"
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index 5c6912dca6..8091587c84 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -108,6 +108,7 @@ import Fingerprint
 import Exception
 import UniqSet
 import Packages
+import ExtractDocs
 
 import Control.Monad
 import Data.Function
@@ -152,12 +153,17 @@ mkIface hsc_env maybe_old_fingerprint mod_details
                       mg_warns        = warns,
                       mg_hpc_info     = hpc_info,
                       mg_safe_haskell = safe_mode,
-                      mg_trust_pkg    = self_trust
+                      mg_trust_pkg    = self_trust,
+                      mg_doc_hdr      = doc_hdr,
+                      mg_decl_docs    = decl_docs,
+                      mg_arg_docs     = arg_docs
                     }
         = mkIface_ hsc_env maybe_old_fingerprint
                    this_mod hsc_src used_th deps rdr_env fix_env
                    warns hpc_info self_trust
-                   safe_mode usages mod_details
+                   safe_mode usages
+                   doc_hdr decl_docs arg_docs
+                   mod_details
 
 -- | make an interface from the results of typechecking only.  Useful
 -- for non-optimising compilation, or where we aren't generating any
@@ -198,11 +204,16 @@ mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details
           -- module and does not need to be recorded as a dependency.
           -- See Note [Identity versus semantic module]
           usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names dep_files merged
+
+          let (doc_hdr', doc_map, arg_map) = extractDocs tc_result
+
           mkIface_ hsc_env maybe_old_fingerprint
                    this_mod hsc_src
                    used_th deps rdr_env
                    fix_env warns hpc_info
-                   (imp_trust_own_pkg imports) safe_mode usages mod_details
+                   (imp_trust_own_pkg imports) safe_mode usages
+                   doc_hdr' doc_map arg_map
+                   mod_details
 
 
 
@@ -212,11 +223,15 @@ mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> HscSource
          -> Bool
          -> SafeHaskellMode
          -> [Usage]
+         -> Maybe HsDocString
+         -> DeclDocMap
+         -> ArgDocMap
          -> ModDetails
          -> IO (ModIface, Bool)
 mkIface_ hsc_env maybe_old_fingerprint
          this_mod hsc_src used_th deps rdr_env fix_env src_warns
          hpc_info pkg_trust_req safe_mode usages
+         doc_hdr decl_docs arg_docs
          ModDetails{  md_insts     = insts,
                       md_fam_insts = fam_insts,
                       md_rules     = rules,
@@ -304,7 +319,10 @@ mkIface_ hsc_env maybe_old_fingerprint
               -- And build the cached values
               mi_warn_fn     = mkIfaceWarnCache warns,
               mi_fix_fn      = mkIfaceFixCache fixities,
-              mi_complete_sigs = icomplete_sigs }
+              mi_complete_sigs = icomplete_sigs,
+              mi_doc_hdr     = doc_hdr,
+              mi_decl_docs   = decl_docs,
+              mi_arg_docs    = arg_docs }
 
     (new_iface, no_change_at_all)
           <- {-# SCC "versioninfo" #-}
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 49e6c211eb..2b25646d8d 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -132,6 +132,9 @@ module GHC (
         ForeignHValue,
         compileExprRemote, compileParsedExprRemote,
 
+        -- ** Docs
+        getDocs, GetDocsFailure(..),
+
         -- ** Other
         runTcInteractive,   -- Desired by some clients (Trac #8878)
         isStmt, hasImport, isImport, isDecl,
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index 7cb25dfefb..9823c60f70 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -950,7 +950,16 @@ data ModIface
                 -- itself) but imports some trustworthy modules from its own
                 -- package (which does require its own package be trusted).
                 -- See Note [RnNames . Trust Own Package]
-        mi_complete_sigs :: [IfaceCompleteMatch]
+        mi_complete_sigs :: [IfaceCompleteMatch],
+
+        mi_doc_hdr :: Maybe HsDocString,
+                -- ^ Module header.
+
+        mi_decl_docs :: DeclDocMap,
+                -- ^ Docs on declarations.
+
+        mi_arg_docs :: ArgDocMap
+                -- ^ Docs on arguments.
      }
 
 -- | Old-style accessor for whether or not the ModIface came from an hs-boot
@@ -1028,7 +1037,10 @@ instance Binary ModIface where
                  mi_hpc       = hpc_info,
                  mi_trust     = trust,
                  mi_trust_pkg = trust_pkg,
-                 mi_complete_sigs = complete_sigs }) = do
+                 mi_complete_sigs = complete_sigs,
+                 mi_doc_hdr   = doc_hdr,
+                 mi_decl_docs = decl_docs,
+                 mi_arg_docs  = arg_docs }) = do
         put_ bh mod
         put_ bh sig_of
         put_ bh hsc_src
@@ -1057,6 +1069,9 @@ instance Binary ModIface where
         put_ bh trust
         put_ bh trust_pkg
         put_ bh complete_sigs
+        lazyPut bh doc_hdr
+        lazyPut bh decl_docs
+        lazyPut bh arg_docs
 
    get bh = do
         mod         <- get bh
@@ -1087,6 +1102,9 @@ instance Binary ModIface where
         trust       <- get bh
         trust_pkg   <- get bh
         complete_sigs <- get bh
+        doc_hdr     <- lazyGet bh
+        decl_docs   <- lazyGet bh
+        arg_docs    <- lazyGet bh
         return (ModIface {
                  mi_module      = mod,
                  mi_sig_of      = sig_of,
@@ -1120,7 +1138,10 @@ instance Binary ModIface where
                  mi_warn_fn     = mkIfaceWarnCache warns,
                  mi_fix_fn      = mkIfaceFixCache fixities,
                  mi_hash_fn     = mkIfaceHashCache decls,
-                 mi_complete_sigs = complete_sigs })
+                 mi_complete_sigs = complete_sigs,
+                 mi_doc_hdr     = doc_hdr,
+                 mi_decl_docs   = decl_docs,
+                 mi_arg_docs    = arg_docs })
 
 -- | The original names declared of a certain module that are exported
 type IfaceExport = AvailInfo
@@ -1159,7 +1180,10 @@ emptyModIface mod
                mi_hpc         = False,
                mi_trust       = noIfaceTrustInfo,
                mi_trust_pkg   = False,
-               mi_complete_sigs = [] }
+               mi_complete_sigs = [],
+               mi_doc_hdr     = Nothing,
+               mi_decl_docs   = emptyDeclDocMap,
+               mi_arg_docs    = emptyArgDocMap }
 
 
 -- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface'
@@ -1284,9 +1308,13 @@ data ModGuts
                                                 -- one); c.f. 'tcg_fam_inst_env'
 
         mg_safe_haskell :: SafeHaskellMode,     -- ^ Safe Haskell mode
-        mg_trust_pkg    :: Bool                 -- ^ Do we need to trust our
+        mg_trust_pkg    :: Bool,                -- ^ Do we need to trust our
                                                 -- own package for Safe Haskell?
                                                 -- See Note [RnNames . Trust Own Package]
+
+        mg_doc_hdr       :: !(Maybe HsDocString), -- ^ Module header.
+        mg_decl_docs     :: !DeclDocMap,     -- ^ Docs on declarations.
+        mg_arg_docs      :: !ArgDocMap       -- ^ Docs on arguments.
     }
 
 -- The ModGuts takes on several slightly different forms:
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 163bb8de3f..3f2309e7f5 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -30,6 +30,8 @@ module InteractiveEval (
         exprType,
         typeKind,
         parseName,
+        getDocs,
+        GetDocsFailure(..),
         showModule,
         moduleIsBootOrNotObjectLinkable,
         parseExpr, compileParsedExpr,
@@ -91,6 +93,8 @@ import Data.Dynamic
 import Data.Either
 import qualified Data.IntMap as IntMap
 import Data.List (find,intercalate)
+import Data.Map (Map)
+import qualified Data.Map as Map
 import StringBuffer (stringToStringBuffer)
 import Control.Monad
 import GHC.Exts
@@ -821,6 +825,70 @@ parseThing parser dflags stmt = do
 
   Lexer.unP parser (Lexer.mkPState dflags buf loc)
 
+getDocs :: GhcMonad m
+        => Name
+        -> m (Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString))
+           -- TODO: What about docs for constructors etc.?
+getDocs name =
+  withSession $ \hsc_env -> do
+     case nameModule_maybe name of
+       Nothing -> pure (Left (NameHasNoModule name))
+       Just mod -> do
+         if isInteractiveModule mod
+           then pure (Left InteractiveName)
+           else do
+             ModIface { mi_doc_hdr = mb_doc_hdr
+                      , mi_decl_docs = DeclDocMap dmap
+                      , mi_arg_docs = ArgDocMap amap
+                      } <- liftIO $ hscGetModuleInterface hsc_env mod
+             if isNothing mb_doc_hdr && Map.null dmap && Map.null amap
+               then pure (Left (NoDocsInIface mod compiled))
+               else pure (Right ( Map.lookup name dmap
+                                , Map.findWithDefault Map.empty name amap))
+  where
+    compiled =
+      -- TODO: Find a more direct indicator.
+      case nameSrcLoc name of
+        RealSrcLoc {} -> False
+        UnhelpfulLoc {} -> True
+
+-- | Failure modes for 'getDocs'.
+
+-- TODO: Find a way to differentiate between modules loaded without '-haddock'
+-- and modules that contain no docs.
+data GetDocsFailure
+
+    -- | 'nameModule_maybe' returned 'Nothing'.
+  = NameHasNoModule Name
+
+    -- | This is probably because the module was loaded without @-haddock@,
+    -- but it's also possible that the entire module contains no documentation.
+  | NoDocsInIface
+      Module
+      Bool -- ^ 'True': The module was compiled.
+           -- 'False': The module was :loaded.
+
+    -- | The 'Name' was defined interactively.
+  | InteractiveName
+
+instance Outputable GetDocsFailure where
+  ppr (NameHasNoModule name) =
+    quotes (ppr name) <+> text "has no module where we could look for docs."
+  ppr (NoDocsInIface mod compiled) = vcat
+    [ text "Can't find any documentation for" <+> ppr mod <> char '.'
+    , text "This is probably because the module was"
+        <+> text (if compiled then "compiled" else "loaded")
+        <+> text "without '-haddock',"
+    , text "but it's also possible that the module contains no documentation."
+    , text ""
+    , if compiled
+        then text "Try re-compiling with '-haddock'."
+        else text "Try running ':set -haddock' and :load the file again."
+        -- TODO: Figure out why :reload doesn't load the docs and maybe fix it.
+    ]
+  ppr InteractiveName =
+    text "Docs are unavailable for interactive declarations."
+
 -- -----------------------------------------------------------------------------
 -- Getting the type of an expression
 
diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs
index a68d0f504a..26f549b3fc 100644
--- a/compiler/typecheck/TcRnMonad.hs
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -234,6 +234,12 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
              maybe_rn_syntax :: forall a. a -> Maybe a ;
              maybe_rn_syntax empty_val
                 | dopt Opt_D_dump_rn_ast dflags = Just empty_val
+
+                  -- We want to serialize the documentation in the .hi-files,
+                  -- and need to extract it from the renamed syntax first.
+                  -- See 'ExtractDocs.extractDocs'.
+                | gopt Opt_Haddock dflags       = Just empty_val
+
                 | keep_rn_syntax                = Just empty_val
                 | otherwise                     = Nothing ;
 
diff --git a/docs/users_guide/8.6.1-notes.rst b/docs/users_guide/8.6.1-notes.rst
index 2b3fd9b463..fc2b1d2cfd 100644
--- a/docs/users_guide/8.6.1-notes.rst
+++ b/docs/users_guide/8.6.1-notes.rst
@@ -118,6 +118,12 @@ Compiler
   :ghc-flag:`-fexternal-dynamic-refs`. If you don't know why you might
   need this, you don't need it.
 
+GHCi
+~~~~
+
+- Added an experimental :ghci-cmd:`:doc` command that displays the
+  documentation for a declaration.
+
 Runtime system
 ~~~~~~~~~~~~~~
 
diff --git a/docs/users_guide/ghci.rst b/docs/users_guide/ghci.rst
index a5f5764a9e..49a96caa0b 100644
--- a/docs/users_guide/ghci.rst
+++ b/docs/users_guide/ghci.rst
@@ -2374,6 +2374,14 @@ commonly used commands.
     see the number of each breakpoint). The ``*`` form deletes all the
     breakpoints.
 
+.. ghci-cmd:: :doc; ⟨name⟩
+
+    (Experimental: This command will likely change significantly in GHC 8.8.)
+
+    Displays the documentation for the given name. Currently the command is
+    restricted to displaying the documentation directly on the declaration
+    in question, ignoring documentation for arguments, constructors etc.
+
 .. ghci-cmd:: :edit; ⟨file⟩
 
     Opens an editor to edit the file ⟨file⟩, or the most recently loaded
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 67f2cbb147..7c427a03a8 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -48,6 +48,7 @@ import GhcMonad ( modifySession )
 import qualified GHC
 import GHC ( LoadHowMuch(..), Target(..),  TargetId(..), InteractiveImport(..),
              TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,
+             GetDocsFailure(..),
              getModuleGraph, handleSourceError )
 import HsImpExp
 import HsSyn
@@ -99,6 +100,7 @@ import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,
                    partition, sort, sortBy )
 import qualified Data.Set as S
 import Data.Maybe
+import Data.Map (Map)
 import qualified Data.Map as M
 import Data.Time.LocalTime ( getZonedTime )
 import Data.Time.Format ( formatTime, defaultTimeLocale )
@@ -179,6 +181,7 @@ ghciCommands = map mkCmd [
   ("def",       keepGoing (defineMacro False),  completeExpression),
   ("def!",      keepGoing (defineMacro True),   completeExpression),
   ("delete",    keepGoing deleteCmd,            noCompletion),
+  ("doc",       keepGoing' docCmd,              completeIdentifier),
   ("edit",      keepGoing' editFile,            completeFilename),
   ("etags",     keepGoing createETagsFileCmd,   completeFilename),
   ("force",     keepGoing forceCmd,             completeExpression),
@@ -288,6 +291,7 @@ defFullHelpText =
   "                               (!: use regex instead of line number)\n" ++
   "   :def <cmd> <expr>           define command :<cmd> (later defined command has\n" ++
   "                               precedence, ::<cmd> is always a builtin command)\n" ++
+  "   :doc <name>                 display docs for the given name (experimental)\n" ++
   "   :edit <file>                edit file\n" ++
   "   :edit                       edit last module\n" ++
   "   :etags [<file>]             create tags file <file> for Emacs (default: \"TAGS\")\n" ++
@@ -1604,6 +1608,38 @@ checkModule m = do
           return True
   afterLoad (successIf ok) False
 
+-----------------------------------------------------------------------------
+-- :doc
+
+docCmd :: String -> InputT GHCi ()
+docCmd "" =
+  throwGhcException (CmdLineError "syntax: ':doc <thing-you-want-docs-for>'")
+docCmd s  = do
+  -- TODO: Maybe also get module headers for module names
+  names <- GHC.parseName s
+  e_docss <- mapM GHC.getDocs names
+  sdocs <- mapM (either handleGetDocsFailure (pure . pprDocs)) e_docss
+  let sdocs' = vcat (intersperse (text "") sdocs)
+  unqual <- GHC.getPrintUnqual
+  dflags <- getDynFlags
+  (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs'
+
+-- TODO: also print arg docs.
+pprDocs :: (Maybe HsDocString, Map Int HsDocString) -> SDoc
+pprDocs (mb_decl_docs, _arg_docs) =
+  maybe
+    (text "<has no documentation>")
+    (text . unpackHDS)
+    mb_decl_docs
+
+handleGetDocsFailure :: GHC.GhcMonad m => GetDocsFailure -> m SDoc
+handleGetDocsFailure no_docs = do
+  dflags <- getDynFlags
+  let msg = showPpr dflags no_docs
+  throwGhcException $ case no_docs of
+    NameHasNoModule {} -> Sorry msg
+    NoDocsInIface {} -> InstallationError msg
+    InteractiveName -> ProgramError msg
 
 -----------------------------------------------------------------------------
 -- :load, :add, :reload
diff --git a/mk/config.mk.in b/mk/config.mk.in
index 92830fa1e8..6ff8e0ee7d 100644
--- a/mk/config.mk.in
+++ b/mk/config.mk.in
@@ -311,8 +311,11 @@ GhcThreaded = $(if $(findstring thr,$(GhcRTSWays)),YES,NO)
 #
 # 	-O(2) is pretty desirable, otherwise no inlining of prelude
 #		things (incl "+") happens when compiling with this compiler
+#
+#       -haddock is needed so the GHCi :doc command can find the boot
+#               library docs in the respective .hi-files
 
-GhcLibHcOpts=-O2
+GhcLibHcOpts=-O2 -haddock
 
 # Strip local symbols from libraries?  This can make the libraries smaller,
 # but makes debugging somewhat more difficult.  Doesn't work with all ld's.
diff --git a/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr b/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr
index 8f06390348..d230d58eaa 100644
--- a/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr
+++ b/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr
@@ -17,7 +17,7 @@ visible a = a
 [3 of 3] Compiling Test             ( Test.hs, Test.o )
 
 ==================== Parser ====================
-
+"
  Module      :  Test
  Copyright   :  (c) Simon Marlow 2002
  License     :  BSD-style
@@ -28,63 +28,65 @@ visible a = a
 
  This module illustrates & tests most of the features of Haddock.
  Testing references from the description: 'T', 'f', 'g', 'Visible.visible'.
-
+"
 module Test (
         <IEGroup: 1>, <IEGroup: 2>, T(..), T2, T3(..), T4(..), T5(..),
         T6(..), N1(..), N2(..), N3(..), N4, N5(..), N6(..), N7(..),
         <IEGroup: 2>, R(..), R1(..),
-         test that we can export record selectors on their own:, p, q, u,
+        " test that we can export record selectors on their own:", p, q, u,
         <IEGroup: 1>, C(a, b), D(..), E, F(..),
-         Test that we can export a class method on its own:, a,
+        " Test that we can export a class method on its own:", a,
         <IEGroup: 1>, f, g, <IEGroup: 1>, <IEDocNamed: aux1>,
         <IEDocNamed: aux2>, <IEDocNamed: aux3>, <IEDocNamed: aux4>,
         <IEDocNamed: aux5>, <IEDocNamed: aux6>, <IEDocNamed: aux7>,
         <IEDocNamed: aux8>, <IEDocNamed: aux9>, <IEDocNamed: aux10>,
         <IEDocNamed: aux11>, <IEDocNamed: aux12>,
-         This is some inline documentation in the export list
+        " This is some inline documentation in the export list
 
  > a code block using bird-tracks
  > each line must begin with > (which isn't significant unless it
- > is at the beginning of the line).,
+ > is at the beginning of the line).",
         <IEGroup: 1>, module Hidden, <IEGroup: 1>, module Visible,
-         nested-style doc comments , <IEGroup: 1>, Ex(..), <IEGroup: 1>, k,
-        l, m, o, <IEGroup: 1>, <IEGroup: 2>,
-        
+        " nested-style doc comments ", <IEGroup: 1>, Ex(..), <IEGroup: 1>,
+        k, l, m, o, <IEGroup: 1>, <IEGroup: 2>,
+        "
  > a literal line
 
  $ a non /literal/ line $
-, f'
+", f'
     ) where
 import Hidden
 import Visible
 <document comment>
 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)
+  = " This comment describes the 'A' constructor"
+    A Int (Maybe Float) |
+    " This comment describes the 'B' constructor"
+    B (T a b, T Int Float)
 <document comment>
 data T2 a b = T2 a b
 <document comment>
 data T3 a b = A1 a | B1 b
 data T4 a b = A2 a | B2 b
-data T5 a b =  documents 'A3' A3 a |  documents 'B3' B3 b
+data T5 a b = " documents 'A3'" A3 a | " documents 'B3'" B3 b
 <document comment>
 data T6
-  =  This is the doc for 'A4' A4 |
-     This is the doc for 'B4' B4 |
-     This is the doc for 'C4' C4
+  = " This is the doc for 'A4'" A4 |
+    " This is the doc for 'B4'" B4 |
+    " This is the doc for 'C4'" C4
 <document comment>
 newtype N1 a = N1 a
 <document comment>
 newtype N2 a b = N2 {n :: a b}
 <document comment>
-newtype N3 a b = N3 {n3 :: a b  this is the 'n3' field}
+newtype N3 a b = N3 {n3 :: a b " this is the 'n3' field"}
 <document comment>
 newtype N4 a b = N4 a
 newtype N5 a b
-  = N5 {n5 :: a b  no docs on the datatype or the constructor}
-newtype N6 a b =  docs on the constructor only N6 {n6 :: a b}
+  = N5 {n5 :: a b " no docs on the datatype or the constructor"}
+newtype N6 a b = " docs on the constructor only" N6 {n6 :: a b}
 <document comment>
-newtype N7 a b =  The 'N7' constructor N7 {n7 :: a b}
+newtype N7 a b = " The 'N7' constructor" N7 {n7 :: a b}
 class (D a) => C a where
   a :: IO a
   b :: [a]
@@ -107,20 +109,20 @@ class F a where
   ff :: a
 <document comment>
 data R
-  =  This is the 'C1' record constructor, with the following fields:
-    C1 {p :: Int  This comment applies to the 'p' field,
-        q :: forall a. a -> a  This comment applies to the 'q' field,
-        r, s :: Int  This comment applies to both 'r' and 's'} |
-     This is the 'C2' record constructor, also with some fields:
+  = " This is the 'C1' record constructor, with the following fields:"
+    C1 {p :: Int " This comment applies to the 'p' field",
+        q :: forall a. a -> a " This comment applies to the 'q' field",
+        r, s :: Int " This comment applies to both 'r' and 's'"} |
+    " This is the 'C2' record constructor, also with some fields:"
     C2 {t :: T1
              -> (T2 Int Int) -> (T3 Bool Bool) -> (T4 Float Float) -> T5 () (),
         u, v :: Int}
 <document comment>
 data R1
-  =  This is the 'C3' record constructor
-    C3 {s1 :: Int  The 's1' record selector,
-        s2 :: Int  The 's2' record selector,
-        s3 :: Int  The 's3' record selector}
+  = " This is the 'C3' record constructor"
+    C3 {s1 :: Int " The 's1' record selector",
+        s2 :: Int " The 's2' record selector",
+        s3 :: Int " The 's3' record selector"}
 <document comment>
 <document comment>
 <document comment>
@@ -151,26 +153,27 @@ data Ex a
     Ex4 (forall a. a -> a)
 <document comment>
 k ::
-  T () ()  This argument has type 'T'
-  -> (T2 Int Int)  This argument has type 'T2 Int Int'
+  T () () " This argument has type 'T'"
+  -> (T2 Int Int) " This argument has type 'T2 Int Int'"
      -> (T3 Bool Bool
-         -> T4 Float Float)  This argument has type @T3 Bool Bool -> T4 Float Float@
-        -> T5 () ()  This argument has a very long description that should
+         -> T4 Float Float) " This argument has type @T3 Bool Bool -> T4 Float Float@"
+        -> T5 () () " This argument has a very long description that should
  hopefully cause some wrapping to happen when it is finally
- rendered by Haddock in the generated HTML page.
-           -> IO ()  This is the result type
-l :: (Int, Int, Float)  takes a triple -> Int  returns an 'Int'
+ rendered by Haddock in the generated HTML page."
+           -> IO () " This is the result type"
+l :: (Int, Int, Float) " takes a triple" -> Int " returns an 'Int'"
 <document comment>
 m ::
-  R -> N1 ()  one of the arguments -> IO Int  and the return value
+  R
+  -> N1 () " one of the arguments" -> IO Int " and the return value"
 <document comment>
 newn ::
-  R  one of the arguments, an 'R'
-  -> N1 ()  one of the arguments -> IO Int
+  R " one of the arguments, an 'R'"
+  -> N1 () " one of the arguments" -> IO Int
 newn = undefined
 <document comment>
 foreign import ccall unsafe "header.h" o
-  :: Float  The input float -> IO Float  The output float
+  :: Float " The input float" -> IO Float " The output float"
 <document comment>
 newp :: Int
 newp = undefined
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr
index 060dd06ad2..997c2ef24c 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr
@@ -3,10 +3,10 @@
 module T11768 where
 data Foo
   = Foo
-  deriving Eq  Documenting a single type
+  deriving Eq " Documenting a single type"
 data Bar
   = Bar
-  deriving (Eq  Documenting one of multiple types, Ord)
+  deriving (Eq " Documenting one of multiple types", Ord)
 <document comment>
 deriving instance Read Bar
 
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA014.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA014.stderr
index a70f624278..f55f8afab1 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA014.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA014.stderr
@@ -1,6 +1,6 @@
 
 ==================== Parser ====================
- a header
+" a header"
 module HeaderTest where
 <document comment>
 x = 0
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA015.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA015.stderr
index 3bfc17d811..15adf3e54e 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA015.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA015.stderr
@@ -1,6 +1,6 @@
 
 ==================== Parser ====================
- a header
+" a header"
 module HeaderTest where
 <document comment>
 x = 0
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA016.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA016.stderr
index 48dd0870c9..e9ccec44a0 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA016.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA016.stderr
@@ -1,6 +1,6 @@
 
 ==================== Parser ====================
-Module description
+"Module description"
 module A where
 
 
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA018.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA018.stderr
index 2aa5245f50..357f7540e2 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA018.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA018.stderr
@@ -1,6 +1,6 @@
 
 ==================== Parser ====================
- module header bla bla 
+" module header bla bla "
 module A where
 
 
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA019.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA019.stderr
index ca316bc8b8..c7a34730d9 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA019.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA019.stderr
@@ -1,7 +1,7 @@
 
 ==================== Parser ====================
 module A (
-         bla bla,  blabla 
+        " bla bla", " blabla "
     ) where
 
 
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA020.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA020.stderr
index 2aaa3eba98..660b28036e 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA020.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA020.stderr
@@ -1,7 +1,7 @@
 
 ==================== Parser ====================
 module A (
-         bla bla,  blabla , x, <IEGroup: 2>,  qweljqwelkqjwelqjkq
+        " bla bla", " blabla ", x, <IEGroup: 2>, " qweljqwelkqjwelqjkq"
     ) where
 x = True
 
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA021.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA021.stderr
index 162c403b84..befbee45f9 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA021.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA021.stderr
@@ -1,8 +1,8 @@
 
 ==================== Parser ====================
 module A (
-         bla bla,  blabla , x, <IEGroup: 2>,  qweljqwelkqjwelqjkq, y,
-         dkashdakj, z, <IEGroup: 1>
+        " bla bla", " blabla ", x, <IEGroup: 2>, " qweljqwelkqjwelqjkq", y,
+        " dkashdakj", z, <IEGroup: 1>
     ) where
 x = True
 y = False
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA023.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA023.stderr
index fcb953a495..d04558c301 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA023.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA023.stderr
@@ -1,7 +1,7 @@
 
 ==================== Parser ====================
 module ShouldCompile where
-test :: (Eq a) => [a]  doc1 -> [a]  doc2 -> [a]  doc3
+test :: (Eq a) => [a] " doc1" -> [a] " doc2 " -> [a] " doc3"
 test xs ys = xs
 
 
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA024.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA024.stderr
index 9f57f5df07..c453e071a3 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA024.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA024.stderr
@@ -1,7 +1,7 @@
 
 ==================== Parser ====================
 module ShouldCompile where
-test2 :: a  doc1 -> b  doc2 -> a  doc 3 
+test2 :: a " doc1 " -> b " doc2 " -> a " doc 3 "
 test2 x y = x
 
 
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA025.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA025.stderr
index 472ec1a1eb..e0b8a4a7bf 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA025.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA025.stderr
@@ -1,7 +1,7 @@
 
 ==================== Parser ====================
 module ShouldCompile where
-test2 :: a  doc1  -> a
+test2 :: a " doc1 " -> a
 test2 x = x
 
 
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA026.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA026.stderr
index 5f7335b6b9..37135099a0 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA026.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA026.stderr
@@ -2,7 +2,7 @@
 ==================== Parser ====================
 module ShouldCompile where
 test ::
-  (Eq a) => [a]  doc1 -> forall b. [b]  doc2 -> [a]  doc3
+  (Eq a) => [a] " doc1" -> forall b. [b] " doc2 " -> [a] " doc3"
 test xs ys = xs
 
 
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA027.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA027.stderr
index e7707c5ec0..0bbb612119 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA027.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA027.stderr
@@ -2,9 +2,9 @@
 ==================== Parser ====================
 module ShouldCompile where
 test ::
-  [a]  doc1
+  [a] " doc1"
   -> forall b.
-     (Ord b) => [b]  doc2  -> forall c. (Num c) => [c]  doc3 -> [a]
+     (Ord b) => [b] " doc2 " -> forall c. (Num c) => [c] " doc3" -> [a]
 test xs ys zs = xs
 
 
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA028.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA028.stderr
index 47d2468ea5..3c1bbc9565 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA028.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA028.stderr
@@ -2,7 +2,7 @@
 ==================== Parser ====================
 module ShouldCompile where
 data a <--> b = Mk a b
-test :: [a]  doc1  -> a <--> b -> [a]  blabla
+test :: [a] " doc1 " -> a <--> b -> [a] " blabla"
 test xs ys = xs
 
 
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA029.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA029.stderr
index 820ffa6708..7271238e3e 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA029.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA029.stderr
@@ -2,6 +2,6 @@
 ==================== Parser ====================
 module ShouldCompile where
 data A
-  =  A comment that documents the first constructor A | B | C | D
+  = " A comment that documents the first constructor" A | B | C | D
 
 
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA030.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA030.stderr
index b0ef139199..e09cfa2187 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA030.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA030.stderr
@@ -2,6 +2,9 @@
 ==================== Parser ====================
 module ShouldCompile where
 data A
-  =  comment for A  A |  comment for B  B |  comment for C   C | D
+  = " comment for A " A |
+    " comment for B " B |
+    " comment for C  " C |
+    D
 
 
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA031.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA031.stderr
index 1d033cd6d7..eb6fcaef1e 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA031.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA031.stderr
@@ -3,7 +3,7 @@
 module ShouldCompile where
 data A
   = A |
-     comment for B  forall a. B a a |
-     comment for C  forall a. Num a => C a
+    " comment for B " forall a. B a a |
+    " comment for C " forall a. Num a => C a
 
 
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA032.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA032.stderr
index 5cf2d9b034..eec30285f5 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA032.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA032.stderr
@@ -3,8 +3,8 @@
 module ShouldCompile where
 data R a
   = R {field1 :: a,
-       field2 :: a  comment for field2,
-       field3 :: a  comment for field3,
-       field4 :: a  comment for field4 }
+       field2 :: a " comment for field2",
+       field3 :: a " comment for field3",
+       field4 :: a " comment for field4 "}
 
 
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA034.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA034.stderr
index f743393349..64478fed12 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA034.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA034.stderr
@@ -2,4 +2,6 @@
 ==================== Parser ====================
 module Hi where
 <document comment>
-data Hi where  This is a GADT constructor. Hi :: () -> Hi
+data Hi where " This is a GADT constructor." Hi :: () -> Hi
+
+
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA035.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA035.stderr
index d0e5bbc57d..3f12a0cffd 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA035.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA035.stderr
@@ -3,7 +3,9 @@
 module Hi where
 data Hi
   where
-      Hi :: ()  This is a comment on the '()' field of 'Hi'
-            -> Int
-               -> String  This is a comment on the 'String' field of 'Hi'
-                  -> Hi  This is a comment on the return type of 'Hi'
+    Hi :: () " This is a comment on the '()' field of 'Hi'"
+          -> Int
+             -> String " This is a comment on the 'String' field of 'Hi'"
+                -> Hi " This is a comment on the return type of 'Hi'"
+
+
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA036.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA036.stderr
index 0d884ab0e3..5cd0a59a05 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA036.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA036.stderr
@@ -2,11 +2,13 @@
 ==================== Parser ====================
 module ConstructorFields where
 data Foo
-  =  doc on `Bar` constructor Bar Int String |
-     doc on the `Baz` constructor
-    Baz Int  doc on the `Int` field of `Baz` String  doc on the `String` field of `Baz` |
-     doc on the `:+` constructor Int :+ String |
-     doc on the `:*` constructor
-    Int  doc on the `Int` field of the `:*` constructor :* String  doc on the `String` field of the `:*` constructor |
-     doc on the `Boo` record constructor Boo {x :: ()} |
-     doc on the `Boa` record constructor Boa {y :: ()}
+  = " doc on `Bar` constructor" Bar Int String |
+    " doc on the `Baz` constructor"
+    Baz Int " doc on the `Int` field of `Baz`" String " doc on the `String` field of `Baz`" |
+    " doc on the `:+` constructor" Int :+ String |
+    " doc on the `:*` constructor"
+    Int " doc on the `Int` field of the `:*` constructor" :* String " doc on the `String` field of the `:*` constructor" |
+    " doc on the `Boo` record constructor" Boo {x :: ()} |
+    " doc on the `Boa` record constructor" Boa {y :: ()}
+
+
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA037.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA037.stderr
index 8e90efa691..b9ecfa6303 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA037.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA037.stderr
@@ -4,4 +4,6 @@ module UnamedConstructorFields where
 data A = A
 data B = B
 data C = C
-data Foo = MkFoo A  'A' has a comment B C  'C' has a comment
+data Foo = MkFoo A " 'A' has a comment" B C " 'C' has a comment"
+
+
diff --git a/testsuite/tests/showIface/DocsInHiFile.hs b/testsuite/tests/showIface/DocsInHiFile.hs
new file mode 100644
index 0000000000..26156722ac
--- /dev/null
+++ b/testsuite/tests/showIface/DocsInHiFile.hs
@@ -0,0 +1,37 @@
+{-| `elem`, 'print',
+`Unknown',
+'<>', ':=:', 'Bool'
+-}
+module DocsInHiFile
+  ( DocsInHiFile.elem
+  , D(..)
+  , add
+  , P(..)
+  , Show(..)
+  ) where
+
+-- | '()', 'elem'.
+elem :: ()
+elem = ()
+
+-- | A datatype.
+data D
+  = D0 -- ^ A constructor for 'D'. '
+  | D1 -- ^ Another constructor
+  deriving ( Show -- ^ 'Show' instance
+           )
+
+add :: Int -- ^ First summand for 'add'
+    -> Int -- ^ Second summand
+    -> Int -- ^ Sum
+add a b = a + b
+
+-- | A class
+class P f where
+  -- | A class method
+  p :: a -- ^ An argument
+    -> f a
+
+-- | Another datatype...
+data D'
+-- ^ ...with two docstrings.
diff --git a/testsuite/tests/showIface/DocsInHiFile0.stdout b/testsuite/tests/showIface/DocsInHiFile0.stdout
new file mode 100644
index 0000000000..e1c32d63c8
--- /dev/null
+++ b/testsuite/tests/showIface/DocsInHiFile0.stdout
@@ -0,0 +1,4 @@
+module header:
+  Nothing
+declaration docs:
+arg docs:
diff --git a/testsuite/tests/showIface/DocsInHiFile1.stdout b/testsuite/tests/showIface/DocsInHiFile1.stdout
new file mode 100644
index 0000000000..fcb5f94f71
--- /dev/null
+++ b/testsuite/tests/showIface/DocsInHiFile1.stdout
@@ -0,0 +1,36 @@
+module header:
+  Just " `elem`, 'print',
+`Unknown',
+'<>', ':=:', 'Bool'
+"
+declaration docs:
+  D':
+    " Another datatype...
+
+ ...with two docstrings."
+  P:
+    " A class"
+  p:
+    " A class method"
+  D:
+    " A datatype."
+  D0:
+    " A constructor for 'D'. '"
+  D1:
+    " Another constructor"
+  elem:
+    " '()', 'elem'."
+  $fShowD:
+    " 'Show' instance"
+arg docs:
+  p:
+    0:
+      " An argument"
+  add:
+    0:
+      " First summand for 'add'"
+    1:
+      " Second summand"
+    2:
+      " Sum"
+
diff --git a/testsuite/tests/showIface/Makefile b/testsuite/tests/showIface/Makefile
index 49b90342b3..7eafdfc9d2 100644
--- a/testsuite/tests/showIface/Makefile
+++ b/testsuite/tests/showIface/Makefile
@@ -5,3 +5,11 @@ include $(TOP)/mk/test.mk
 Orphans:
 	'$(TEST_HC)' $(TEST_HC_OPTS) -c Orphans.hs
 	'$(TEST_HC)' $(TEST_HC_OPTS) --show-iface Orphans.hi | grep -E '^(instance |family instance |"myrule)' | grep -v 'family instance modules:'
+
+DocsInHiFile0:
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c DocsInHiFile.hs
+	'$(TEST_HC)' $(TEST_HC_OPTS) --show-iface DocsInHiFile.hi | grep -A 4 'module header:'
+
+DocsInHiFile1:
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c -haddock DocsInHiFile.hs
+	'$(TEST_HC)' $(TEST_HC_OPTS) --show-iface DocsInHiFile.hi | grep -A 100 'module header:'
diff --git a/testsuite/tests/showIface/all.T b/testsuite/tests/showIface/all.T
index 5c89b70b59..df5d5cd9ec 100644
--- a/testsuite/tests/showIface/all.T
+++ b/testsuite/tests/showIface/all.T
@@ -1 +1,9 @@
 test('Orphans', normal, run_command, ['$MAKE -s --no-print-directory Orphans'])
+test('DocsInHiFile0',
+     extra_files(['DocsInHiFile.hs']),
+     run_command,
+     ['$MAKE -s --no-print-directory DocsInHiFile0'])
+test('DocsInHiFile1',
+     extra_files(['DocsInHiFile.hs']),
+     run_command,
+     ['$MAKE -s --no-print-directory DocsInHiFile1'])