hi haddock: Lex and store haddock docs in interface files

Names appearing in Haddock docstrings are lexed and renamed like any other names
appearing in the AST. We currently rename names irrespective of the namespace,
so both type and constructor names corresponding to an identifier will appear in
the docstring. Haddock will select a given name as the link destination based on
its own heuristics.

This patch also restricts the limitation of `-haddock` being incompatible with
`Opt_KeepRawTokenStream`.

The export and documenation structure is now computed in GHC and serialised in
.hi files. This can be used by haddock to directly generate doc pages without
reparsing or renaming the source. At the moment the operation of haddock
is not modified, that's left to a future patch.

Updates the haddock submodule with the minimum changes needed.

5 files changed, 447 insertions, 126 deletions

diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index 40c54b629a..568783bdb5 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -686,8 +686,8 @@ pprConDecl (ConDeclH98 { con_name = L _ con
                        , con_mb_cxt = mcxt
                        , con_args = args
                        , con_doc = doc })
-  = sep [ ppr_mbDoc doc
-        , pprHsForAll (mkHsForAllInvisTele noAnn ex_tvs) mcxt
+  = pprMaybeWithDoc doc $
+    sep [ pprHsForAll (mkHsForAllInvisTele noAnn ex_tvs) mcxt
         , ppr_details args ]
   where
     -- In ppr_details: let's not print the multiplicities (they are always 1, by
@@ -703,7 +703,7 @@ pprConDecl (ConDeclH98 { con_name = L _ con
 pprConDecl (ConDeclGADT { con_names = cons, con_bndrs = L _ outer_bndrs
                         , con_mb_cxt = mcxt, con_g_args = args
                         , con_res_ty = res_ty, con_doc = doc })
-  = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon
+  = pprMaybeWithDoc doc $ ppr_con_names cons <+> dcolon
     <+> (sep [pprHsOuterSigTyVarBndrs outer_bndrs <+> pprLHsContext mcxt,
               sep (ppr_args args ++ [ppr res_ty]) ])
   where
@@ -1172,7 +1172,7 @@ type instance Anno (DataFamInstDecl (GhcPass p)) = SrcSpanAnnA
 type instance Anno (FamEqn (GhcPass p) _) = SrcSpanAnnA
 type instance Anno (ClsInstDecl (GhcPass p)) = SrcSpanAnnA
 type instance Anno (InstDecl (GhcPass p)) = SrcSpanAnnA
-type instance Anno DocDecl = SrcSpanAnnA
+type instance Anno (DocDecl (GhcPass p)) = SrcSpanAnnA
 type instance Anno (DerivDecl (GhcPass p)) = SrcSpanAnnA
 type instance Anno OverlapMode = SrcSpanAnnP
 type instance Anno (DerivStrategy (GhcPass p)) = SrcAnn NoEpAnns
diff --git a/compiler/GHC/Hs/Doc.hs b/compiler/GHC/Hs/Doc.hs
index 117ce3adad..91f584c8d9 100644
--- a/compiler/GHC/Hs/Doc.hs
+++ b/compiler/GHC/Hs/Doc.hs
@@ -1,161 +1,288 @@
-
+-- | Types and functions for raw and lexed docstrings.
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE StandaloneDeriving #-}
 
 module GHC.Hs.Doc
-  ( HsDocString
-  , LHsDocString
-  , mkHsDocString
-  , mkHsDocStringUtf8ByteString
-  , isEmptyDocString
-  , unpackHDS
-  , hsDocStringToByteString
-  , ppr_mbDoc
+  ( HsDoc
+  , WithHsDocIdentifiers(..)
+  , hsDocIds
+  , LHsDoc
+  , pprHsDocDebug
+  , pprWithDoc
+  , pprMaybeWithDoc
 
-  , appendDocs
-  , concatDocs
+  , module GHC.Hs.DocString
 
-  , DeclDocMap(..)
-  , emptyDeclDocMap
+  , ExtractedTHDocs(..)
 
-  , ArgDocMap(..)
-  , emptyArgDocMap
+  , DocStructureItem(..)
+  , DocStructure
 
-  , ExtractedTHDocs(..)
+  , Docs(..)
+  , emptyDocs
   ) where
 
 import GHC.Prelude
 
 import GHC.Utils.Binary
-import GHC.Utils.Encoding
 import GHC.Types.Name
-import GHC.Utils.Outputable as Outputable
+import GHC.Utils.Outputable as Outputable hiding ((<>))
 import GHC.Types.SrcLoc
+import qualified GHC.Data.EnumSet as EnumSet
+import GHC.Data.EnumSet (EnumSet)
+import GHC.Types.Avail
+import GHC.Types.Name.Set
+import GHC.Unit.Module.Name
+import GHC.Driver.Flags
 
-import Data.ByteString (ByteString)
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Char8 as C8
+import Control.Applicative (liftA2)
 import Data.Data
 import Data.IntMap (IntMap)
 import qualified Data.IntMap as IntMap
 import Data.Map (Map)
 import qualified Data.Map as Map
-import Data.Maybe
+import Data.List.NonEmpty (NonEmpty(..))
+import GHC.LanguageExtensions.Type
+import qualified GHC.Utils.Outputable as O
+import Language.Haskell.Syntax.Extension
+import GHC.Hs.Extension
+import GHC.Types.Unique.Map
+import Data.List (sortBy)
+
+import GHC.Hs.DocString
 
--- | Haskell Documentation String
+-- | A docstring with the (probable) identifiers found in it.
+type HsDoc = WithHsDocIdentifiers HsDocString
+
+-- | Annotate a value with the probable identifiers found in it
+-- These will be used by haddock to generate links.
+--
+-- The identifiers are bundled along with their location in the source file.
+-- This is useful for tooling to know exactly where they originate.
 --
--- 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)
+-- This type is currently used in two places - for regular documentation comments,
+-- with 'a' set to 'HsDocString', and for adding identifier information to
+-- warnings, where 'a' is 'StringLiteral'
+data WithHsDocIdentifiers a pass = WithHsDocIdentifiers
+  { hsDocString      :: !a
+  , hsDocIdentifiers :: ![Located (IdP pass)]
+  }
 
--- | Located Haskell Documentation String
-type LHsDocString = Located HsDocString
+deriving instance (Data pass, Data (IdP pass), Data a) => Data (WithHsDocIdentifiers a pass)
+deriving instance (Eq (IdP pass), Eq a) => Eq (WithHsDocIdentifiers a pass)
 
-instance Binary HsDocString where
-  put_ bh (HsDocString bs) = put_ bh bs
-  get bh = HsDocString <$> get bh
+-- | For compatibility with the existing @-ddump-parsed' output, we only show
+-- the docstring.
+--
+-- Use 'pprHsDoc' to show `HsDoc`'s internals.
+instance Outputable a => Outputable (WithHsDocIdentifiers a pass) where
+  ppr (WithHsDocIdentifiers s _ids) = ppr s
 
-instance Outputable HsDocString where
-  ppr = doubleQuotes . text . unpackHDS
+instance Binary a => Binary (WithHsDocIdentifiers a GhcRn) where
+  put_ bh (WithHsDocIdentifiers s ids) = do
+    put_ bh s
+    put_ bh ids
+  get bh =
+    liftA2 WithHsDocIdentifiers (get bh) (get bh)
 
-isEmptyDocString :: HsDocString -> Bool
-isEmptyDocString (HsDocString bs) = BS.null bs
+-- | Extract a mapping from the lexed identifiers to the names they may
+-- correspond to.
+hsDocIds :: WithHsDocIdentifiers a GhcRn -> NameSet
+hsDocIds (WithHsDocIdentifiers _ ids) = mkNameSet $ map unLoc ids
 
-mkHsDocString :: String -> HsDocString
-mkHsDocString s = HsDocString (utf8EncodeString s)
+-- | Pretty print a thing with its doc
+-- The docstring will include the comment decorators '-- |', '{-|' etc
+-- and will come either before or after depending on how it was written
+-- i.e it will come after the thing if it is a '-- ^' or '{-^' and before
+-- otherwise.
+pprWithDoc :: LHsDoc name -> SDoc -> SDoc
+pprWithDoc doc = pprWithDocString (hsDocString $ unLoc doc)
 
--- | Create a 'HsDocString' from a UTF8-encoded 'ByteString'.
-mkHsDocStringUtf8ByteString :: ByteString -> HsDocString
-mkHsDocStringUtf8ByteString = HsDocString
+-- | See 'pprWithHsDoc'
+pprMaybeWithDoc :: Maybe (LHsDoc name) -> SDoc -> SDoc
+pprMaybeWithDoc Nothing    = id
+pprMaybeWithDoc (Just doc) = pprWithDoc doc
 
-unpackHDS :: HsDocString -> String
-unpackHDS = utf8DecodeByteString . hsDocStringToByteString
+-- | Print a doc with its identifiers, useful for debugging
+pprHsDocDebug :: (Outputable (IdP name)) => HsDoc name -> SDoc
+pprHsDocDebug (WithHsDocIdentifiers s ids) =
+    vcat [ text "text:" $$ nest 2 (pprHsDocString s)
+         , text "identifiers:" $$ nest 2 (vcat (map pprLocatedAlways ids))
+         ]
 
--- | Return the contents of a 'HsDocString' as a UTF8-encoded 'ByteString'.
-hsDocStringToByteString :: HsDocString -> ByteString
-hsDocStringToByteString (HsDocString bs) = bs
+type LHsDoc pass = Located (HsDoc pass)
 
-ppr_mbDoc :: Maybe LHsDocString -> SDoc
-ppr_mbDoc (Just doc) = ppr doc
-ppr_mbDoc Nothing    = empty
+-- | A simplified version of 'HsImpExp.IE'.
+data DocStructureItem
+  = DsiSectionHeading Int (HsDoc GhcRn)
+  | DsiDocChunk (HsDoc GhcRn)
+  | DsiNamedChunkRef String
+  | DsiExports Avails
+  | DsiModExport
+      (NonEmpty ModuleName) -- ^ We might re-export avails from multiple
+                            -- modules with a single export declaration. E.g.
+                            -- when we have
+                            --
+                            -- > module M (module X) where
+                            -- > import R0 as X
+                            -- > import R1 as X
+      Avails
 
--- | 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.toList m)
-  -- We can't rely on a deterministic ordering of the `Name`s here.
-  -- See the comments on `Name`'s `Ord` instance for context.
-  get bh = DeclDocMap . Map.fromList <$> 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)
+instance Binary DocStructureItem where
+  put_ bh = \case
+    DsiSectionHeading level doc -> do
+      putByte bh 0
+      put_ bh level
+      put_ bh doc
+    DsiDocChunk doc -> do
+      putByte bh 1
+      put_ bh doc
+    DsiNamedChunkRef name -> do
+      putByte bh 2
+      put_ bh name
+    DsiExports avails -> do
+      putByte bh 3
+      put_ bh avails
+    DsiModExport mod_names avails -> do
+      putByte bh 4
+      put_ bh mod_names
+      put_ bh avails
+
+  get bh = do
+    tag <- getByte bh
+    case tag of
+      0 -> DsiSectionHeading <$> get bh <*> get bh
+      1 -> DsiDocChunk <$> get bh
+      2 -> DsiNamedChunkRef <$> get bh
+      3 -> DsiExports <$> get bh
+      4 -> DsiModExport <$> get bh <*> get bh
+      _ -> fail "instance Binary DocStructureItem: Invalid tag"
+
+instance Outputable DocStructureItem where
+  ppr = \case
+    DsiSectionHeading level doc -> vcat
+      [ text "section heading, level" <+> ppr level O.<> colon
+      , nest 2 (pprHsDocDebug doc)
+      ]
+    DsiDocChunk doc -> vcat
+      [ text "documentation chunk:"
+      , nest 2 (pprHsDocDebug doc)
+      ]
+    DsiNamedChunkRef name ->
+      text "reference to named chunk:" <+> text name
+    DsiExports avails ->
+      text "avails:" $$ nest 2 (ppr avails)
+    DsiModExport mod_names avails ->
+      text "re-exported module(s):" <+> ppr mod_names $$ nest 2 (ppr avails)
 
-emptyDeclDocMap :: DeclDocMap
-emptyDeclDocMap = DeclDocMap Map.empty
+type DocStructure = [DocStructureItem]
 
--- | Docs for arguments. E.g. function arguments, method arguments.
-newtype ArgDocMap = ArgDocMap (Map Name (IntMap HsDocString))
+data Docs = Docs
+  { docs_mod_hdr      :: Maybe (HsDoc GhcRn)
+    -- ^ Module header.
+  , docs_decls        :: UniqMap Name [HsDoc GhcRn]
+    -- ^ Docs for declarations: functions, data types, instances, methods etc.
+    -- A list because sometimes subsequent haddock comments can be combined into one
+  , docs_args         :: UniqMap Name (IntMap (HsDoc GhcRn))
+    -- ^ Docs for arguments. E.g. function arguments, method arguments.
+  , docs_structure    :: DocStructure
+  , docs_named_chunks :: Map String (HsDoc GhcRn)
+    -- ^ Map from chunk name to content.
+    --
+    -- This map will be empty unless we have an explicit export list from which
+    -- we can reference the chunks.
+  , docs_haddock_opts :: Maybe String
+    -- ^ Haddock options from @OPTIONS_HADDOCK@ or from @-haddock-opts@.
+  , docs_language     :: Maybe Language
+    -- ^ The 'Language' used in the module, for example 'Haskell2010'.
+  , docs_extensions   :: EnumSet Extension
+    -- ^ The full set of language extensions used in the module.
+  }
 
-instance Binary ArgDocMap where
-  put_ bh (ArgDocMap m) = put_ bh (Map.toList (IntMap.toAscList <$> m))
-  -- We can't rely on a deterministic ordering of the `Name`s here.
-  -- See the comments on `Name`'s `Ord` instance for context.
-  get bh = ArgDocMap . fmap IntMap.fromDistinctAscList . Map.fromList <$> get bh
+instance Binary Docs where
+  put_ bh docs = do
+    put_ bh (docs_mod_hdr docs)
+    put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetEltsUniqMap $ docs_decls docs)
+    put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetEltsUniqMap $ docs_args docs)
+    put_ bh (docs_structure docs)
+    put_ bh (Map.toList $ docs_named_chunks docs)
+    put_ bh (docs_haddock_opts docs)
+    put_ bh (docs_language docs)
+    put_ bh (docs_extensions docs)
+  get bh = do
+    mod_hdr <- get bh
+    decls <- listToUniqMap <$> get bh
+    args <- listToUniqMap <$> get bh
+    structure <- get bh
+    named_chunks <- Map.fromList <$> get bh
+    haddock_opts <- get bh
+    language <- get bh
+    exts <- get bh
+    pure Docs { docs_mod_hdr = mod_hdr
+              , docs_decls =  decls
+              , docs_args = args
+              , docs_structure = structure
+              , docs_named_chunks = named_chunks
+              , docs_haddock_opts = haddock_opts
+              , docs_language = language
+              , docs_extensions = exts
+              }
 
