X-Git-Url: https://gerrit.simantics.org/r/gitweb?p=simantics%2Fplatform.git;a=blobdiff_plain;f=bundles%2Forg.simantics.scl.data%2Fscl%2FData%2FJson.scl;h=2190287fcf7560d9f637e20e5600c6ef9805bcff;hp=fb034cd57886311de41b4aa8253689ce957c0105;hb=66b0fd2ee69d84d3107f109679b6fd1866f8f3fc;hpb=402384bf9afa895e925d9d2593a81e99ab99eab9

diff --git a/bundles/org.simantics.scl.data/scl/Data/Json.scl b/bundles/org.simantics.scl.data/scl/Data/Json.scl
index fb034cd57..2190287fc 100644
--- a/bundles/org.simantics.scl.data/scl/Data/Json.scl
+++ b/bundles/org.simantics.scl.data/scl/Data/Json.scl
@@ -1,421 +1,443 @@
-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
-instance Eq JsonToken where
-    (==) = Java.equals
-
-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
-  
-deriving instance Show Json
-deriving instance Eq Json
-deriving instance Show JsonField
-deriving instance Eq 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 => Eq 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\":{}}"
+/*
+
+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