aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Interface/Json.hs
blob: 636d3e19dfc99987c869eb37875bd6663ea13d25 (plain) (blame)
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 BasicTypes
import Json
import Module
import Name
import 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