Merge pull request #1317 from bgamari/wip/ghc-head-merge

Merge ghc-8.10 into ghc-head

1 files changed, 163 insertions, 3 deletions

diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs
index df585f29..9b80d98f 100644
--- a/haddock-api/src/Haddock/Interface/Json.hs
+++ b/haddock-api/src/Haddock/Interface/Json.hs
@@ -13,7 +13,6 @@ import GHC.Utils.Outputable
 
 import Control.Arrow
 import Data.Map (Map)
-import Data.Bifunctor
 import qualified Data.Map as Map
 
 import Haddock.Types
@@ -58,11 +57,172 @@ jsonMap f g = jsonObject . map (f *** g) . Map.toList
 jsonMDoc :: MDoc Name -> JsonDoc
 jsonMDoc MetaDoc{..} =
   jsonObject [ ("meta", jsonObject [("version", jsonMaybe (jsonString . show) (_version _meta))])
-             , ("doc",  jsonDoc _doc)
+             , ("document",  jsonDoc _doc)
              ]
 
+showModName :: Wrap (ModuleName, OccName) -> String
+showModName = showWrapped (moduleNameString . fst)
+
+showName :: Wrap Name -> String
+showName = showWrapped nameStableString
+
+
 jsonDoc :: Doc Name -> JsonDoc
-jsonDoc doc = jsonString (show (bimap (moduleNameString . fst) nameStableString doc))
+
+jsonDoc DocEmpty = jsonObject
+    [ ("tag", jsonString "DocEmpty") ]
+
+jsonDoc (DocAppend x y) = jsonObject
+    [ ("tag", jsonString "DocAppend")
+    , ("first", jsonDoc x)
+    , ("second", jsonDoc y)
+    ]
+
+jsonDoc (DocString s) = jsonObject
+    [ ("tag", jsonString "DocString")
+    , ("string", jsonString s)
+    ]
+
+jsonDoc (DocParagraph x) = jsonObject
+    [ ("tag", jsonString "DocParagraph")
+    , ("document", jsonDoc x)
+    ]
+
+jsonDoc (DocIdentifier name) = jsonObject
+    [ ("tag", jsonString "DocIdentifier")
+    , ("name", jsonString (showName name))
+    ]
+
+jsonDoc (DocIdentifierUnchecked modName) = jsonObject
+    [ ("tag", jsonString "DocIdentifierUnchecked")
+    , ("modName", jsonString (showModName modName))
+    ]
+
+jsonDoc (DocModule s) = jsonObject
+    [ ("tag", jsonString "DocModule")
+    , ("string", jsonString s)
+    ]
+
+jsonDoc (DocWarning x) = jsonObject
+    [ ("tag", jsonString "DocWarning")
+    , ("document", jsonDoc x)
+    ]
+
+jsonDoc (DocEmphasis x) = jsonObject
+    [ ("tag", jsonString "DocEmphasis")
+    , ("document", jsonDoc x)
+    ]
+
+jsonDoc (DocMonospaced x) = jsonObject
+    [ ("tag", jsonString "DocMonospaced")
+    , ("document", jsonDoc x)
+    ]
+
+jsonDoc (DocBold x) = jsonObject
+    [ ("tag", jsonString "DocBold")
+    , ("document", jsonDoc x)
+    ]
+
+jsonDoc (DocUnorderedList xs) = jsonObject
+    [ ("tag", jsonString "DocUnorderedList")
+    , ("documents", jsonArray (fmap jsonDoc xs))
+    ]
+
+jsonDoc (DocOrderedList xs) = jsonObject
+    [ ("tag", jsonString "DocOrderedList")
+    , ("documents", jsonArray (fmap jsonDoc xs))
+    ]
+
+jsonDoc (DocDefList xys) = jsonObject
+    [ ("tag", jsonString "DocDefList")
+    , ("definitions", jsonArray (fmap jsonDef xys))
+    ]
+  where
+    jsonDef (x, y) = jsonObject [("document", jsonDoc x), ("y", jsonDoc y)]
+
+jsonDoc (DocCodeBlock x) = jsonObject
+    [ ("tag", jsonString "DocCodeBlock")
+    , ("document", jsonDoc x)
+    ]
+
+jsonDoc (DocHyperlink hyperlink) = jsonObject
+    [ ("tag", jsonString "DocHyperlink")
+    , ("hyperlink", jsonHyperlink hyperlink)
+    ]
+  where
+    jsonHyperlink Hyperlink{..} = jsonObject
+        [ ("hyperlinkUrl", jsonString hyperlinkUrl)
+        , ("hyperlinkLabel", jsonMaybe jsonDoc hyperlinkLabel)
+        ]
+
+jsonDoc (DocPic picture) = jsonObject
+    [ ("tag", jsonString "DocPic")
+    , ("picture", jsonPicture picture)
+    ]
+  where
+    jsonPicture Picture{..} = jsonObject
+        [ ("pictureUrl", jsonString pictureUri)
+        , ("pictureLabel", jsonMaybe jsonString pictureTitle)
+        ]
+
+jsonDoc (DocMathInline s) = jsonObject
+    [ ("tag", jsonString "DocMathInline")
+    , ("string", jsonString s)
+    ]
+
+jsonDoc (DocMathDisplay s) = jsonObject
+    [ ("tag", jsonString "DocMathDisplay")
+    , ("string", jsonString s)
+    ]
+
+jsonDoc (DocAName s) = jsonObject
+    [ ("tag", jsonString "DocAName")
+    , ("string", jsonString s)
+    ]
+
+jsonDoc (DocProperty s) = jsonObject
+    [ ("tag", jsonString "DocProperty")
+    , ("string", jsonString s)
+    ]
+
+jsonDoc (DocExamples examples) = jsonObject
+    [ ("tag", jsonString "DocExamples")
+    , ("examples", jsonArray (fmap jsonExample examples))
+    ]
+  where
+    jsonExample Example{..} = jsonObject
+        [ ("exampleExpression", jsonString exampleExpression)
+        , ("exampleResult", jsonArray (fmap jsonString exampleResult))
+        ]
+
+jsonDoc (DocHeader header) = jsonObject
+    [ ("tag", jsonString "DocHeader")
+    , ("header", jsonHeader header)
+    ]
+  where
+    jsonHeader Header{..} = jsonObject
+        [ ("headerLevel", jsonInt headerLevel)
+        , ("headerTitle", jsonDoc headerTitle)
+        ]
+
+jsonDoc (DocTable table) = jsonObject
+    [ ("tag", jsonString "DocTable")
+    , ("table", jsonTable table)
+    ]
+  where
+    jsonTable Table{..} = jsonObject
+        [ ("tableHeaderRows", jsonArray (fmap jsonTableRow tableHeaderRows))
+        , ("tableBodyRows", jsonArray (fmap jsonTableRow tableBodyRows))
+        ]
+
+    jsonTableRow TableRow{..} = jsonArray (fmap jsonTableCell tableRowCells)
+
+    jsonTableCell TableCell{..} = jsonObject
+        [ ("tableCellColspan", jsonInt tableCellColspan)
+        , ("tableCellRowspan", jsonInt tableCellRowspan)
+        , ("tableCellContents", jsonDoc tableCellContents)
+        ]
+
 
 jsonModule :: Module -> JsonDoc
 jsonModule = JSString . moduleStableString