bundles/org.simantics.scl.data/scl/Data/Json.scl

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