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

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