aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Interface/Json.hs
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Interface/Json.hs')
-rw-r--r--haddock-api/src/Haddock/Interface/Json.hs166
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 043a1530..4e271602 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