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

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