@@ -2,40 +2,219 @@
22module Elm.Docs where
33
44import Control.Applicative ((<$>),(<*>))
5+import Control.Arrow (second)
56import Control.Monad
6−import Data.Aeson
7−
8−data Document = Doc
9− { moduleName :: String
10− , structure :: String
11− , entries :: [Entry]
12− } deriving (Show)
13−
14−data Entry = Entry
15− { name :: String
16− , comment :: String
17− , raw :: String
18− , assocPrec :: Maybe (String,Int)
19− } deriving (Show)
20−
21−instance FromJSON Document where
22− parseJSON (Object v) =
23− Doc <$> v .: "name"
24− <*> v .: "document"
25− <*> (concat <$> sequence [ v .: "aliases", v .: "datatypes", v .: "values" ])
26−
27− parseJSON _ = fail "Conversion to Document was expecting an object"
28−
29−instance FromJSON Entry where
30− parseJSON (Object v) =
31− Entry <$> v .: "name"
32− <*> v .: "comment"
33− <*> v .: "raw"
34− <*> (liftM2 (,) <$> v .:? "associativity"
35− <*> v .:? "precedence")
36−
37− parseJSON _ = fail "Conversion to Entry was expecting an object"
38−
39−data Content = Markdown String | Value String
40− deriving Show
7+import Data.Aeson ((.:), (.:?), (.=))
8+import qualified Data.Aeson as Json
9+import qualified Data.ByteString.Lazy.Char8 as BS
10+import qualified Data.Text as Text
4111
12+import qualified Elm.Compiler.Module as Module
13+
14+
15+data Documentation = Documentation
16+ { moduleName :: Module.Name
17+ , overview :: String
18+ , aliases :: [Alias]
19+ , types :: [Union]
20+ , values :: [Value]
21+ }
22+
23+
24+data Alias = Alias
25+ { aliasName :: String
26+ , aliasComment :: String
27+ , aliasArgs :: [String]
28+ , aliasType :: Type
29+ }
30+
31+
32+data Union = Union
33+ { unionName :: String
34+ , unionComment :: String
35+ , unionArgs :: [String]
36+ , unionCases :: [(String, [Type])]
37+ }
38+
39+
40+data Value = Value
41+ { valueName :: String
42+ , valueComment :: String
43+ , valueTipe :: Type
44+ , valueAssocPrec :: Maybe (String,Int)
45+ }
46+
47+
48+data Type
49+ = Lambda Type Type
50+ | Var String
51+ | Type String
52+ | App Type [Type]
53+ | Record [(String, Type)] (Maybe Type)
54+
55+
56+-- JSON for DOCUMENTATION
57+
58+instance Json.ToJSON Documentation where
59+ toJSON (Documentation name comment aliases types values) =
60+ Json.object
61+ [ "name" .= name
62+ , "comment" .= comment
63+ , "aliases" .= aliases
64+ , "types" .= types
65+ , "values" .= values
66+ ]
67+
68+instance Json.FromJSON Documentation where
69+ parseJSON (Json.Object obj) =
70+ Documentation
71+ <$> obj .: "name"
72+ <*> obj .: "comment"
73+ <*> obj .: "aliases"
74+ <*> obj .: "types"
75+ <*> obj .: "values"
76+
77+ parseJSON value =
78+ fail $ "Cannot decode Documentation from: " ++ BS.unpack (Json.encode value)
79+
80+
81+-- JSON for ALIAS
82+
83+instance Json.ToJSON Alias where
84+ toJSON (Alias name comment args tipe) =
85+ Json.object
86+ [ "name" .= name
87+ , "comment" .= comment
88+ , "args" .= args
89+ , "type" .= tipe
90+ ]
91+
92+instance Json.FromJSON Alias where
93+ parseJSON (Json.Object obj) =
94+ Alias
95+ <$> obj .: "name"
96+ <*> obj .: "comment"
97+ <*> obj .: "args"
98+ <*> obj .: "type"
99+
100+ parseJSON value =
101+ fail $ "Cannot decode Alias from: " ++ BS.unpack (Json.encode value)
102+
103+
104+-- JSON for UNION
105+
106+instance Json.ToJSON Union where
107+ toJSON (Union name comment args cases) =
108+ Json.object
109+ [ "name" .= name
110+ , "comment" .= comment
111+ , "args" .= args
112+ , "cases" .= cases
113+ ]
114+
115+instance Json.FromJSON Union where
116+ parseJSON (Json.Object obj) =
117+ Union
118+ <$> obj .: "name"
119+ <*> obj .: "comment"
120+ <*> obj .: "args"
121+ <*> obj .: "cases"
122+
123+ parseJSON value =
124+ fail $ "Cannot decode Union from: " ++ BS.unpack (Json.encode value)
125+
126+
127+-- JSON for VALUE
128+
129+instance Json.ToJSON Value where
130+ toJSON (Value name comment tipe assocPrec) =
131+ Json.object (fields ++ possibleFields)
132+ where
133+ fields =
134+ [ "name" .= name
135+ , "comment" .= comment
136+ , "type" .= tipe
137+ ]
138+
139+ possibleFields =
140+ case assocPrec of
141+ Nothing -> []
142+ Just (assoc, prec) ->
143+ [ "associativity" .= assoc
144+ , "precedence" .= prec
145+ ]
146+
147+
148+instance Json.FromJSON Value where
149+ parseJSON (Json.Object obj) =
150+ Value
151+ <$> obj .: "name"
152+ <*> obj .: "comment"
153+ <*> obj .: "type"
154+ <*> (liftM2 (,) <$> obj .:? "associativity" <*> obj .:? "precedence")
155+
156+ parseJSON value =
157+ fail $ "Cannot decode Value from: " ++ BS.unpack (Json.encode value)
158+
159+
160+-- JSON for TYPE
161+
162+instance Json.ToJSON Type where
163+ toJSON tipe =
164+ Json.object (getFields tipe)
165+ where
166+ getFields tipe =
167+ case tipe of
168+ Lambda t1 t2 ->
169+ [ "tag" .= ("lambda" :: Text.Text)
170+ , "in" .= Json.toJSON t1
171+ , "out" .= Json.toJSON t2
172+ ]
173+
174+ Var x ->
175+ [ "tag" .= ("var" :: Text.Text)
176+ , "name" .= Json.toJSON x
177+ ]
178+
179+ Type name ->
180+ [ "tag" .= ("type" :: Text.Text)
181+ , "name" .= Json.toJSON name
182+ ]
183+
184+ App t ts ->
185+ [ "tag" .= ("app" :: Text.Text)
186+ , "func" .= Json.toJSON t
187+ , "args" .= Json.toJSON ts
188+ ]
189+
190+ Record fields ext ->
191+ [ "tag" .= ("record" :: Text.Text)
192+ , "fields" .= Json.toJSON (map (Json.toJSON . second Json.toJSON) fields)
193+ , "extension" .= Json.toJSON ext
194+ ]
195+
196+instance Json.FromJSON Type where
197+ parseJSON (Json.Object obj) =
198+ do tag <- obj .: "tag"
199+ case (tag :: String) of
200+ "lambda" ->
201+ Lambda <$> obj .: "in" <*> obj .: "out"
202+
203+ "var" ->
204+ Var <$> obj .: "name"
205+
206+ "type" ->
207+ Type <$> obj .: "name"
208+
209+ "app" ->
210+ App <$> obj .: "func" <*> obj .: "arg"
211+
212+ "record" ->
213+ Record <$> obj .: "fields" <*> obj .: "extension"
214+
215+ _ ->
216+ fail $ "Error when decoding type with tag: " ++ tag
217+
218+
219+ parseJSON value =
220+ fail $ "Cannot decode Value from: " ++ BS.unpack (Json.encode value)