From 22b86b38b00d6e168a5872e70113efd5fc1d81b6 Mon Sep 17 00:00:00 2001 From: =?utf8?q?Hannu=20Niemist=C3=B6?= Date: Thu, 14 Feb 2019 14:45:23 +0200 Subject: [PATCH] Automatic deriving of instances for Json Example: data GeographicalLocation = GeographicalLocation { latitude :: Double, longitude :: Maybe Double } deriving instance Json GeographicalLocation testIt :: () 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 --- .../scl/compiler/common/names/Names.java | 12 + .../internal/deriving/InstanceDerivers.java | 2 + .../internal/deriving/JsonDeriver.java | 218 ++++++++++++++++++ .../org.simantics.scl.data/scl/Data/Json.scl | 1 + 4 files changed, 233 insertions(+) create mode 100644 bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/internal/deriving/JsonDeriver.java 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 ba78a3548..7767b5d20 100644 --- 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 b450766a6..43f9b3385 100644 --- 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 index 000000000..24f8b3162 --- /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 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