From 402384bf9afa895e925d9d2593a81e99ab99eab9 Mon Sep 17 00:00:00 2001
From: =?utf8?q?Hannu=20Niemist=C3=B6?= <hannu.niemisto@semantum.fi>
Date: Tue, 13 Sep 2016 16:29:17 +0300
Subject: [PATCH] An initial implementation of Json module.

Change-Id: I33668d8cfdcafd91f7f205a49d5660337f2f0c46
---
 .../META-INF/MANIFEST.MF                      |   3 +-
 .../org.simantics.scl.data/scl/Data/Json.md   |  42 ++
 .../org.simantics.scl.data/scl/Data/Json.scl  | 421 ++++++++++++++++++
 .../scl/Data/Writer.scl                       |  18 +
 4 files changed, 483 insertions(+), 1 deletion(-)
 create mode 100644 bundles/org.simantics.scl.data/scl/Data/Json.md
 create mode 100644 bundles/org.simantics.scl.data/scl/Data/Json.scl
 create mode 100644 bundles/org.simantics.scl.data/scl/Data/Writer.scl

diff --git a/bundles/org.simantics.scl.data/META-INF/MANIFEST.MF b/bundles/org.simantics.scl.data/META-INF/MANIFEST.MF
index 950e59b42..52095a101 100644
--- 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
index 000000000..fe8e7218f
--- /dev/null
+++ b/bundles/org.simantics.scl.data/scl/Data/Json.md
@@ -0,0 +1,42 @@
+# Basic functions
+
+::value[toJsonString, fromJsonString]
+
+# Supported value types
+
+This module supports the following value types:
+
+```
+instance Json String
+instance Json Short
+instance Json Integer
+instance Json Long
+instance Json Float
+instance Json Double
+
+instance (Json a) => Json [a]
+instance (Json a) => Json (Maybe a)
+
+instance Json ()
+instance (Json a, Json b) => Json (a, b)
+instance (Json a, Json b, Json c) => Json (a, b, c)
+instance (Json a, Json b, Json c, Json d) => Json (a, b, c, d)
+instance (Json a, Json b, Json c, Json d, Json e) => Json (a, b, c, d, e) 
+
+instance Json Json
+```
+
+# Generic JSON Type
+
+::data[Json, JsonField]
+
+# Adding support for additional value types
+
+::data[JsonGenerator, JsonParser]
+::class[Json]
+
+It is enough to implement `toJson` and `fromJson`.
+
+# Undocumented entities
+
+::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
index 000000000..fb034cd57
--- /dev/null
+++ b/bundles/org.simantics.scl.data/scl/Data/Json.scl
@@ -0,0 +1,421 @@
+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\":{}}"
+*/
\ 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
index 000000000..4c526f2c1
--- /dev/null
+++ b/bundles/org.simantics.scl.data/scl/Data/Writer.scl
@@ -0,0 +1,18 @@
+import "JavaBuiltin" as Java
+
+importJava "java.io.Writer" where
+    data Writer
+
+importJava "java.io.StringWriter" where
+    data StringWriter
+    
+    @JavaName "<init>"
+    createStringWriter :: <Proc> StringWriter
+
+    @JavaName toString
+    resultOfStringWriter :: StringWriter -> <Proc> String
+
+class WriterLike a where
+    toWriter :: a -> Writer
+instance WriterLike StringWriter where
+    toWriter = Java.unsafeCoerce
\ No newline at end of file
-- 
2.47.1