1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
|
{-# LANGUAGE RecordWildCards #-}
module Haddock.Interface.Json (
jsonInstalledInterface
, jsonInterfaceFile
, renderJson
) where
import GHC.Types.Basic
import GHC.Utils.Json
import GHC.Types.Module
import GHC.Types.Name
import GHC.Utils.Outputable
import Control.Arrow
import Data.Map (Map)
import Data.Bifunctor
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))])
, ("doc", jsonDoc _doc)
]
jsonDoc :: Doc Name -> JsonDoc
jsonDoc doc = jsonString (show (bimap (moduleNameString . fst) nameStableString doc))
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
|
