{-# LANGUAGE RecordWildCards #-}
module Haddock.Interface.Json (
jsonInstalledInterface
, jsonInterfaceFile
, renderJson
) where
import BasicTypes
import Json
import Module
import Name
import Outputable
import Control.Arrow
import Data.Map (Map)
import qualified Data.Map as Map
import Haddock.Types
import Haddock.InterfaceFile
jsonInterfaceFile :: InterfaceFile -> JsonDoc
jsonInterfaceFile InterfaceFile{..} =
jsonObject [ ("link_env" , jsonMap nameStableString (jsonString . moduleNameString . moduleName) ifLinkEnv)
, ("inst_ifaces", jsonArray (map jsonInstalledInterface ifInstalledIfaces))
]
jsonInstalledInterface :: InstalledInterface -> JsonDoc
jsonInstalledInterface InstalledInterface{..} = jsonObject properties
where
properties =
[ ("module" , jsonModule instMod)
, ("is_sig" , jsonBool instIsSig)
, ("info" , jsonHaddockModInfo instInfo)
, ("doc_map" , jsonMap nameStableString jsonMDoc instDocMap)
, ("arg_map" , jsonMap nameStableString (jsonMap show jsonMDoc) instArgMap)
, ("exports" , jsonArray (map jsonName instExports))
, ("visible_exports" , jsonArray (map jsonName instVisibleExports))
, ("options" , jsonArray (map (jsonString . show) instOptions))
, ("fix_map" , jsonMap nameStableString jsonFixity instFixMap)
]
jsonHaddockModInfo :: HaddockModInfo Name -> JsonDoc
jsonHaddockModInfo HaddockModInfo{..} =
jsonObject [ ("description" , jsonMaybe jsonDoc hmi_description)
, ("copyright" , jsonMaybe jsonString hmi_copyright)
, ("maintainer" , jsonMaybe jsonString hmi_maintainer)
, ("stability" , jsonMaybe jsonString hmi_stability)
, ("protability" , jsonMaybe jsonString hmi_portability)
, ("safety" , jsonMaybe jsonString hmi_safety)
, ("language" , jsonMaybe (jsonString . show) hmi_language)
, ("extensions" , jsonArray (map (jsonString . show) hmi_extensions))
]
jsonMap :: (a -> String) -> (b -> JsonDoc) -> Map a b -> JsonDoc
jsonMap f g = jsonObject . map (f *** g) . Map.toList
jsonMDoc :: MDoc Name -> JsonDoc
jsonMDoc MetaDoc{..} =
jsonObject [ ("meta", jsonObject [("version", jsonMaybe (jsonString . show) (_version _meta))])
, ("document", jsonDoc _doc)
]
showModName :: Wrap (ModuleName, OccName) -> String
showModName = showWrapped (moduleNameString . fst)
showName :: Wrap Name -> String
showName = showWrapped nameStableString
jsonDoc :: Doc Name -> JsonDoc
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
jsonName :: Name -> JsonDoc
jsonName = JSString . nameStableString
jsonFixity :: Fixity -> JsonDoc
jsonFixity (Fixity _ prec dir) =
jsonObject [ ("prec" , jsonInt prec)
, ("direction" , jsonFixityDirection dir)
]
jsonFixityDirection :: FixityDirection -> JsonDoc
jsonFixityDirection InfixL = jsonString "infixl"
jsonFixityDirection InfixR = jsonString "infixr"
jsonFixityDirection InfixN = jsonString "infix"
renderJson :: JsonDoc -> SDoc
renderJson = renderJSON
jsonMaybe :: (a -> JsonDoc) -> Maybe a -> JsonDoc
jsonMaybe = maybe jsonNull
jsonString :: String -> JsonDoc
jsonString = JSString
jsonObject :: [(String, JsonDoc)] -> JsonDoc
jsonObject = JSObject
jsonArray :: [JsonDoc] -> JsonDoc
jsonArray = JSArray
jsonNull :: JsonDoc
jsonNull = JSNull
jsonInt :: Int -> JsonDoc
jsonInt = JSInt
jsonBool :: Bool -> JsonDoc
jsonBool = JSBool