Automatic deriving of instances for Json

Example:

data GeographicalLocation = GeographicalLocation {
    latitude :: Double,
    longitude :: Maybe Double
}

deriving instance Json GeographicalLocation

testIt :: <Proc> ()
testIt = do
    print $ toJsonString GeographicalLocation {
        latitude = 1,
        longitude = Just 2 }
    print (fromJsonString
        "{ \"latitude\": 1, \"longitude\": 2 }"
        :: GeographicalLocation)
    print $ toJsonString GeographicalLocation {
        latitude = 1,
        longitude = Nothing }
    print (fromJsonString
        "{ \"latitude\": 1 }"
        :: GeographicalLocation)

#256

Change-Id: I7f44b65472436779045e4d15871858d14132dff9

diff --git a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/common/names/Names.java b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/common/names/Names.java
index ba78a35483dda0faa00c93b69d89880d97944071..7767b5d2056649fa758748bc3011c31755b3b415 100644 (file)
--- a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/common/names/Names.java
+++ b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/common/names/Names.java
@@ -13,11 +13,19 @@ public class Names {
     public static final Name Builtin_fail = Name.create(Types.BUILTIN, "fail");
     public static final Name Builtin_runProc = Name.create(Types.BUILTIN, "runProc");
     public static final Name Builtin_createCHRContext = Name.create(Types.BUILTIN, "createCHRContext");
+    public static final Name Builtin_Just = Name.create("Builtin", "Just");
+    public static final Name Builtin_Nothing = Name.create("Builtin", "Nothing");
     public static final Name Data_XML_createElement = Name.create("Data/XML", "createElement");
     public static final Type Data_XML_Element = Types.con("Data/XML", "Element");
     public static final TCon Expressions_Context_Context = Types.con("Expressions/Context", "Context");    
     public static final Name Expressions_Context_contextGet = Name.create("Expressions/Context", "contextGet");
     public static final Name JavaBuiltin_unsafeCoerce = Name.create("JavaBuiltin", "unsafeCoerce");
+    public static final TCon Json_Json = Types.con("Data/Json", "Json");
+    public static final Name Json_fromJson = Name.create("Data/Json", "fromJson");
+    public static final Name Json_toJson = Name.create("Data/Json", "toJson");
+    public static final Name Json_lookupJsonField = Name.create("Data/Json", "lookupJsonField");
+    public static final Name Json_JsonObject = Name.create("Data/Json", "JsonObject");
+    public static final Name Json_JsonField = Name.create("Data/Json", "JsonField");
     public static final Name MList_add = Name.create("MList", "add");
     public static final Name MList_create = Name.create("MList", "create");
     public static final Name MList_freeze = Name.create("MList", "freeze");
@@ -36,15 +44,19 @@ public class Names {
     public static final Name Prelude_bindE = Name.create("Prelude", "bindE");
     public static final Name Prelude_build = Name.create("Prelude", "build");
     public static final Name Prelude_concatMap = Name.create("Prelude", "concatMap");
+    public static final Name Prelude_dot = Name.create("Prelude", ".");
     public static final Name Prelude_dollar = Name.create("Prelude", "$");
     public static final Name Prelude_elem = Name.create("Prelude", "elem");
     public static final Name Prelude_elemMaybe = Name.create("Prelude", "elemMaybe");
     public static final Name Prelude_emptyList = Name.create("Prelude", "emptyList");
+    public static final Name Prelude_filterJust = Name.create("Prelude", "filterJust");
     public static final Name Prelude_foldl = Name.create("Prelude", "foldl");
     public static final Name Prelude_fromDouble = Name.create("Prelude", "fromDouble");
     public static final Name Prelude_fromInteger = Name.create("Prelude", "fromInteger");
+    public static final Name Prelude_fromJust = Name.create("Prelude", "fromJust");
     public static final Name Prelude_guardList = Name.create("Prelude", "guardList");
     public static final Name Prelude_iterList = Name.create("Prelude", "iterList");
+    public static final Name Prelude_map = Name.create("Prelude", "map");
     public static final Name Prelude_mapFirst = Name.create("Prelude", "mapFirst");
     public static final Name Prelude_mapList = Name.create("Prelude", "mapList");
     public static final Name Prelude_neg = Name.create("Prelude", "neg");

diff --git a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/internal/deriving/InstanceDerivers.java b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/internal/deriving/InstanceDerivers.java
index b450766a6a5893c62b864381e25212c88be7dac3..43f9b3385e7deebf816778d44feb16597d628cd1 100644 (file)
--- a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/internal/deriving/InstanceDerivers.java
+++ b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/internal/deriving/InstanceDerivers.java
@@ -1,5 +1,6 @@
 package org.simantics.scl.compiler.internal.deriving;
 
+import org.simantics.scl.compiler.common.names.Names;
 import org.simantics.scl.compiler.types.TCon;
 import org.simantics.scl.compiler.types.Types;
 
@@ -13,6 +14,7 @@ public class InstanceDerivers {
         MAP.put(Types.IO, new IODeriver());
         MAP.put(Types.ORD, new OrdDeriver());
         MAP.put(Types.SHOW, new ShowDeriver());
+        MAP.put(Names.Json_Json, new JsonDeriver());
     }
     
     public static InstanceDeriver get(TCon typeClass) {

diff --git a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/internal/deriving/JsonDeriver.java b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/internal/deriving/JsonDeriver.java
new file mode 100644 (file)
index 0000000..24f8b31
--- /dev/null
+++ b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/internal/deriving/JsonDeriver.java
@@ -0,0 +1,218 @@
+package org.simantics.scl.compiler.internal.deriving;
+
+import java.util.ArrayList;
+
+import org.simantics.scl.compiler.common.datatypes.Constructor;
+import org.simantics.scl.compiler.common.names.Names;
+import org.simantics.scl.compiler.constants.StringConstant;
+import org.simantics.scl.compiler.elaboration.errors.NotPatternException;
+import org.simantics.scl.compiler.elaboration.expressions.EApply;
+import org.simantics.scl.compiler.elaboration.expressions.EConstant;
+import org.simantics.scl.compiler.elaboration.expressions.EListLiteral;
+import org.simantics.scl.compiler.elaboration.expressions.ELiteral;
+import org.simantics.scl.compiler.elaboration.expressions.ERecord;
+import org.simantics.scl.compiler.elaboration.expressions.EVar;
+import org.simantics.scl.compiler.elaboration.expressions.Expression;
+import org.simantics.scl.compiler.elaboration.expressions.records.FieldAssignment;
+import org.simantics.scl.compiler.elaboration.modules.SCLValue;
+import org.simantics.scl.compiler.elaboration.modules.TypeAlias;
+import org.simantics.scl.compiler.elaboration.modules.TypeConstructor;
+import org.simantics.scl.compiler.elaboration.modules.TypeDescriptor;
+import org.simantics.scl.compiler.environment.AmbiguousNameException;
+import org.simantics.scl.compiler.environment.Environment;
+import org.simantics.scl.compiler.environment.Environments;
+import org.simantics.scl.compiler.errors.ErrorLog;
+import org.simantics.scl.compiler.internal.parsing.declarations.DDerivingInstanceAst;
+import org.simantics.scl.compiler.internal.parsing.declarations.DInstanceAst;
+import org.simantics.scl.compiler.internal.parsing.declarations.DValueAst;
+import org.simantics.scl.compiler.internal.parsing.translation.ProcessedDInstanceAst;
+import org.simantics.scl.compiler.internal.parsing.translation.ValueRepository;
+import org.simantics.scl.compiler.internal.parsing.types.TVarAst;
+import org.simantics.scl.compiler.types.TApply;
+import org.simantics.scl.compiler.types.TCon;
+import org.simantics.scl.compiler.types.Type;
+import org.simantics.scl.compiler.types.Types;
+
+class JsonDeriver implements InstanceDeriver {
+
+    @Override
+    public void derive(
+            ErrorLog errorLog,
+            Environment environment,
+            ArrayList<ProcessedDInstanceAst> instancesAst,
+            DDerivingInstanceAst der) {
+        // Analyze
+        if(der.types.length != 1) {
+            errorLog.log(der.location, "Invalid number of parameters to " + der.name);
+            return;
+        }
+        TVarAst headType = DerivingUtils.getHeadType(der.types[0]);
+        if(headType == null) {
+            errorLog.log(der.types[0].location, "Cannot derive Json instance for the type " + headType + ".");
+            return;
+        }
+        TCon con;
+        try {
+            con = Environments.getTypeDescriptorName(environment, headType.name);
+        } catch (AmbiguousNameException e1) {
+            errorLog.log(headType.location, e1.getMessage());
+            return;
+        }
+        if(con == null) {
+            errorLog.log(headType.location, "Couldn't resolve " + headType.name);
+            return;
+        }
+        TypeDescriptor tdesc = environment.getTypeDescriptor(con);
+        if(tdesc == null) {
+            errorLog.log(headType.location, "Didn't find type constructor for " + headType.name);
+            return;
+        }
+        if(tdesc instanceof TypeAlias) {
+            errorLog.log(headType.location, "Cannot derive instance for a type alias.");
+            return;
+        }
+        TypeConstructor tcon = (TypeConstructor)tdesc;
+        if(tcon.isOpen) {
+            errorLog.log(headType.location, "Cannot derive instance for open data types.");
+            return;
+        }
+
+        if(tcon.constructors.length != 1) {
+            errorLog.log(headType.location, "Data must have exactly one constructor for deriving to work.");
+            return;
+        }
+        Constructor constructor = tcon.constructors[0];
+        if(constructor.recordFieldNames == null) {
+            errorLog.log(headType.location, "Data must have a record constructor for deriving to work.");
+            return;
+        }
+
+        DInstanceAst instanceAst = new DInstanceAst(der.location, der.context, der.name, der.types);
+        ValueRepository valueDefs = new ValueRepository();
+
+        SCLValue fromJson = environment.getValue(Names.Json_fromJson);
+        SCLValue toJson = environment.getValue(Names.Json_toJson);
+        SCLValue lookupJsonField = environment.getValue(Names.Json_lookupJsonField);
+        SCLValue JsonObject = environment.getValue(Names.Json_JsonObject);
+        SCLValue JsonField = environment.getValue(Names.Json_JsonField);
+        
+        SCLValue Just = environment.getValue(Names.Builtin_Just);
+        SCLValue fromJust = environment.getValue(Names.Prelude_fromJust);
+        SCLValue map = environment.getValue(Names.Prelude_map);
+        SCLValue filterJust = environment.getValue(Names.Prelude_filterJust);
+        SCLValue dot = environment.getValue(Names.Prelude_dot);
+
+        // Collect all relevant information about the constructor
+        String constructorName = constructor.name.name;
+        int fieldCount = constructor.parameterTypes.length;
+        String[] fieldNames = constructor.recordFieldNames;
+        boolean[] isOptional = new boolean[fieldCount];
+        boolean hasAtLeastOneOptional = false;
+        for(int i=0;i<fieldCount;++i) {
+            Type type = constructor.parameterTypes[i];
+            hasAtLeastOneOptional |= isOptional[i] = type instanceof TApply
+                    && ((TApply)type).function == Types.MAYBE;
+        }
+
+        // Generate toJson
+        {
+            /* toJson GeographicalLocation { latitude, longitude } = JsonObject [
+             *     JsonField "latitude" (toJson latitude),
+             *     JsonField "longitude" (toJson longitude)
+             * ]
+             * toJson GeographicalLocation { latitude, longitude } = JsonObject $ filterJust [
+             *     Just (JsonField "latitude" (toJson latitude)),
+             *     map (JsonField "longitude" . toJson) longitude
+             * ]
+             */
+            FieldAssignment[] fieldAssignments = new FieldAssignment[fieldCount];
+            for(int i=0;i<fieldCount;++i)
+                fieldAssignments[i] = new FieldAssignment(fieldNames[i], null);
+            Expression lhs = new EApply(
+                    new EVar("toJson"),
+                    new ERecord(new EVar(constructorName), fieldAssignments)
+                    );
+            Expression componentsExpression;
+            if(hasAtLeastOneOptional) {
+                Expression[] components = new Expression[fieldCount];
+                for(int i=0;i<fieldCount;++i) {
+                    if(isOptional[i])
+                        components[i] = new EApply(new EConstant(map),
+                                new EApply(new EConstant(dot),
+                                        new EApply(new EConstant(JsonField), new ELiteral(new StringConstant(fieldNames[i]))),
+                                        new EConstant(toJson)
+                                        ),
+                                new EVar(fieldNames[i])
+                                );
+                    else
+                        components[i] = new EApply(new EConstant(Just),
+                                new EApply(new EConstant(JsonField),
+                                        new ELiteral(new StringConstant(fieldNames[i])),
+                                        new EApply(new EConstant(toJson), new EVar(fieldNames[i]))
+                                        ));
+                }
+                componentsExpression = new EApply(new EConstant(filterJust),
+                        new EListLiteral(components));
+            }
+            else {
+                Expression[] components = new Expression[fieldCount];
+                for(int i=0;i<fieldCount;++i) {
+                    components[i] = new EApply(new EConstant(JsonField),
+                            new ELiteral(new StringConstant(fieldNames[i])),
+                            new EApply(new EConstant(toJson), new EVar(fieldNames[i]))
+                            );
+                }
+                componentsExpression = new EListLiteral(components);
+            }
+            Expression rhs = new EApply(new EConstant(JsonObject), componentsExpression);
+            try {
+                DValueAst valueAst = new DValueAst(lhs, rhs);
+                valueAst.setLocationDeep(der.location);
+                valueDefs.add(valueAst);
+            } catch (NotPatternException e) {
+                errorLog.log(e.getExpression().location, "Not a pattern (a).");
+            }
+        }
+
+        // Generate fromJson
+        {
+            /* fromJson object = GeographicalLocation {
+             *     latitude = fromJson $ fromJust $ lookupJsonField "latitude" object,
+             *     longitude = map fromJson $ lookupJsonField "longitude" object
+             * }
+             */
+            Expression lhs = new EApply(
+                    new EVar("fromJson"),
+                    new EVar("jsonObject")
+                    );
+            FieldAssignment[] fieldAssignments = new FieldAssignment[fieldCount];
+            for(int i=0;i<fieldCount;++i) {
+                Expression fieldValue = new EApply(new EConstant(lookupJsonField),
+                        new ELiteral(new StringConstant(fieldNames[i])),
+                        new EVar("jsonObject")
+                        );
+                if(isOptional[i]) {
+                    fieldValue = new EApply(new EConstant(map), new EConstant(fromJson), fieldValue);
+                }
+                else {
+                    fieldValue = new EApply(new EConstant(fromJust), fieldValue);
+                    fieldValue = new EApply(new EConstant(fromJson), fieldValue);
+                }
+                fieldAssignments[i] = new FieldAssignment(fieldNames[i], fieldValue);
+            }
+            Expression rhs = new ERecord(new EVar(constructorName),
+                    fieldAssignments
+                    );
+            try {
+                DValueAst valueAst = new DValueAst(lhs, rhs);
+                valueAst.setLocationDeep(der.location);
+                valueDefs.add(valueAst);
+            } catch (NotPatternException e) {
+                errorLog.log(e.getExpression().location, "Not a pattern (b).");
+            }
+        }
+
+        instancesAst.add(new ProcessedDInstanceAst(instanceAst, valueDefs));
+    }
+
+}

diff --git a/bundles/org.simantics.scl.data/scl/Data/Json.scl b/bundles/org.simantics.scl.data/scl/Data/Json.scl
index 2190287fcf7560d9f637e20e5600c6ef9805bcff..cacffb01acc806a48d284f220afc8e874c8b8a65 100644 (file)
--- a/bundles/org.simantics.scl.data/scl/Data/Json.scl
+++ b/bundles/org.simantics.scl.data/scl/Data/Json.scl
@@ -174,6 +174,7 @@ instance Json Double where
     readJson = getDoubleValue
     toJson = JsonDouble
     fromJson (JsonDouble value) = value
+    fromJson (JsonLong value) = Java.l2d value
 
 instance Json Float where
     writeJson = writeNumberFloat