1 files changed, 152 insertions, 0 deletions
diff --git a/compiler/GHC/Hs/Doc.hs b/compiler/GHC/Hs/Doc.hs
new file mode 100644
index 0000000000..18a820fa6e
--- /dev/null
+++ b/compiler/GHC/Hs/Doc.hs
@@ -0,0 +1,152 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module GHC.Hs.Doc
+  ( HsDocString
+  , LHsDocString
+  , mkHsDocString
+  , mkHsDocStringUtf8ByteString
+  , 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 = doubleQuotes . text . unpackHDS
+
+mkHsDocString :: String -> HsDocString
+mkHsDocString s =
+  inlinePerformIO $ do
+    let len = utf8EncodedLength s
+    buf <- mallocForeignPtrBytes len
+    withForeignPtr buf $ \ptr -> do
+      utf8EncodeString ptr s
+      pure (HsDocString (BS.fromForeignPtr buf 0 len))
+
+-- | Create a 'HsDocString' from a UTF8-encoded 'ByteString'.
+mkHsDocStringUtf8ByteString :: ByteString -> HsDocString
+mkHsDocStringUtf8ByteString = HsDocString
+
+unpackHDS :: HsDocString -> String
+unpackHDS = utf8DecodeByteString . hsDocStringToByteString
+
+-- | Return the contents of a 'HsDocString' as a UTF8-encoded 'ByteString'.
+hsDocStringToByteString :: HsDocString -> ByteString
+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.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)
+
+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.toList (Map.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 Map.fromDistinctAscList . Map.fromList <$> 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