]> gerrit.simantics Code Review - simantics/platform.git/blob - bundles/org.simantics.scl.data/scl/Data/Json.scl
Fix to OrderedSetTemplate, preference for autocompletion
[simantics/platform.git] / bundles / org.simantics.scl.data / scl / Data / Json.scl
1 import "StandardLibrary"
2 import "Data/Writer"
3 import "JavaBuiltin" as Java
4
5 importJava "com.fasterxml.jackson.core.JsonGenerator" where
6     data JsonGenerator
7
8 @private
9 importJava "com.fasterxml.jackson.core.JsonGenerator" where
10     writeNull :: JsonGenerator -> <Proc> ()
11     
12     writeStartArray :: JsonGenerator -> <Proc> ()
13     @JavaName writeStartArray
14     writeStartArrayN :: JsonGenerator -> Integer -> <Proc> ()
15     writeEndArray :: JsonGenerator -> <Proc> ()
16     
17     writeStartObject :: JsonGenerator -> <Proc> ()
18     writeFieldName :: JsonGenerator -> String -> <Proc> ()
19     writeEndObject :: JsonGenerator -> <Proc> ()
20
21     writeBoolean :: JsonGenerator -> Boolean -> <Proc> ()
22     
23     writeString :: JsonGenerator -> String -> <Proc> ()
24     
25     @JavaName writeNumber
26     writeNumberDouble :: JsonGenerator -> Double -> <Proc> ()
27     @JavaName writeNumber
28     writeNumberInteger :: JsonGenerator -> Integer -> <Proc> ()
29     @JavaName writeNumber
30     writeNumberLong :: JsonGenerator -> Long -> <Proc> ()
31     @JavaName writeNumber
32     writeNumberShort :: JsonGenerator -> Short -> <Proc> ()
33     @JavaName writeNumber
34     writeNumberFloat :: JsonGenerator -> Float -> <Proc> ()
35     
36     @JavaName close
37     closeGenerator :: JsonGenerator -> <Proc> ()
38
39 @private
40 importJava "com.fasterxml.jackson.core.JsonToken" where
41     data JsonToken
42     END_ARRAY :: JsonToken
43     END_OBJECT :: JsonToken
44     FIELD_NAME :: JsonToken
45     NOT_AVAILABLE :: JsonToken
46     START_ARRAY :: JsonToken
47     START_OBJECT :: JsonToken
48     VALUE_EMBEDDED_OBJECT :: JsonToken
49     VALUE_FALSE :: JsonToken
50     VALUE_NULL :: JsonToken
51     VALUE_NUMBER_FLOAT :: JsonToken
52     VALUE_NUMBER_INT :: JsonToken
53     VALUE_STRING :: JsonToken
54     VALUE_TRUE :: JsonToken
55
56 importJava "com.fasterxml.jackson.core.JsonParser" where
57     data JsonParser
58
59 @private
60 importJava "com.fasterxml.jackson.core.JsonParser" where
61     nextToken :: JsonParser -> <Proc> JsonToken
62     currentToken :: JsonParser -> <Proc> JsonToken
63     getDoubleValue :: JsonParser -> <Proc> Double
64     getIntValue :: JsonParser -> <Proc> Integer
65     getText :: JsonParser -> <Proc> String
66     getShortValue :: JsonParser -> <Proc> Short
67     getFloatValue :: JsonParser -> <Proc> Float
68     getLongValue :: JsonParser -> <Proc> Long
69     nextFieldName :: JsonParser -> <Proc> Maybe String
70
71 @private
72 importJava "com.fasterxml.jackson.core.JsonFactory" where
73     data JsonFactory
74     
75     @JavaName "<init>"
76     createJsonFactory :: <Proc> JsonFactory
77     
78     @JavaName createGenerator
79     createWriterGenerator :: JsonFactory -> Writer -> <Proc> JsonGenerator
80     
81     @JavaName createParser
82     createStringParser :: JsonFactory -> String -> <Proc> JsonParser
83     
84 @private
85 defaultFactory = createJsonFactory
86
87 @private
88 @inline
89 assertStartArray :: JsonParser -> <Proc> ()
90 assertStartArray p = if currentToken p == START_ARRAY
91                      then ()
92                      else fail "Expected START_ARRAY token."
93
94 @private
95 @inline
96 assertEndArray :: JsonParser -> <Proc> ()
97 assertEndArray p = if nextToken p == END_ARRAY
98                    then ()
99                    else fail "Expected END_ARRAY token."
100
101 // *** Json type class ********************************************************
102
103 class Json a where
104     writeJson :: JsonGenerator -> a -> <Proc> ()
105     readJson :: JsonParser -> <Proc> a
106     toJson :: a -> Json
107     fromJson :: Json -> a
108     
109     writeJson g v = writeJson g (toJson v)
110     readJson p = fromJson (readJson p) 
111
112 @private
113 readNextJson :: Json a => JsonParser -> <Proc> a
114 readNextJson p = do
115     nextToken p
116     readJson p
117
118 """
119 Converts the value to a string encoded with JSON
120 """
121 toJsonString :: Json a => a -> String
122 toJsonString v = runProc do
123     writer = createStringWriter
124     generator = createWriterGenerator defaultFactory (toWriter writer)
125     writeJson generator v
126     closeGenerator generator
127     resultOfStringWriter writer
128
129 """
130 Parses a JSON encoded string into a value
131 """
132 fromJsonString :: Json a => String -> a
133 fromJsonString str = runProc do
134     parser = createStringParser defaultFactory str
135     readNextJson parser
136
137 instance Json String where
138     writeJson = writeString
139     readJson = getText
140     toJson = JsonString
141     fromJson (JsonString value) = value
142
143 instance Json Boolean where
144     writeJson = writeBoolean
145     readJson p =
146         if currentToken p == VALUE_TRUE
147         then True
148         else False
149     toJson = JsonBoolean
150     fromJson (JsonBoolean value) = value
151     
152 instance Json Double where
153     writeJson = writeNumberDouble
154     readJson = getDoubleValue
155     toJson = JsonDouble
156     fromJson (JsonDouble value) = value
157
158 instance Json Float where
159     writeJson = writeNumberFloat
160     readJson = getFloatValue
161     toJson = JsonDouble . toDouble
162     fromJson (JsonDouble value) = fromDouble value
163
164 instance Json Integer where
165     writeJson = writeNumberInteger
166     readJson = getIntValue
167     toJson = JsonLong . fromInteger
168     fromJson (JsonLong value) = Java.l2i value
169
170 instance Json Long where
171     writeJson = writeNumberLong
172     readJson = getLongValue
173     toJson = JsonLong
174     fromJson (JsonLong value) = value
175
176 instance Json Short where
177     writeJson = writeNumberShort
178     readJson = getShortValue
179     toJson = JsonLong . Java.i2l . Java.s2i
180     fromJson (JsonLong value) = Java.i2s (Java.l2i value) 
181     
182 instance (Json a) => Json (Maybe a) where
183     writeJson g (Just v) =  writeJson g v
184     writeJson g Nothing = writeNull g
185     readJson p = 
186         if currentToken p == VALUE_NULL
187         then Nothing
188         else Just (readJson p)
189     toJson (Just value) = toJson value
190     toJson Nothing = JsonNull
191     fromJson JsonNull = Nothing
192     fromJson json = Just (fromJson json)
193
194 instance (Json a) => Json [a] where
195     writeJson g l = do
196         writeStartArray g
197         iter (writeJson g) l
198         writeEndArray g
199     readJson p = MList.freeze result
200       where
201         result = MList.create ()
202         assertStartArray p
203         while (nextToken p != END_ARRAY)
204             (MList.add result $ readJson p)
205     toJson l = JsonArray (map toJson l)
206     fromJson (JsonArray l) = map fromJson l
207
208 instance Json () where
209     writeJson g _ = do
210         writeStartArray g
211         writeEndArray g
212     readJson p = do
213         assertStartArray p
214         assertEndArray p
215         ()
216     toJson _ = JsonArray []
217     fromJson (JsonArray []) = ()
218
219 instance (Json a, Json b) => Json (a, b) where
220     writeJson g (a, b) = do
221         writeStartArray g
222         writeJson g a
223         writeJson g b
224         writeEndArray g
225     readJson p = (a, b)
226       where
227         assertStartArray p
228         a = readNextJson p
229         b = readNextJson p
230         assertEndArray p
231     toJson (a, b) = JsonArray [toJson a, toJson b]
232     fromJson (JsonArray [a, b]) = (fromJson a, fromJson b)        
233
234 instance (Json a, Json b, Json c) => Json (a, b, c) where
235     writeJson g (a, b, c) = do
236         writeStartArray g
237         writeJson g a
238         writeJson g b
239         writeJson g c
240         writeEndArray g
241     readJson p = (a, b, c)
242       where
243         assertStartArray p
244         a = readNextJson p
245         b = readNextJson p
246         c = readNextJson p
247         assertEndArray p
248     toJson (a, b, c) = JsonArray [toJson a, toJson b, toJson c]
249     fromJson (JsonArray [a, b, c]) = (fromJson a, fromJson b, fromJson c)        
250
251 instance (Json a, Json b, Json c, Json d) => Json (a, b, c, d) where
252     writeJson g (a, b, c, d) = do
253         writeStartArray g
254         writeJson g a
255         writeJson g b
256         writeJson g c
257         writeJson g d
258         writeEndArray g
259     readJson p = (a, b, c, d)
260       where
261         assertStartArray p
262         a = readNextJson p
263         b = readNextJson p
264         c = readNextJson p
265         d = readNextJson p
266         assertEndArray p
267     toJson (a, b, c, d) = JsonArray [toJson a, toJson b, toJson c, toJson d]
268     fromJson (JsonArray [a, b, c, d]) = (fromJson a, fromJson b, fromJson c, fromJson d)        
269
270 instance (Json a, Json b, Json c, Json d, Json e) => Json (a, b, c, d, e) where
271     writeJson g (a, b, c, d, e) = do
272         writeStartArray g
273         writeJson g a
274         writeJson g b
275         writeJson g c
276         writeJson g d
277         writeJson g e
278         writeEndArray g
279     readJson p = (a, b, c, d, e)
280       where
281         assertStartArray p
282         a = readNextJson p
283         b = readNextJson p
284         c = readNextJson p
285         d = readNextJson p
286         e = readNextJson p
287         assertEndArray p
288     toJson (a, b, c, d, e) = JsonArray [toJson a, toJson b, toJson c, toJson d, toJson e]
289     fromJson (JsonArray [a, b, c, d, e]) = (fromJson a, fromJson b, fromJson c, fromJson d, fromJson e)        
290
291 data Json =
292     JsonString String
293   | JsonDouble Double
294   | JsonLong Long
295   | JsonArray [Json]
296   | JsonBoolean Boolean
297   | JsonNull
298   | JsonObject [JsonField]
299 data JsonField = JsonField String Json
300   
301 deriving instance Show Json
302 deriving instance Show JsonField
303
304 instance Json Json where
305     writeJson g (JsonString value) = writeString g value
306     writeJson g (JsonDouble value) = writeNumberDouble g value
307     writeJson g (JsonLong value) = writeNumberLong g value
308     writeJson g (JsonBoolean value) = writeBoolean g value
309     writeJson g JsonNull = writeNull g
310     writeJson g (JsonArray values) = do
311         writeStartArray g
312         iter (writeJson g) values
313         writeEndArray g
314     writeJson g (JsonObject fields) = do
315         writeStartObject g
316         iter (\(JsonField name value) -> do
317             writeFieldName g name
318             writeJson g value) fields
319         writeEndObject g
320         
321     readJson p = do
322         token = currentToken p
323         if token == VALUE_STRING
324         then JsonString (getText p)
325         else if token == VALUE_NUMBER_FLOAT
326         then JsonDouble (getDoubleValue p)
327         else if token == VALUE_NUMBER_INT
328         then JsonLong (getLongValue p)
329         else if token == VALUE_TRUE
330         then JsonBoolean True
331         else if token == VALUE_FALSE
332         then JsonBoolean False
333         else if token == VALUE_NULL
334         then JsonNull
335         else if token == START_ARRAY
336         then do
337             result = MList.create ()
338             while (nextToken p != END_ARRAY)
339                 (MList.add result $ readJson p)
340             JsonArray (MList.freeze result)
341         else if token == START_OBJECT
342         then do
343             result = MList.create ()
344             readJsonObjectContents result p
345             JsonObject (MList.freeze result)
346         else fail "Unsupported token type." 
347     toJson = id
348     fromJson = id
349
350 @private
351 readJsonObjectContents :: MList.T JsonField -> JsonParser -> <Proc> ()
352 readJsonObjectContents result p =
353     match nextFieldName p with
354         Just name -> do
355             MList.add result $ JsonField name (readNextJson p)
356             readJsonObjectContents result p
357         Nothing -> ()
358
359 /*
360 @private
361 makeTypeEqual :: a -> a -> ()
362 makeTypeEqual _ _ = ()
363
364 @private
365 testValue :: Json a => Show a => a -> <Proc> ()
366 testValue v1 = do
367     v2 = toJsonString v1
368     v3 = fromJsonString v2
369     makeTypeEqual v1 v3
370     print "\(v1) -> \(v2) -> \(v3)"
371     if v1 != v3
372     then fail "Values differ"
373     else ()
374
375 testGenericJson :: String -> <Proc> ()
376 testGenericJson v1 = do
377     v2 = fromJsonString v1 :: Json
378     v3 = toJsonString v2
379     print "\(v1) -> \(v2) -> \(v3)"
380     if v1 != v3
381     then fail "Values differ"
382     else ()
383
384 testIt :: <Proc> ()
385 testIt = do
386     testValue "asd"
387     testValue True
388     testValue False
389     testValue (123 :: Short)
390     testValue (123 :: Integer)    
391     testValue (123 :: Long)
392     testValue (123 :: Double)
393     testValue (123 :: Float)
394     testValue (Nothing :: Maybe String)
395     testValue (Just "asd") 
396     testValue ["a", "b", "c"] 
397     testValue [[],["a"],["b","c"]]
398     testValue ()
399     testValue ("a", "b")
400     testValue ("a", "b", "c")
401     testValue ("a", "b", "c", "d")
402     testValue [Just "a", Nothing]
403     testValue [("a", "b"), ("c", "d")]
404     testValue (("a", "b"), ("c", "d"))
405      
406     testGenericJson "\"asd\""
407     testGenericJson "123"
408     testGenericJson "123.0"
409     testGenericJson "true"
410     testGenericJson "false"
411     testGenericJson "null"
412     testGenericJson "[1,2,3]"
413     testGenericJson "[[1],[2,3],[]]"
414     testGenericJson "{}"
415     testGenericJson "{\"a\":123,\"b\":[]}"
416     testGenericJson "{\"a\":{}}"
417 */