-instance Outputable ArgDocMap where
-  ppr (ArgDocMap m) = vcat (map pprPair (Map.toAscList m))
+instance Outputable Docs where
+  ppr docs =
+      vcat
+        [ pprField (pprMaybe pprHsDocDebug) "module header" docs_mod_hdr
+        , pprField (ppr . fmap (ppr . map pprHsDocDebug)) "declaration docs" docs_decls
+        , pprField (ppr . fmap (pprIntMap ppr pprHsDocDebug)) "arg docs" docs_args
+        , pprField (vcat . map ppr) "documentation structure" docs_structure
+        , pprField (pprMap (doubleQuotes . text) pprHsDocDebug) "named chunks"
+                   docs_named_chunks
+        , pprField pprMbString "haddock options" docs_haddock_opts
+        , pprField ppr "language" docs_language
+        , pprField (vcat . map ppr . EnumSet.toList) "language extensions"
+                   docs_extensions
+        ]
     where
-      pprPair (name, int_map) =
-        ppr name Outputable.<> colon $$ nest 2 (pprIntMap int_map)
-      pprIntMap im = vcat (map pprIPair (IntMap.toAscList im))
-      pprIPair (i, doc) = ppr i Outputable.<> colon $$ nest 2 (ppr doc)
+      pprField :: (a -> SDoc) -> String -> (Docs -> a) -> SDoc
+      pprField ppr' heading lbl =
+        text heading O.<> colon $$ nest 2 (ppr' (lbl docs))
+      pprMap pprKey pprVal m =
+        vcat $ flip map (Map.toList m) $ \(k, v) ->
+          pprKey k O.<> colon $$ nest 2 (pprVal v)
+      pprIntMap pprKey pprVal m =
+        vcat $ flip map (IntMap.toList m) $ \(k, v) ->
+          pprKey k O.<> colon $$ nest 2 (pprVal v)
+      pprMbString Nothing = empty
+      pprMbString (Just s) = text s
+      pprMaybe ppr' = \case
+        Nothing -> text "Nothing"
+        Just x -> text "Just" <+> ppr' x
 
-emptyArgDocMap :: ArgDocMap
-emptyArgDocMap = ArgDocMap Map.empty
+emptyDocs :: Docs
+emptyDocs = Docs
+  { docs_mod_hdr = Nothing
+  , docs_decls = emptyUniqMap
+  , docs_args = emptyUniqMap
+  , docs_structure = []
+  , docs_named_chunks = Map.empty
+  , docs_haddock_opts = Nothing
+  , docs_language = Nothing
+  , docs_extensions = EnumSet.empty
+  }
 
 -- | Maps of docs that were added via Template Haskell's @putDoc@.
 data ExtractedTHDocs =
   ExtractedTHDocs
-    { ethd_mod_header :: Maybe HsDocString
+    { ethd_mod_header :: Maybe (HsDoc GhcRn)
       -- ^ The added module header documentation, if it exists.
-    , ethd_decl_docs  :: DeclDocMap
+    , ethd_decl_docs  :: UniqMap Name (HsDoc GhcRn)
       -- ^ The documentation added to declarations.
-    , ethd_arg_docs   :: ArgDocMap
+    , ethd_arg_docs   :: UniqMap Name (IntMap (HsDoc GhcRn))
       -- ^ The documentation added to function arguments.
-    , ethd_inst_docs  :: DeclDocMap
+    , ethd_inst_docs  :: UniqMap Name (HsDoc GhcRn)
       -- ^ The documentation added to class and family instances.
     }
diff --git a/compiler/GHC/Hs/DocString.hs b/compiler/GHC/Hs/DocString.hs
new file mode 100644
index 0000000000..3a557ee0e8
--- /dev/null
+++ b/compiler/GHC/Hs/DocString.hs
@@ -0,0 +1,197 @@
+-- | An exactprintable structure for docstrings
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module GHC.Hs.DocString
+  ( LHsDocString
+  , HsDocString(..)
+  , HsDocStringDecorator(..)
+  , HsDocStringChunk(..)
+  , LHsDocStringChunk
+  , isEmptyDocString
+  , unpackHDSC
+  , mkHsDocStringChunk
+  , mkHsDocStringChunkUtf8ByteString
+  , pprHsDocString
+  , pprHsDocStrings
+  , mkGeneratedHsDocString
+  , docStringChunks
+  , renderHsDocString
+  , renderHsDocStrings
+  , exactPrintHsDocString
+  , pprWithDocString
+  ) where
+
+import GHC.Prelude
+
+import GHC.Utils.Binary
+import GHC.Utils.Encoding
+import GHC.Utils.Outputable as Outputable hiding ((<>))
+import GHC.Types.SrcLoc
+
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import Data.Data
+import Data.List.NonEmpty (NonEmpty(..))
+import Data.List (intercalate)
+
+type LHsDocString = Located HsDocString
+
+-- | Haskell Documentation String
+--
+-- Rich structure to support exact printing
+-- The location around each chunk doesn't include the decorators
+data HsDocString
+  = MultiLineDocString !HsDocStringDecorator !(NonEmpty LHsDocStringChunk)
+     -- ^ The first chunk is preceded by "-- <decorator>" and each following chunk is preceded by "--"
+     -- Example: -- | This is a docstring for 'foo'. It is the line with the decorator '|' and is always included
+     --          -- This continues that docstring and is the second element in the NonEmpty list
+     --          foo :: a -> a
+  | NestedDocString !HsDocStringDecorator LHsDocStringChunk
+     -- ^ The docstring is preceded by "{-<decorator>" and followed by "-}"
+     -- The chunk contains balanced pairs of '{-' and '-}'
+  | GeneratedDocString HsDocStringChunk
+     -- ^ A docstring generated either internally or via TH
+     -- Pretty printed with the '-- |' decorator
+     -- This is because it may contain unbalanced pairs of '{-' and '-}' and
+     -- not form a valid 'NestedDocString'
+  deriving (Eq, Data, Show)
+
+instance Outputable HsDocString where
+  ppr = text . renderHsDocString
+
+-- | Annotate a pretty printed thing with its doc
+-- The docstring comes after if is 'HsDocStringPrevious'
+-- Otherwise it comes before.
+-- Note - we convert MultiLineDocString HsDocStringPrevious to HsDocStringNext
+-- because we can't control if something else will be pretty printed on the same line
+pprWithDocString :: HsDocString -> SDoc -> SDoc
+pprWithDocString  (MultiLineDocString HsDocStringPrevious ds) sd = pprWithDocString (MultiLineDocString HsDocStringNext ds) sd
+pprWithDocString doc@(NestedDocString HsDocStringPrevious  _) sd = sd <+> pprHsDocString doc
+pprWithDocString doc sd = pprHsDocString doc $+$ sd
+
+
+instance Binary HsDocString where
+  put_ bh x = case x of
+    MultiLineDocString dec xs -> do
+      putByte bh 0
+      put_ bh dec
+      put_ bh xs
+    NestedDocString dec x -> do
+      putByte bh 1
+      put_ bh dec
+      put_ bh x
+    GeneratedDocString x -> do
+      putByte bh 2
+      put_ bh x
+  get bh = do
+    tag <- getByte bh
+    case tag of
+      0 -> MultiLineDocString <$> get bh <*> get bh
+      1 -> NestedDocString <$> get bh <*> get bh
+      2 -> GeneratedDocString <$> get bh
+      t -> fail $ "HsDocString: invalid tag " ++ show t
+
+data HsDocStringDecorator
+  = HsDocStringNext -- ^ '|' is the decorator
+  | HsDocStringPrevious -- ^ '^' is the decorator
+  | HsDocStringNamed !String -- ^ '$<string>' is the decorator
+  | HsDocStringGroup !Int -- ^ The decorator is the given number of '*'s
+  deriving (Eq, Ord, Show, Data)
+
+instance Outputable HsDocStringDecorator where
+  ppr = text . printDecorator
+
+printDecorator :: HsDocStringDecorator -> String
+printDecorator HsDocStringNext = "|"
+printDecorator HsDocStringPrevious = "^"
+printDecorator (HsDocStringNamed n) = '$':n
+printDecorator (HsDocStringGroup n) = replicate n '*'
+
+instance Binary HsDocStringDecorator where
+  put_ bh x = case x of
+    HsDocStringNext -> putByte bh 0
+    HsDocStringPrevious -> putByte bh 1
+    HsDocStringNamed n -> putByte bh 2 >> put_ bh n
+    HsDocStringGroup n -> putByte bh 3 >> put_ bh n
+  get bh = do
+    tag <- getByte bh
+    case tag of
+      0 -> pure HsDocStringNext
+      1 -> pure HsDocStringPrevious
+      2 -> HsDocStringNamed <$> get bh
+      3 -> HsDocStringGroup <$> get bh
+      t -> fail $ "HsDocStringDecorator: invalid tag " ++ show t
+
+type LHsDocStringChunk = Located HsDocStringChunk
+
+-- | A continguous chunk of documentation
+newtype HsDocStringChunk = HsDocStringChunk ByteString
+  deriving (Eq,Ord,Data, Show)
+
+instance Binary HsDocStringChunk where
+  put_ bh (HsDocStringChunk bs) = put_ bh bs
+  get bh = HsDocStringChunk <$> get bh
+
+instance Outputable HsDocStringChunk where
+  ppr = text . unpackHDSC
+
+
+mkHsDocStringChunk :: String -> HsDocStringChunk
+mkHsDocStringChunk s = HsDocStringChunk (utf8EncodeString s)
+
+-- | Create a 'HsDocString' from a UTF8-encoded 'ByteString'.
+mkHsDocStringChunkUtf8ByteString :: ByteString -> HsDocStringChunk
+mkHsDocStringChunkUtf8ByteString = HsDocStringChunk
+
+unpackHDSC :: HsDocStringChunk -> String
+unpackHDSC (HsDocStringChunk bs) = utf8DecodeByteString bs
+
+nullHDSC :: HsDocStringChunk -> Bool
+nullHDSC (HsDocStringChunk bs) = BS.null bs
+
+mkGeneratedHsDocString :: String -> HsDocString
+mkGeneratedHsDocString = GeneratedDocString . mkHsDocStringChunk
+
+isEmptyDocString :: HsDocString -> Bool
+isEmptyDocString (MultiLineDocString _ xs) = all (nullHDSC . unLoc) xs
+isEmptyDocString (NestedDocString _ s) = nullHDSC $ unLoc s
+isEmptyDocString (GeneratedDocString x) = nullHDSC x
+
+docStringChunks :: HsDocString -> [LHsDocStringChunk]
+docStringChunks (MultiLineDocString _ (x:|xs)) = x:xs
+docStringChunks (NestedDocString _ x) = [x]
+docStringChunks (GeneratedDocString x) = [L (UnhelpfulSpan UnhelpfulGenerated) x]
+
+-- | Pretty print with decorators, exactly as the user wrote it
+pprHsDocString :: HsDocString -> SDoc
+pprHsDocString = text . exactPrintHsDocString
+
+pprHsDocStrings :: [HsDocString] -> SDoc
+pprHsDocStrings = text . intercalate "\n\n" . map exactPrintHsDocString
+
+-- | Pretty print with decorators, exactly as the user wrote it
+exactPrintHsDocString :: HsDocString -> String
+exactPrintHsDocString (MultiLineDocString dec (x :| xs))
+  = unlines' $ ("-- " ++ printDecorator dec ++ unpackHDSC (unLoc x))
+            : map (\x -> "--" ++ unpackHDSC (unLoc x)) xs
+exactPrintHsDocString (NestedDocString dec (L _ s))
+  = "{-" ++ printDecorator dec ++ unpackHDSC s ++ "-}"
+exactPrintHsDocString (GeneratedDocString x) = case lines (unpackHDSC x) of
+  [] -> ""
+  (x:xs) -> unlines' $ ( "-- |" ++ x)
+                    : map (\y -> "--"++y) xs
+
+-- | Just get the docstring, without any decorators
+renderHsDocString :: HsDocString -> String
+renderHsDocString (MultiLineDocString _ (x :| xs)) = unlines' $ map (unpackHDSC . unLoc) (x:xs)
+renderHsDocString (NestedDocString _ ds) = unpackHDSC $ unLoc ds
+renderHsDocString (GeneratedDocString x) = unpackHDSC x
+
+-- | Don't add a newline to a single string
+unlines' :: [String] -> String
+unlines' = intercalate "\n"
+
+-- | Just get the docstring, without any decorators
+-- Seperates docstrings using "\n\n", which is how haddock likes to render them
+renderHsDocStrings :: [HsDocString] -> String
+renderHsDocStrings = intercalate "\n\n" . map renderHsDocString
diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs
index fa16da9fdc..22c83e6e2a 100644
--- a/compiler/GHC/Hs/ImpExp.hs
+++ b/compiler/GHC/Hs/ImpExp.hs
@@ -19,7 +19,7 @@ module GHC.Hs.ImpExp where
 import GHC.Prelude
 
 import GHC.Unit.Module        ( ModuleName, IsBootInterface(..) )
-import GHC.Hs.Doc             ( HsDocString )
+import GHC.Hs.Doc
 import GHC.Types.SourceText   ( SourceText(..) )
 import GHC.Types.FieldLabel   ( FieldLabel )
 
@@ -279,8 +279,8 @@ data IE pass
         -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnModule'
 
         -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
-  | IEGroup             (XIEGroup pass) Int HsDocString -- ^ Doc section heading
-  | IEDoc               (XIEDoc pass) HsDocString       -- ^ Some documentation
+  | IEGroup             (XIEGroup pass) Int (LHsDoc pass) -- ^ Doc section heading
+  | IEDoc               (XIEDoc pass) (LHsDoc pass)       -- ^ Some documentation
   | IEDocNamed          (XIEDocNamed pass) String    -- ^ Reference to named doc
   | XIE !(XXIE pass)
 
diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index 2b17df420e..40dc281a74 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -1005,7 +1005,7 @@ pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
   where
     ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty,
                                  cd_fld_doc = doc }))
-        = ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
+        = pprMaybeWithDoc doc (ppr_names ns <+> dcolon <+> ppr ty)
 
     ppr_names :: [LFieldOcc (GhcPass p)] -> SDoc
     ppr_names [n] = pprPrefixOcc n
@@ -1094,10 +1094,7 @@ ppr_mono_ty (HsParTy _ ty)
   --    toHsType doesn't put in any HsParTys, so we may still need them
 
 ppr_mono_ty (HsDocTy _ ty doc)
-  -- AZ: Should we add parens?  Should we introduce "-- ^"?
-  = ppr_mono_lty ty <+> ppr (unLoc doc)
-  -- we pretty print Haddock comments on types as if they were
-  -- postfix operators
+  = pprWithDoc doc $ ppr_mono_lty ty
 
 ppr_mono_ty (XHsType t) = ppr t