An initial implementation of Json module.

Change-Id: I33668d8cfdcafd91f7f205a49d5660337f2f0c46

diff --git a/bundles/org.simantics.scl.data/META-INF/MANIFEST.MF b/bundles/org.simantics.scl.data/META-INF/MANIFEST.MF
index 950e59b42ff0238825f5f0037490c67dd021d843..52095a10169c88160aac11f4b9d3392cc79806e4 100644 (file)
--- a/bundles/org.simantics.scl.data/META-INF/MANIFEST.MF
+++ b/bundles/org.simantics.scl.data/META-INF/MANIFEST.MF
@@ -7,5 +7,6 @@ Bundle-RequiredExecutionEnvironment: JavaSE-1.7
 Require-Bundle: org.simantics.scl.runtime;bundle-version="0.4.0",
  org.simantics.scl.osgi;bundle-version="1.0.4",
  org.jdom2;bundle-version="2.0.6",
- org.junit;bundle-version="4.12.0";resolution:=optional
+ org.junit;bundle-version="4.12.0";resolution:=optional,
+ com.fasterxml.jackson.core.jackson-core;bundle-version="2.8.2"
 Bundle-ClassPath: .

diff --git a/bundles/org.simantics.scl.data/scl/Data/Json.md b/bundles/org.simantics.scl.data/scl/Data/Json.md
new file mode 100644 (file)
index 0000000..fe8e721
--- /dev/null
+++ b/bundles/org.simantics.scl.data/scl/Data/Json.md
@@ -0,0 +1,42 @@
+# Basic functions\r
+\r
+::value[toJsonString, fromJsonString]\r
+\r
+# Supported value types\r
+\r
+This module supports the following value types:\r
+\r
+```\r
+instance Json String\r
+instance Json Short\r
+instance Json Integer\r
+instance Json Long\r
+instance Json Float\r
+instance Json Double\r
+\r
+instance (Json a) => Json [a]\r
+instance (Json a) => Json (Maybe a)\r
+\r
+instance Json ()\r
+instance (Json a, Json b) => Json (a, b)\r
+instance (Json a, Json b, Json c) => Json (a, b, c)\r
+instance (Json a, Json b, Json c, Json d) => Json (a, b, c, d)\r
+instance (Json a, Json b, Json c, Json d, Json e) => Json (a, b, c, d, e) \r
+\r
+instance Json Json\r
+```\r
+\r
+# Generic JSON Type\r
+\r
+::data[Json, JsonField]\r
+\r
+# Adding support for additional value types\r
+\r
+::data[JsonGenerator, JsonParser]\r
+::class[Json]\r
+\r
+It is enough to implement `toJson` and `fromJson`.\r
+\r
+# Undocumented entities\r
+\r
+::undocumented[]
\ No newline at end of file

diff --git a/bundles/org.simantics.scl.data/scl/Data/Json.scl b/bundles/org.simantics.scl.data/scl/Data/Json.scl
new file mode 100644 (file)
index 0000000..fb034cd
--- /dev/null
+++ b/bundles/org.simantics.scl.data/scl/Data/Json.scl
@@ -0,0 +1,421 @@
+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
+*/
\ No newline at end of file

diff --git a/bundles/org.simantics.scl.data/scl/Data/Writer.scl b/bundles/org.simantics.scl.data/scl/Data/Writer.scl
new file mode 100644 (file)
index 0000000..4c526f2
--- /dev/null
+++ b/bundles/org.simantics.scl.data/scl/Data/Writer.scl
@@ -0,0 +1,18 @@
+import "JavaBuiltin" as Java\r
+\r
+importJava "java.io.Writer" where\r
+    data Writer\r
+\r
+importJava "java.io.StringWriter" where\r
+    data StringWriter\r
+    \r
+    @JavaName "<init>"\r
+    createStringWriter :: <Proc> StringWriter\r
+\r
+    @JavaName toString\r
+    resultOfStringWriter :: StringWriter -> <Proc> String\r
+\r
+class WriterLike a where\r
+    toWriter :: a -> Writer\r
+instance WriterLike StringWriter where\r
+    toWriter = Java.unsafeCoerce
\ No newline at end of file