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 data Json =
 313     JsonString String
 314   | JsonDouble Double
 315   | JsonLong Long
 316   | JsonArray [Json]
 317   | JsonBoolean Boolean
 318   | JsonNull
 319   | JsonObject [JsonField]
 320 data JsonField = JsonField String Json
 321
 322 lookupJsonField :: String -> Json -> Maybe Json
 323 lookupJsonField fieldName (JsonObject fields) = mapFirst selector fields
 324   where
 325     selector (JsonField name value) | name == fieldName = Just value
 326     selector _ = Nothing
 327
 328 deriving instance Show Json
 329 deriving instance Show JsonField
 330
 331 instance Json Json where
 332     writeJson g (JsonString value) = writeString g value
 333     writeJson g (JsonDouble value) = writeNumberDouble g value
 334     writeJson g (JsonLong value) = writeNumberLong g value
 335     writeJson g (JsonBoolean value) = writeBoolean g value
 336     writeJson g JsonNull = writeNull g
 337     writeJson g (JsonArray values) = do
 338         writeStartArray g
 339         iter (writeJson g) values
 340         writeEndArray g
 341     writeJson g (JsonObject fields) = do
 342         writeStartObject g
 343         iter (\(JsonField name value) -> do
 344             writeFieldName g name
 345             writeJson g value) fields
 346         writeEndObject g
 347
 348     readJson p = do
 349         token = currentToken p
 350         if token == VALUE_STRING
 351         then JsonString (getText p)
 352         else if token == VALUE_NUMBER_FLOAT
 353         then JsonDouble (getDoubleValue p)
 354         else if token == VALUE_NUMBER_INT
 355         then JsonLong (getLongValue p)
 356         else if token == VALUE_TRUE
 357         then JsonBoolean True
 358         else if token == VALUE_FALSE
 359         then JsonBoolean False
 360         else if token == VALUE_NULL
 361         then JsonNull
 362         else if token == START_ARRAY
 363         then do
 364             result = MList.create ()
 365             while (nextToken p != END_ARRAY)
 366                 (MList.add result $ readJson p)
 367             JsonArray (MList.freeze result)
 368         else if token == START_OBJECT
 369         then do
 370             result = MList.create ()
 371             readJsonObjectContents result p
 372             JsonObject (MList.freeze result)
 373         else fail "Unsupported token type."
 374     toJson = id
 375     fromJson = id
 376
 377 @private
 378 readJsonObjectContents :: MList.T JsonField -> JsonParser -> <Proc> ()
 379 readJsonObjectContents result p =
 380     match nextFieldName p with
 381         Just name -> do
 382             MList.add result $ JsonField name (readNextJson p)
 383             readJsonObjectContents result p
 384         Nothing -> ()
 385
 386 /*
 387 @private
 388 makeTypeEqual :: a -> a -> ()
 389 makeTypeEqual _ _ = ()
 390
 391 @private
 392 testValue :: Json a => Show a => a -> <Proc> ()
 393 testValue v1 = do
 394     v2 = toJsonString v1
 395     v3 = fromJsonString v2
 396     makeTypeEqual v1 v3
 397     print "\(v1) -> \(v2) -> \(v3)"
 398     if v1 != v3
 399     then fail "Values differ"
 400     else ()
 401
 402 testGenericJson :: String -> <Proc> ()
 403 testGenericJson v1 = do
 404     v2 = fromJsonString v1 :: Json
 405     v3 = toJsonString v2
 406     print "\(v1) -> \(v2) -> \(v3)"
 407     if v1 != v3
 408     then fail "Values differ"
 409     else ()
 410
 411 testIt :: <Proc> ()
 412 testIt = do
 413     testValue "asd"
 414     testValue True
 415     testValue False
 416     testValue (123 :: Short)
 417     testValue (123 :: Integer)
 418     testValue (123 :: Long)
 419     testValue (123 :: Double)
 420     testValue (123 :: Float)
 421     testValue (Nothing :: Maybe String)
 422     testValue (Just "asd")
 423     testValue ["a", "b", "c"]
 424     testValue [[],["a"],["b","c"]]
 425     testValue ()
 426     testValue ("a", "b")
 427     testValue ("a", "b", "c")
 428     testValue ("a", "b", "c", "d")
 429     testValue [Just "a", Nothing]
 430     testValue [("a", "b"), ("c", "d")]
 431     testValue (("a", "b"), ("c", "d"))
 432
 433     testGenericJson "\"asd\""
 434     testGenericJson "123"
 435     testGenericJson "123.0"
 436     testGenericJson "true"
 437     testGenericJson "false"
 438     testGenericJson "null"
 439     testGenericJson "[1,2,3]"
 440     testGenericJson "[[1],[2,3],[]]"
 441     testGenericJson "{}"
 442     testGenericJson "{\"a\":123,\"b\":[]}"
 443     testGenericJson "{\"a\":{}}"
 444 */