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
 178 instance Json Float where
 179     writeJson = writeNumberFloat
 180     readJson = getFloatValue
 181     toJson = JsonDouble . toDouble
 182     fromJson (JsonDouble value) = fromDouble value
 183
 184 instance Json Integer where
 185     writeJson = writeNumberInteger
 186     readJson = getIntValue
 187     toJson = JsonLong . fromInteger
 188     fromJson (JsonLong value) = Java.l2i value
 189
 190 instance Json Long where
 191     writeJson = writeNumberLong
 192     readJson = getLongValue
 193     toJson = JsonLong
 194     fromJson (JsonLong value) = value
 195
 196 instance Json Short where
 197     writeJson = writeNumberShort
 198     readJson = getShortValue
 199     toJson = JsonLong . Java.i2l . Java.s2i
 200     fromJson (JsonLong value) = Java.i2s (Java.l2i value)
 201
 202 instance (Json a) => Json (Maybe a) where
 203     writeJson g (Just v) =  writeJson g v
 204     writeJson g Nothing = writeNull g
 205     readJson p =
 206         if currentToken p == VALUE_NULL
 207         then Nothing
 208         else Just (readJson p)
 209     toJson (Just value) = toJson value
 210     toJson Nothing = JsonNull
 211     fromJson JsonNull = Nothing
 212     fromJson json = Just (fromJson json)
 213
 214 instance (Json a) => Json [a] where
 215     writeJson g l = do
 216         writeStartArray g
 217         iter (writeJson g) l
 218         writeEndArray g
 219     readJson p = MList.freeze result
 220       where
 221         result = MList.create ()
 222         assertStartArray p
 223         while (nextToken p != END_ARRAY)
 224             (MList.add result $ readJson p)
 225     toJson l = JsonArray (map toJson l)
 226     fromJson (JsonArray l) = map fromJson l
 227
 228 instance Json () where
 229     writeJson g _ = do
 230         writeStartArray g
 231         writeEndArray g
 232     readJson p = do
 233         assertStartArray p
 234         assertEndArray p
 235         ()
 236     toJson _ = JsonArray []
 237     fromJson (JsonArray []) = ()
 238
 239 instance (Json a, Json b) => Json (a, b) where
 240     writeJson g (a, b) = do
 241         writeStartArray g
 242         writeJson g a
 243         writeJson g b
 244         writeEndArray g
 245     readJson p = (a, b)
 246       where
 247         assertStartArray p
 248         a = readNextJson p
 249         b = readNextJson p
 250         assertEndArray p
 251     toJson (a, b) = JsonArray [toJson a, toJson b]
 252     fromJson (JsonArray [a, b]) = (fromJson a, fromJson b)
 253
 254 instance (Json a, Json b, Json c) => Json (a, b, c) where
 255     writeJson g (a, b, c) = do
 256         writeStartArray g
 257         writeJson g a
 258         writeJson g b
 259         writeJson g c
 260         writeEndArray g
 261     readJson p = (a, b, c)
 262       where
 263         assertStartArray p
 264         a = readNextJson p
 265         b = readNextJson p
 266         c = readNextJson p
 267         assertEndArray p
 268     toJson (a, b, c) = JsonArray [toJson a, toJson b, toJson c]
 269     fromJson (JsonArray [a, b, c]) = (fromJson a, fromJson b, fromJson c)
 270
 271 instance (Json a, Json b, Json c, Json d) => Json (a, b, c, d) where
 272     writeJson g (a, b, c, d) = do
 273         writeStartArray g
 274         writeJson g a
 275         writeJson g b
 276         writeJson g c
 277         writeJson g d
 278         writeEndArray g
 279     readJson p = (a, b, c, d)
 280       where
 281         assertStartArray p
 282         a = readNextJson p
 283         b = readNextJson p
 284         c = readNextJson p
 285         d = readNextJson p
 286         assertEndArray p
 287     toJson (a, b, c, d) = JsonArray [toJson a, toJson b, toJson c, toJson d]
 288     fromJson (JsonArray [a, b, c, d]) = (fromJson a, fromJson b, fromJson c, fromJson d)
 289
 290 instance (Json a, Json b, Json c, Json d, Json e) => Json (a, b, c, d, e) where
 291     writeJson g (a, b, c, d, e) = do
 292         writeStartArray g
 293         writeJson g a
 294         writeJson g b
 295         writeJson g c
 296         writeJson g d
 297         writeJson g e
 298         writeEndArray g
 299     readJson p = (a, b, c, d, e)
 300       where
 301         assertStartArray p
 302         a = readNextJson p
 303         b = readNextJson p
 304         c = readNextJson p
 305         d = readNextJson p
 306         e = readNextJson p
 307         assertEndArray p
 308     toJson (a, b, c, d, e) = JsonArray [toJson a, toJson b, toJson c, toJson d, toJson e]
 309     fromJson (JsonArray [a, b, c, d, e]) = (fromJson a, fromJson b, fromJson c, fromJson d, fromJson e)
 310
 311 data Json =
 312     JsonString String
 313   | JsonDouble Double
 314   | JsonLong Long
 315   | JsonArray [Json]
 316   | JsonBoolean Boolean
 317   | JsonNull
 318   | JsonObject [JsonField]
 319 data JsonField = JsonField String Json
 320
 321 lookupJsonField :: String -> Json -> Maybe Json
 322 lookupJsonField fieldName (JsonObject fields) = mapFirst selector fields
 323   where
 324     selector (JsonField name value) | name == fieldName = Just value
 325     selector _ = Nothing
 326
 327 deriving instance Show Json
 328 deriving instance Show JsonField
 329
 330 instance Json Json where
 331     writeJson g (JsonString value) = writeString g value
 332     writeJson g (JsonDouble value) = writeNumberDouble g value
 333     writeJson g (JsonLong value) = writeNumberLong g value
 334     writeJson g (JsonBoolean value) = writeBoolean g value
 335     writeJson g JsonNull = writeNull g
 336     writeJson g (JsonArray values) = do
 337         writeStartArray g
 338         iter (writeJson g) values
 339         writeEndArray g
 340     writeJson g (JsonObject fields) = do
 341         writeStartObject g
 342         iter (\(JsonField name value) -> do
 343             writeFieldName g name
 344             writeJson g value) fields
 345         writeEndObject g
 346
 347     readJson p = do
 348         token = currentToken p
 349         if token == VALUE_STRING
 350         then JsonString (getText p)
 351         else if token == VALUE_NUMBER_FLOAT
 352         then JsonDouble (getDoubleValue p)
 353         else if token == VALUE_NUMBER_INT
 354         then JsonLong (getLongValue p)
 355         else if token == VALUE_TRUE
 356         then JsonBoolean True
 357         else if token == VALUE_FALSE
 358         then JsonBoolean False
 359         else if token == VALUE_NULL
 360         then JsonNull
 361         else if token == START_ARRAY
 362         then do
 363             result = MList.create ()
 364             while (nextToken p != END_ARRAY)
 365                 (MList.add result $ readJson p)
 366             JsonArray (MList.freeze result)
 367         else if token == START_OBJECT
 368         then do
 369             result = MList.create ()
 370             readJsonObjectContents result p
 371             JsonObject (MList.freeze result)
 372         else fail "Unsupported token type."
 373     toJson = id
 374     fromJson = id
 375
 376 @private
 377 readJsonObjectContents :: MList.T JsonField -> JsonParser -> <Proc> ()
 378 readJsonObjectContents result p =
 379     match nextFieldName p with
 380         Just name -> do
 381             MList.add result $ JsonField name (readNextJson p)
 382             readJsonObjectContents result p
 383         Nothing -> ()
 384
 385 /*
 386 @private
 387 makeTypeEqual :: a -> a -> ()
 388 makeTypeEqual _ _ = ()
 389
 390 @private
 391 testValue :: Json a => Show a => a -> <Proc> ()
 392 testValue v1 = do
 393     v2 = toJsonString v1
 394     v3 = fromJsonString v2
 395     makeTypeEqual v1 v3
 396     print "\(v1) -> \(v2) -> \(v3)"
 397     if v1 != v3
 398     then fail "Values differ"
 399     else ()
 400
 401 testGenericJson :: String -> <Proc> ()
 402 testGenericJson v1 = do
 403     v2 = fromJsonString v1 :: Json
 404     v3 = toJsonString v2
 405     print "\(v1) -> \(v2) -> \(v3)"
 406     if v1 != v3
 407     then fail "Values differ"
 408     else ()
 409
 410 testIt :: <Proc> ()
 411 testIt = do
 412     testValue "asd"
 413     testValue True
 414     testValue False
 415     testValue (123 :: Short)
 416     testValue (123 :: Integer)
 417     testValue (123 :: Long)
 418     testValue (123 :: Double)
 419     testValue (123 :: Float)
 420     testValue (Nothing :: Maybe String)
 421     testValue (Just "asd")
 422     testValue ["a", "b", "c"]
 423     testValue [[],["a"],["b","c"]]
 424     testValue ()
 425     testValue ("a", "b")
 426     testValue ("a", "b", "c")
 427     testValue ("a", "b", "c", "d")
 428     testValue [Just "a", Nothing]
 429     testValue [("a", "b"), ("c", "d")]
 430     testValue (("a", "b"), ("c", "d"))
 431
 432     testGenericJson "\"asd\""
 433     testGenericJson "123"
 434     testGenericJson "123.0"
 435     testGenericJson "true"
 436     testGenericJson "false"
 437     testGenericJson "null"
 438     testGenericJson "[1,2,3]"
 439     testGenericJson "[[1],[2,3],[]]"
 440     testGenericJson "{}"
 441     testGenericJson "{\"a\":123,\"b\":[]}"
 442     testGenericJson "{\"a\":{}}"
 443 */