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 */