-import "StandardLibrary"\r
-import "Data/Writer"\r
-import "JavaBuiltin" as Java\r
-\r
-importJava "com.fasterxml.jackson.core.JsonGenerator" where\r
- data JsonGenerator\r
-\r
-@private\r
-importJava "com.fasterxml.jackson.core.JsonGenerator" where\r
- writeNull :: JsonGenerator -> <Proc> ()\r
- \r
- writeStartArray :: JsonGenerator -> <Proc> ()\r
- @JavaName writeStartArray\r
- writeStartArrayN :: JsonGenerator -> Integer -> <Proc> ()\r
- writeEndArray :: JsonGenerator -> <Proc> ()\r
- \r
- writeStartObject :: JsonGenerator -> <Proc> ()\r
- writeFieldName :: JsonGenerator -> String -> <Proc> ()\r
- writeEndObject :: JsonGenerator -> <Proc> ()\r
-\r
- writeBoolean :: JsonGenerator -> Boolean -> <Proc> ()\r
- \r
- writeString :: JsonGenerator -> String -> <Proc> ()\r
- \r
- @JavaName writeNumber\r
- writeNumberDouble :: JsonGenerator -> Double -> <Proc> ()\r
- @JavaName writeNumber\r
- writeNumberInteger :: JsonGenerator -> Integer -> <Proc> ()\r
- @JavaName writeNumber\r
- writeNumberLong :: JsonGenerator -> Long -> <Proc> ()\r
- @JavaName writeNumber\r
- writeNumberShort :: JsonGenerator -> Short -> <Proc> ()\r
- @JavaName writeNumber\r
- writeNumberFloat :: JsonGenerator -> Float -> <Proc> ()\r
- \r
- @JavaName close\r
- closeGenerator :: JsonGenerator -> <Proc> ()\r
-\r
-@private\r
-importJava "com.fasterxml.jackson.core.JsonToken" where\r
- data JsonToken\r
- END_ARRAY :: JsonToken\r
- END_OBJECT :: JsonToken\r
- FIELD_NAME :: JsonToken\r
- NOT_AVAILABLE :: JsonToken\r
- START_ARRAY :: JsonToken\r
- START_OBJECT :: JsonToken\r
- VALUE_EMBEDDED_OBJECT :: JsonToken\r
- VALUE_FALSE :: JsonToken\r
- VALUE_NULL :: JsonToken\r
- VALUE_NUMBER_FLOAT :: JsonToken\r
- VALUE_NUMBER_INT :: JsonToken\r
- VALUE_STRING :: JsonToken\r
- VALUE_TRUE :: JsonToken\r
-instance Eq JsonToken where\r
- (==) = Java.equals\r
-\r
-importJava "com.fasterxml.jackson.core.JsonParser" where\r
- data JsonParser\r
-\r
-@private\r
-importJava "com.fasterxml.jackson.core.JsonParser" where\r
- nextToken :: JsonParser -> <Proc> JsonToken\r
- currentToken :: JsonParser -> <Proc> JsonToken\r
- getDoubleValue :: JsonParser -> <Proc> Double\r
- getIntValue :: JsonParser -> <Proc> Integer\r
- getText :: JsonParser -> <Proc> String\r
- getShortValue :: JsonParser -> <Proc> Short\r
- getFloatValue :: JsonParser -> <Proc> Float\r
- getLongValue :: JsonParser -> <Proc> Long\r
- nextFieldName :: JsonParser -> <Proc> Maybe String\r
-\r
-@private\r
-importJava "com.fasterxml.jackson.core.JsonFactory" where\r
- data JsonFactory\r
- \r
- @JavaName "<init>"\r
- createJsonFactory :: <Proc> JsonFactory\r
- \r
- @JavaName createGenerator\r
- createWriterGenerator :: JsonFactory -> Writer -> <Proc> JsonGenerator\r
- \r
- @JavaName createParser\r
- createStringParser :: JsonFactory -> String -> <Proc> JsonParser\r
- \r
-@private\r
-defaultFactory = createJsonFactory\r
-\r
-@private\r
-@inline\r
-assertStartArray :: JsonParser -> <Proc> ()\r
-assertStartArray p = if currentToken p == START_ARRAY\r
- then ()\r
- else fail "Expected START_ARRAY token."\r
-\r
-@private\r
-@inline\r
-assertEndArray :: JsonParser -> <Proc> ()\r
-assertEndArray p = if nextToken p == END_ARRAY\r
- then ()\r
- else fail "Expected END_ARRAY token."\r
-\r
-// *** Json type class ********************************************************\r
-\r
-class Json a where\r
- writeJson :: JsonGenerator -> a -> <Proc> ()\r
- readJson :: JsonParser -> <Proc> a\r
- toJson :: a -> Json\r
- fromJson :: Json -> a\r
- \r
- writeJson g v = writeJson g (toJson v)\r
- readJson p = fromJson (readJson p) \r
-\r
-@private\r
-readNextJson :: Json a => JsonParser -> <Proc> a\r
-readNextJson p = do\r
- nextToken p\r
- readJson p\r
-\r
-"""\r
-Converts the value to a string encoded with JSON\r
-"""\r
-toJsonString :: Json a => a -> String\r
-toJsonString v = runProc do\r
- writer = createStringWriter\r
- generator = createWriterGenerator defaultFactory (toWriter writer)\r
- writeJson generator v\r
- closeGenerator generator\r
- resultOfStringWriter writer\r
-\r
-"""\r
-Parses a JSON encoded string into a value\r
-"""\r
-fromJsonString :: Json a => String -> a\r
-fromJsonString str = runProc do\r
- parser = createStringParser defaultFactory str\r
- readNextJson parser\r
-\r
-instance Json String where\r
- writeJson = writeString\r
- readJson = getText\r
- toJson = JsonString\r
- fromJson (JsonString value) = value\r
-\r
-instance Json Boolean where\r
- writeJson = writeBoolean\r
- readJson p =\r
- if currentToken p == VALUE_TRUE\r
- then True\r
- else False\r
- toJson = JsonBoolean\r
- fromJson (JsonBoolean value) = value\r
- \r
-instance Json Double where\r
- writeJson = writeNumberDouble\r
- readJson = getDoubleValue\r
- toJson = JsonDouble\r
- fromJson (JsonDouble value) = value\r
-\r
-instance Json Float where\r
- writeJson = writeNumberFloat\r
- readJson = getFloatValue\r
- toJson = JsonDouble . toDouble\r
- fromJson (JsonDouble value) = fromDouble value\r
-\r
-instance Json Integer where\r
- writeJson = writeNumberInteger\r
- readJson = getIntValue\r
- toJson = JsonLong . fromInteger\r
- fromJson (JsonLong value) = Java.l2i value\r
-\r
-instance Json Long where\r
- writeJson = writeNumberLong\r
- readJson = getLongValue\r
- toJson = JsonLong\r
- fromJson (JsonLong value) = value\r
-\r
-instance Json Short where\r
- writeJson = writeNumberShort\r
- readJson = getShortValue\r
- toJson = JsonLong . Java.i2l . Java.s2i\r
- fromJson (JsonLong value) = Java.i2s (Java.l2i value) \r
- \r
-instance (Json a) => Json (Maybe a) where\r
- writeJson g (Just v) = writeJson g v\r
- writeJson g Nothing = writeNull g\r
- readJson p = \r
- if currentToken p == VALUE_NULL\r
- then Nothing\r
- else Just (readJson p)\r
- toJson (Just value) = toJson value\r
- toJson Nothing = JsonNull\r
- fromJson JsonNull = Nothing\r
- fromJson json = Just (fromJson json)\r
-\r
-instance (Json a) => Json [a] where\r
- writeJson g l = do\r
- writeStartArray g\r
- iter (writeJson g) l\r
- writeEndArray g\r
- readJson p = MList.freeze result\r
- where\r
- result = MList.create ()\r
- assertStartArray p\r
- while (nextToken p != END_ARRAY)\r
- (MList.add result $ readJson p)\r
- toJson l = JsonArray (map toJson l)\r
- fromJson (JsonArray l) = map fromJson l\r
-\r
-instance Json () where\r
- writeJson g _ = do\r
- writeStartArray g\r
- writeEndArray g\r
- readJson p = do\r
- assertStartArray p\r
- assertEndArray p\r
- ()\r
- toJson _ = JsonArray []\r
- fromJson (JsonArray []) = ()\r
-\r
-instance (Json a, Json b) => Json (a, b) where\r
- writeJson g (a, b) = do\r
- writeStartArray g\r
- writeJson g a\r
- writeJson g b\r
- writeEndArray g\r
- readJson p = (a, b)\r
- where\r
- assertStartArray p\r
- a = readNextJson p\r
- b = readNextJson p\r
- assertEndArray p\r
- toJson (a, b) = JsonArray [toJson a, toJson b]\r
- fromJson (JsonArray [a, b]) = (fromJson a, fromJson b) \r
-\r
-instance (Json a, Json b, Json c) => Json (a, b, c) where\r
- writeJson g (a, b, c) = do\r
- writeStartArray g\r
- writeJson g a\r
- writeJson g b\r
- writeJson g c\r
- writeEndArray g\r
- readJson p = (a, b, c)\r
- where\r
- assertStartArray p\r
- a = readNextJson p\r
- b = readNextJson p\r
- c = readNextJson p\r
- assertEndArray p\r
- toJson (a, b, c) = JsonArray [toJson a, toJson b, toJson c]\r
- fromJson (JsonArray [a, b, c]) = (fromJson a, fromJson b, fromJson c) \r
-\r
-instance (Json a, Json b, Json c, Json d) => Json (a, b, c, d) where\r
- writeJson g (a, b, c, d) = do\r
- writeStartArray g\r
- writeJson g a\r
- writeJson g b\r
- writeJson g c\r
- writeJson g d\r
- writeEndArray g\r
- readJson p = (a, b, c, d)\r
- where\r
- assertStartArray p\r
- a = readNextJson p\r
- b = readNextJson p\r
- c = readNextJson p\r
- d = readNextJson p\r
- assertEndArray p\r
- toJson (a, b, c, d) = JsonArray [toJson a, toJson b, toJson c, toJson d]\r
- fromJson (JsonArray [a, b, c, d]) = (fromJson a, fromJson b, fromJson c, fromJson d) \r
-\r
-instance (Json a, Json b, Json c, Json d, Json e) => Json (a, b, c, d, e) where\r
- writeJson g (a, b, c, d, e) = do\r
- writeStartArray g\r
- writeJson g a\r
- writeJson g b\r
- writeJson g c\r
- writeJson g d\r
- writeJson g e\r
- writeEndArray g\r
- readJson p = (a, b, c, d, e)\r
- where\r
- assertStartArray p\r
- a = readNextJson p\r
- b = readNextJson p\r
- c = readNextJson p\r
- d = readNextJson p\r
- e = readNextJson p\r
- assertEndArray p\r
- toJson (a, b, c, d, e) = JsonArray [toJson a, toJson b, toJson c, toJson d, toJson e]\r
- fromJson (JsonArray [a, b, c, d, e]) = (fromJson a, fromJson b, fromJson c, fromJson d, fromJson e) \r
-\r
-data Json =\r
- JsonString String\r
- | JsonDouble Double\r
- | JsonLong Long\r
- | JsonArray [Json]\r
- | JsonBoolean Boolean\r
- | JsonNull\r
- | JsonObject [JsonField]\r
-data JsonField = JsonField String Json\r
- \r
-deriving instance Show Json\r
-deriving instance Eq Json\r
-deriving instance Show JsonField\r
-deriving instance Eq JsonField\r
-\r
-instance Json Json where\r
- writeJson g (JsonString value) = writeString g value\r
- writeJson g (JsonDouble value) = writeNumberDouble g value\r
- writeJson g (JsonLong value) = writeNumberLong g value\r
- writeJson g (JsonBoolean value) = writeBoolean g value\r
- writeJson g JsonNull = writeNull g\r
- writeJson g (JsonArray values) = do\r
- writeStartArray g\r
- iter (writeJson g) values\r
- writeEndArray g\r
- writeJson g (JsonObject fields) = do\r
- writeStartObject g\r
- iter (\(JsonField name value) -> do\r
- writeFieldName g name\r
- writeJson g value) fields\r
- writeEndObject g\r
- \r
- readJson p = do\r
- token = currentToken p\r
- if token == VALUE_STRING\r
- then JsonString (getText p)\r
- else if token == VALUE_NUMBER_FLOAT\r
- then JsonDouble (getDoubleValue p)\r
- else if token == VALUE_NUMBER_INT\r
- then JsonLong (getLongValue p)\r
- else if token == VALUE_TRUE\r
- then JsonBoolean True\r
- else if token == VALUE_FALSE\r
- then JsonBoolean False\r
- else if token == VALUE_NULL\r
- then JsonNull\r
- else if token == START_ARRAY\r
- then do\r
- result = MList.create ()\r
- while (nextToken p != END_ARRAY)\r
- (MList.add result $ readJson p)\r
- JsonArray (MList.freeze result)\r
- else if token == START_OBJECT\r
- then do\r
- result = MList.create ()\r
- readJsonObjectContents result p\r
- JsonObject (MList.freeze result)\r
- else fail "Unsupported token type." \r
- toJson = id\r
- fromJson = id\r
-\r
-@private\r
-readJsonObjectContents :: MList.T JsonField -> JsonParser -> <Proc> ()\r
-readJsonObjectContents result p =\r
- match nextFieldName p with\r
- Just name -> do\r
- MList.add result $ JsonField name (readNextJson p)\r
- readJsonObjectContents result p\r
- Nothing -> ()\r
-\r
-/*\r
-@private\r
-makeTypeEqual :: a -> a -> ()\r
-makeTypeEqual _ _ = ()\r
-\r
-@private\r
-testValue :: Json a => Show a => Eq a => a -> <Proc> ()\r
-testValue v1 = do\r
- v2 = toJsonString v1\r
- v3 = fromJsonString v2\r
- makeTypeEqual v1 v3\r
- print "\(v1) -> \(v2) -> \(v3)"\r
- if v1 != v3\r
- then fail "Values differ"\r
- else ()\r
-\r
-testGenericJson :: String -> <Proc> ()\r
-testGenericJson v1 = do\r
- v2 = fromJsonString v1 :: Json\r
- v3 = toJsonString v2\r
- print "\(v1) -> \(v2) -> \(v3)"\r
- if v1 != v3\r
- then fail "Values differ"\r
- else ()\r
-\r
-testIt :: <Proc> ()\r
-testIt = do\r
- testValue "asd"\r
- testValue True\r
- testValue False\r
- testValue (123 :: Short)\r
- testValue (123 :: Integer) \r
- testValue (123 :: Long)\r
- testValue (123 :: Double)\r
- testValue (123 :: Float)\r
- testValue (Nothing :: Maybe String)\r
- testValue (Just "asd") \r
- testValue ["a", "b", "c"] \r
- testValue [[],["a"],["b","c"]]\r
- testValue ()\r
- testValue ("a", "b")\r
- testValue ("a", "b", "c")\r
- testValue ("a", "b", "c", "d")\r
- testValue [Just "a", Nothing]\r
- testValue [("a", "b"), ("c", "d")]\r
- testValue (("a", "b"), ("c", "d"))\r
- \r
- testGenericJson "\"asd\""\r
- testGenericJson "123"\r
- testGenericJson "123.0"\r
- testGenericJson "true"\r
- testGenericJson "false"\r
- testGenericJson "null"\r
- testGenericJson "[1,2,3]"\r
- testGenericJson "[[1],[2,3],[]]"\r
- testGenericJson "{}"\r
- testGenericJson "{\"a\":123,\"b\":[]}"\r
- testGenericJson "{\"a\":{}}"\r
+/*
+
+An example how to implement
+
+data GeographicalLocation = GeographicalLocation {
+ latitude :: Double,
+ longitude :: Double
+}
+
+instance Json GeographicalLocation where
+ toJson GeographicalLocation { latitude, longitude } = JsonObject [
+ JsonField "latitude" (toJson latitude),
+ JsonField "longitude" (toJson longitude)
+ ]
+ fromJson object = GeographicalLocation {
+ latitude = fromJson $ fromJust $ lookupJsonField "latitude" object,
+ longitude = fromJson $ fromJust $ lookupJsonField "longitude" object
+ }
+*/
+
+import "StandardLibrary"
+import "Data/Writer"
+import "JavaBuiltin" as Java
+
+importJava "com.fasterxml.jackson.core.JsonGenerator" where
+ data JsonGenerator
+
+@private
+importJava "com.fasterxml.jackson.core.JsonGenerator" where
+ writeNull :: JsonGenerator -> <Proc> ()
+
+ writeStartArray :: JsonGenerator -> <Proc> ()
+ @JavaName writeStartArray
+ writeStartArrayN :: JsonGenerator -> Integer -> <Proc> ()
+ writeEndArray :: JsonGenerator -> <Proc> ()
+
+ writeStartObject :: JsonGenerator -> <Proc> ()
+ writeFieldName :: JsonGenerator -> String -> <Proc> ()
+ writeEndObject :: JsonGenerator -> <Proc> ()
+
+ writeBoolean :: JsonGenerator -> Boolean -> <Proc> ()
+
+ writeString :: JsonGenerator -> String -> <Proc> ()
+
+ @JavaName writeNumber
+ writeNumberDouble :: JsonGenerator -> Double -> <Proc> ()
+ @JavaName writeNumber
+ writeNumberInteger :: JsonGenerator -> Integer -> <Proc> ()
+ @JavaName writeNumber
+ writeNumberLong :: JsonGenerator -> Long -> <Proc> ()
+ @JavaName writeNumber
+ writeNumberShort :: JsonGenerator -> Short -> <Proc> ()
+ @JavaName writeNumber
+ writeNumberFloat :: JsonGenerator -> Float -> <Proc> ()
+
+ @JavaName close
+ closeGenerator :: JsonGenerator -> <Proc> ()
+
+@private
+importJava "com.fasterxml.jackson.core.JsonToken" where
+ data JsonToken
+ END_ARRAY :: JsonToken
+ END_OBJECT :: JsonToken
+ FIELD_NAME :: JsonToken
+ NOT_AVAILABLE :: JsonToken
+ START_ARRAY :: JsonToken
+ START_OBJECT :: JsonToken
+ VALUE_EMBEDDED_OBJECT :: JsonToken
+ VALUE_FALSE :: JsonToken
+ VALUE_NULL :: JsonToken
+ VALUE_NUMBER_FLOAT :: JsonToken
+ VALUE_NUMBER_INT :: JsonToken
+ VALUE_STRING :: JsonToken
+ VALUE_TRUE :: JsonToken
+
+importJava "com.fasterxml.jackson.core.JsonParser" where
+ data JsonParser
+
+@private
+importJava "com.fasterxml.jackson.core.JsonParser" where
+ nextToken :: JsonParser -> <Proc> JsonToken
+ currentToken :: JsonParser -> <Proc> JsonToken
+ getDoubleValue :: JsonParser -> <Proc> Double
+ getIntValue :: JsonParser -> <Proc> Integer
+ getText :: JsonParser -> <Proc> String
+ getShortValue :: JsonParser -> <Proc> Short
+ getFloatValue :: JsonParser -> <Proc> Float
+ getLongValue :: JsonParser -> <Proc> Long
+ nextFieldName :: JsonParser -> <Proc> Maybe String
+
+@private
+importJava "com.fasterxml.jackson.core.JsonFactory" where
+ data JsonFactory
+
+ @JavaName "<init>"
+ createJsonFactory :: <Proc> JsonFactory
+
+ @JavaName createGenerator
+ createWriterGenerator :: JsonFactory -> Writer -> <Proc> JsonGenerator
+
+ @JavaName createParser
+ createStringParser :: JsonFactory -> String -> <Proc> JsonParser
+
+@private
+defaultFactory = createJsonFactory
+
+@private
+@inline
+assertStartArray :: JsonParser -> <Proc> ()
+assertStartArray p = if currentToken p == START_ARRAY
+ then ()
+ else fail "Expected START_ARRAY token."
+
+@private
+@inline
+assertEndArray :: JsonParser -> <Proc> ()
+assertEndArray p = if nextToken p == END_ARRAY
+ then ()
+ else fail "Expected END_ARRAY token."
+
+// *** Json type class ********************************************************
+
+class Json a where
+ writeJson :: JsonGenerator -> a -> <Proc> ()
+ readJson :: JsonParser -> <Proc> a
+ toJson :: a -> Json
+ fromJson :: Json -> a
+
+ writeJson g v = writeJson g (toJson v)
+ readJson p = fromJson (readJson p)
+
+@private
+readNextJson :: Json a => JsonParser -> <Proc> a
+readNextJson p = do
+ nextToken p
+ readJson p
+
+"""
+Converts the value to a string encoded with JSON
+"""
+toJsonString :: Json a => a -> String
+toJsonString v = runProc do
+ writer = createStringWriter
+ generator = createWriterGenerator defaultFactory (toWriter writer)
+ writeJson generator v
+ closeGenerator generator
+ resultOfStringWriter writer
+
+"""
+Parses a JSON encoded string into a value
+"""
+fromJsonString :: Json a => String -> a
+fromJsonString str = runProc do
+ parser = createStringParser defaultFactory str
+ readNextJson parser
+
+instance Json String where
+ writeJson = writeString
+ readJson = getText
+ toJson = JsonString
+ fromJson (JsonString value) = value
+
+instance Json Boolean where
+ writeJson = writeBoolean
+ readJson p =
+ if currentToken p == VALUE_TRUE
+ then True
+ else False
+ toJson = JsonBoolean
+ fromJson (JsonBoolean value) = value
+
+instance Json Double where
+ writeJson = writeNumberDouble
+ readJson = getDoubleValue
+ toJson = JsonDouble
+ fromJson (JsonDouble value) = value
+
+instance Json Float where
+ writeJson = writeNumberFloat
+ readJson = getFloatValue
+ toJson = JsonDouble . toDouble
+ fromJson (JsonDouble value) = fromDouble value
+
+instance Json Integer where
+ writeJson = writeNumberInteger
+ readJson = getIntValue
+ toJson = JsonLong . fromInteger
+ fromJson (JsonLong value) = Java.l2i value
+
+instance Json Long where
+ writeJson = writeNumberLong
+ readJson = getLongValue
+ toJson = JsonLong
+ fromJson (JsonLong value) = value
+
+instance Json Short where
+ writeJson = writeNumberShort
+ readJson = getShortValue
+ toJson = JsonLong . Java.i2l . Java.s2i
+ fromJson (JsonLong value) = Java.i2s (Java.l2i value)
+
+instance (Json a) => Json (Maybe a) where
+ writeJson g (Just v) = writeJson g v
+ writeJson g Nothing = writeNull g
+ readJson p =
+ if currentToken p == VALUE_NULL
+ then Nothing
+ else Just (readJson p)
+ toJson (Just value) = toJson value
+ toJson Nothing = JsonNull
+ fromJson JsonNull = Nothing
+ fromJson json = Just (fromJson json)
+
+instance (Json a) => Json [a] where
+ writeJson g l = do
+ writeStartArray g
+ iter (writeJson g) l
+ writeEndArray g
+ readJson p = MList.freeze result
+ where
+ result = MList.create ()
+ assertStartArray p
+ while (nextToken p != END_ARRAY)
+ (MList.add result $ readJson p)
+ toJson l = JsonArray (map toJson l)
+ fromJson (JsonArray l) = map fromJson l
+
+instance Json () where
+ writeJson g _ = do
+ writeStartArray g
+ writeEndArray g
+ readJson p = do
+ assertStartArray p
+ assertEndArray p
+ ()
+ toJson _ = JsonArray []
+ fromJson (JsonArray []) = ()
+
+instance (Json a, Json b) => Json (a, b) where
+ writeJson g (a, b) = do
+ writeStartArray g
+ writeJson g a
+ writeJson g b
+ writeEndArray g
+ readJson p = (a, b)
+ where
+ assertStartArray p
+ a = readNextJson p
+ b = readNextJson p
+ assertEndArray p
+ toJson (a, b) = JsonArray [toJson a, toJson b]
+ fromJson (JsonArray [a, b]) = (fromJson a, fromJson b)
+
+instance (Json a, Json b, Json c) => Json (a, b, c) where
+ writeJson g (a, b, c) = do
+ writeStartArray g
+ writeJson g a
+ writeJson g b
+ writeJson g c
+ writeEndArray g
+ readJson p = (a, b, c)
+ where
+ assertStartArray p
+ a = readNextJson p
+ b = readNextJson p
+ c = readNextJson p
+ assertEndArray p
+ toJson (a, b, c) = JsonArray [toJson a, toJson b, toJson c]
+ fromJson (JsonArray [a, b, c]) = (fromJson a, fromJson b, fromJson c)
+
+instance (Json a, Json b, Json c, Json d) => Json (a, b, c, d) where
+ writeJson g (a, b, c, d) = do
+ writeStartArray g
+ writeJson g a
+ writeJson g b
+ writeJson g c
+ writeJson g d
+ writeEndArray g
+ readJson p = (a, b, c, d)
+ where
+ assertStartArray p
+ a = readNextJson p
+ b = readNextJson p
+ c = readNextJson p
+ d = readNextJson p
+ assertEndArray p
+ toJson (a, b, c, d) = JsonArray [toJson a, toJson b, toJson c, toJson d]
+ fromJson (JsonArray [a, b, c, d]) = (fromJson a, fromJson b, fromJson c, fromJson d)
+
+instance (Json a, Json b, Json c, Json d, Json e) => Json (a, b, c, d, e) where
+ writeJson g (a, b, c, d, e) = do
+ writeStartArray g
+ writeJson g a
+ writeJson g b
+ writeJson g c
+ writeJson g d
+ writeJson g e
+ writeEndArray g
+ readJson p = (a, b, c, d, e)
+ where
+ assertStartArray p
+ a = readNextJson p
+ b = readNextJson p
+ c = readNextJson p
+ d = readNextJson p
+ e = readNextJson p
+ assertEndArray p
+ toJson (a, b, c, d, e) = JsonArray [toJson a, toJson b, toJson c, toJson d, toJson e]
+ fromJson (JsonArray [a, b, c, d, e]) = (fromJson a, fromJson b, fromJson c, fromJson d, fromJson e)
+
+data Json =
+ JsonString String
+ | JsonDouble Double
+ | JsonLong Long
+ | JsonArray [Json]
+ | JsonBoolean Boolean
+ | JsonNull
+ | JsonObject [JsonField]
+data JsonField = JsonField String Json
+
+lookupJsonField :: String -> Json -> Maybe Json
+lookupJsonField fieldName (JsonObject fields) = mapFirst selector fields
+ where
+ selector (JsonField name value) | name == fieldName = Just value
+ selector _ = Nothing
+
+deriving instance Show Json
+deriving instance Show JsonField
+
+instance Json Json where
+ writeJson g (JsonString value) = writeString g value
+ writeJson g (JsonDouble value) = writeNumberDouble g value
+ writeJson g (JsonLong value) = writeNumberLong g value
+ writeJson g (JsonBoolean value) = writeBoolean g value
+ writeJson g JsonNull = writeNull g
+ writeJson g (JsonArray values) = do
+ writeStartArray g
+ iter (writeJson g) values
+ writeEndArray g
+ writeJson g (JsonObject fields) = do
+ writeStartObject g
+ iter (\(JsonField name value) -> do
+ writeFieldName g name
+ writeJson g value) fields
+ writeEndObject g
+
+ readJson p = do
+ token = currentToken p
+ if token == VALUE_STRING
+ then JsonString (getText p)
+ else if token == VALUE_NUMBER_FLOAT
+ then JsonDouble (getDoubleValue p)
+ else if token == VALUE_NUMBER_INT
+ then JsonLong (getLongValue p)
+ else if token == VALUE_TRUE
+ then JsonBoolean True
+ else if token == VALUE_FALSE
+ then JsonBoolean False
+ else if token == VALUE_NULL
+ then JsonNull
+ else if token == START_ARRAY
+ then do
+ result = MList.create ()
+ while (nextToken p != END_ARRAY)
+ (MList.add result $ readJson p)
+ JsonArray (MList.freeze result)
+ else if token == START_OBJECT
+ then do
+ result = MList.create ()
+ readJsonObjectContents result p
+ JsonObject (MList.freeze result)
+ else fail "Unsupported token type."
+ toJson = id
+ fromJson = id
+
+@private
+readJsonObjectContents :: MList.T JsonField -> JsonParser -> <Proc> ()
+readJsonObjectContents result p =
+ match nextFieldName p with
+ Just name -> do
+ MList.add result $ JsonField name (readNextJson p)
+ readJsonObjectContents result p
+ Nothing -> ()
+
+/*
+@private
+makeTypeEqual :: a -> a -> ()
+makeTypeEqual _ _ = ()
+
+@private
+testValue :: Json a => Show a => a -> <Proc> ()
+testValue v1 = do
+ v2 = toJsonString v1
+ v3 = fromJsonString v2
+ makeTypeEqual v1 v3
+ print "\(v1) -> \(v2) -> \(v3)"
+ if v1 != v3
+ then fail "Values differ"
+ else ()
+
+testGenericJson :: String -> <Proc> ()
+testGenericJson v1 = do
+ v2 = fromJsonString v1 :: Json
+ v3 = toJsonString v2
+ print "\(v1) -> \(v2) -> \(v3)"
+ if v1 != v3
+ then fail "Values differ"
+ else ()
+
+testIt :: <Proc> ()
+testIt = do
+ testValue "asd"
+ testValue True
+ testValue False
+ testValue (123 :: Short)
+ testValue (123 :: Integer)
+ testValue (123 :: Long)
+ testValue (123 :: Double)
+ testValue (123 :: Float)
+ testValue (Nothing :: Maybe String)
+ testValue (Just "asd")
+ testValue ["a", "b", "c"]
+ testValue [[],["a"],["b","c"]]
+ testValue ()
+ testValue ("a", "b")
+ testValue ("a", "b", "c")
+ testValue ("a", "b", "c", "d")
+ testValue [Just "a", Nothing]
+ testValue [("a", "b"), ("c", "d")]
+ testValue (("a", "b"), ("c", "d"))
+
+ testGenericJson "\"asd\""
+ testGenericJson "123"
+ testGenericJson "123.0"
+ testGenericJson "true"
+ testGenericJson "false"
+ testGenericJson "null"
+ testGenericJson "[1,2,3]"
+ testGenericJson "[[1],[2,3],[]]"
+ testGenericJson "{}"
+ testGenericJson "{\"a\":123,\"b\":[]}"
+ testGenericJson "{\"a\":{}}"
*/
\ No newline at end of file
Code Review / simantics / platform.git / blobdiff