Skip to content
This repository has been archived by the owner on Sep 7, 2023. It is now read-only.

Commit

Permalink
Merge 6f7f228 into aaca615
Browse files Browse the repository at this point in the history
  • Loading branch information
@jeromesimeon
jeromesimeon committed Mar 8, 2022
2 parents aaca615 + 6f7f228 commit 708ff08
Show file tree
Hide file tree
Showing 23 changed files with 26,450 additions and 27,311 deletions.
2 changes: 1 addition & 1 deletion .github/workflows/build.yml
View file
Expand Up @@ -13,8 +13,8 @@ jobs:
strategy:
matrix:
node-version:
- 12.x
- 14.x
- 16.x
os:
- ubuntu-latest
- macOS-latest
Expand Down
89 changes: 42 additions & 47 deletions compiler/atds/cto.atd
View file
Expand Up @@ -22,69 +22,64 @@
type json <ocaml module="Yojson.Basic" t="t"> = abstract
<doc text="Type of arbitrary JSON values.">

type loc = {
offset : int;
type position = {
ttype <json name="$class"> : string;
line : int;
column: int;
} <ocaml field_prefix="cto_loc_">
offset : int;
} <ocaml field_prefix="cto_position_">

type location = {
start : loc;
end : loc;
} <ocaml field_prefix="cto_location_">
type range = {
ttype <json name="$class"> : string;
start : position;
end : position;
} <ocaml field_prefix="cto_range_">

type decorator = json

type propType = {
type typeIdentifier = {
ttype <json name="$class"> : string;
name : string;
} <ocaml field_prefix="cto_prop_type_">
type optional = {
ttype <json name="type"> : string;
}
type declaration = {
ttype <json name="type"> : string;
id : id;
?propertyType : propType nullable;
?array : string nullable;
optional : optional nullable;
decorators : decorator list;
location : location;
} <ocaml field_prefix="cto_decl_content_">
?namespace : string nullable;
} <ocaml field_prefix="cto_type_identifier_">

type definition_content = {
ttype <json name="type"> : string;
declarations : declaration list;
} <ocaml field_prefix="cto_defn_content_">
type identified = {
ttype <json name="$class"> : string;
?name : string nullable;
} <ocaml field_prefix="cto_identified_">

type id = {
ttype <json name="type"> : string;
type property = {
ttype <json name="$class"> : string;
name : string;
} <ocaml field_prefix="cto_id_">
?isOptional : bool nullable;
?isArray : bool nullable;
?ptype <json name="type"> : typeIdentifier nullable;
?decorators : decorator list nullable;
?validator : json nullable;
?defaultValue: json nullable;
?location : range nullable;
} <ocaml field_prefix="cto_property_">

type classRef = {
ttype <json name="type"> : string;
type declaration = {
ttype <json name="$class"> : string;
name : string;
} <ocaml field_prefix="cto_extends_">
type classExtension = {
ttype <json name="type"> : string;
class : classRef;
} <ocaml field_prefix="cto_extends_">
type definition = {
ttype <json name="type"> : string;
id : id;
?classExtension : classExtension nullable;
body : definition_content;
?abstract : json nullable;
?location : location nullable;
} <ocaml field_prefix="cto_defn_">
properties : property list;
?superType : typeIdentifier nullable;
?isAbstract : bool nullable;
?location : range nullable;
} <ocaml field_prefix="cto_declaration_">

type import = {
ttype <json name="$class"> : string;
?name : string nullable;
namespace : string;
?uri : string nullable;
} <ocaml field_prefix="cto_import_">

type model = {
ttype <json name="type"> : string;
ttype <json name="$class"> : string;
namespace : string;
imports : import list;
body : definition list;
} <ocaml field_prefix="cto_">
declarations : declaration list;
} <ocaml field_prefix="cto_model_">
<doc text="Type of CTO models">

154 changes: 73 additions & 81 deletions compiler/lib/cto_import.ml
View file
Expand Up @@ -19,22 +19,23 @@ open Cto_j

let filename = ref ""

let enum_case_of_decl d =
char_list_of_string d.cto_decl_content_id.cto_id_name
let enum_case_of_property d =
char_list_of_string d.cto_property_name

let cto_enum_of_decls dl =
List.map enum_case_of_decl dl
let cto_enum_of_properties dl =
List.map enum_case_of_property dl

let mk_abstract j =
begin match j with
| Some true -> true
| Some false
| None -> false
| Some _ -> true
end

let mk_extends j =
let mk_superType j =
begin match j with
| None -> None
| Some ce -> Some (None, Util.char_list_of_string ce.cto_extends_class.cto_extends_name)
| Some ce -> Some (None, Util.char_list_of_string ce.cto_type_identifier_name)
end

let mk_prov loc =
Expand All @@ -43,94 +44,79 @@ let mk_prov loc =
ErgoCompiler.prov_loc
{ loc_file = Util.char_list_of_string !filename;
loc_start =
{ offset = loc.cto_location_start.cto_loc_offset;
line = loc.cto_location_start.cto_loc_line;
column = loc.cto_location_start.cto_loc_column; };
{ offset = loc.cto_range_start.cto_position_offset;
line = loc.cto_range_start.cto_position_line;
column = loc.cto_range_start.cto_position_column; };
loc_end =
{ offset = loc.cto_location_end.cto_loc_offset;
line = loc.cto_location_end.cto_loc_line;
column = loc.cto_location_end.cto_loc_column; }; }
{ offset = loc.cto_range_end.cto_position_offset;
line = loc.cto_range_end.cto_position_line;
column = loc.cto_range_end.cto_position_column; }; }
| None ->
dummy_provenance
end

let base_type_of_decl loc d =
begin match d with
| None -> ergo_raise (ergo_system_error "Missing propertyType in CTO")
| Some d ->
begin match d.cto_prop_type_name with
| "Boolean" -> ErgoCompiler.cto_boolean loc
| "String" -> ErgoCompiler.cto_string loc
| "Double" -> ErgoCompiler.cto_double loc
| "Integer" -> ErgoCompiler.cto_integer loc
| "Long" -> ErgoCompiler.cto_long loc
| "DateTime" -> ErgoCompiler.cto_dateTime loc
| s -> ErgoCompiler.cto_class_ref loc
(None,(char_list_of_string s))
end
let base_type_of_property loc d =
begin match d.cto_property_ttype with
| "concerto.metamodel.BooleanProperty" -> ErgoCompiler.cto_boolean loc
| "concerto.metamodel.StringProperty" -> ErgoCompiler.cto_string loc
| "concerto.metamodel.DoubleProperty" -> ErgoCompiler.cto_double loc
| "concerto.metamodel.IntegerProperty" -> ErgoCompiler.cto_integer loc
| "concerto.metamodel.LongProperty" -> ErgoCompiler.cto_long loc
| "concerto.metamodel.DateTimeProperty" -> ErgoCompiler.cto_dateTime loc
| s -> begin match d.cto_property_ptype with
| None ->
ergo_raise (ergo_system_error ("Mal-formed property, without a corresponding type identifier (class: " ^ s ^ ")"))
| Some t ->
ErgoCompiler.cto_class_ref loc
(None,(char_list_of_string t.cto_type_identifier_name))
end
end

let field_of_decl d =
let loc = mk_prov (Some d.cto_decl_content_location) in
let field_name = char_list_of_string d.cto_decl_content_id.cto_id_name in
let field_of_property d =
let loc = mk_prov d.cto_property_location in
let field_name = char_list_of_string d.cto_property_name in
let base_type =
base_type_of_decl loc d.cto_decl_content_propertyType
base_type_of_property loc d
in
let field_type = base_type in
let field_type =
begin match d.cto_decl_content_array with
| Some "[]" -> ErgoCompiler.cto_array loc field_type
| Some _ -> ergo_raise (ergo_system_error "Mal-formed array option in CTO JSON representation")
begin match d.cto_property_isArray with
| Some true -> ErgoCompiler.cto_array loc field_type
| Some false
| None -> field_type
end
in
let field_type =
begin match d.cto_decl_content_optional with
begin match d.cto_property_isOptional with
| Some true -> ErgoCompiler.cto_option loc field_type
| Some false
| None -> field_type
| Some opt ->
ErgoCompiler.cto_option loc field_type
end
in
(field_name, field_type)

let cto_concept_of_decls dl =
List.map field_of_decl dl
let cto_fields_of_properties dl =
List.map field_of_property dl

let cto_event_of_decls dl =
List.map field_of_decl dl

let cto_asset_of_decls dl =
List.map field_of_decl dl

let cto_participant_of_decls dl =
List.map field_of_decl dl

let cto_declaration_of_defn d =
let decl_class = d.cto_defn_id.cto_id_name in
let loc = mk_prov d.cto_defn_location in
let abstract = mk_abstract d.cto_defn_abstract in
let extends = mk_extends d.cto_defn_classExtension in
(* if abstract then Printf.printf "Found abstract class: %s !\n" decl_class; *)
(* if abstract then Printf.printf "Found abstract class: %s !\n" decl_class; *)
let cto_declaration_of_declaration d =
let decl_class = d.cto_declaration_name in
let loc = mk_prov d.cto_declaration_location in
let abstract = mk_abstract d.cto_declaration_isAbstract in
let extends = mk_superType d.cto_declaration_superType in
let decl_type =
begin match d.cto_defn_ttype with
| "EnumDeclaration" ->
CTOEnum (cto_enum_of_decls d.cto_defn_body.cto_defn_content_declarations)
| "TransactionDeclaration" ->
(* XXX First parameter is inheritance TBD *)
CTOTransaction (abstract, extends, cto_concept_of_decls d.cto_defn_body.cto_defn_content_declarations)
| "ConceptDeclaration" ->
(* XXX First parameter is inheritance TBD *)
CTOConcept (abstract, extends, cto_concept_of_decls d.cto_defn_body.cto_defn_content_declarations)
| "EventDeclaration" ->
(* XXX First parameter is inheritance TBD *)
CTOEvent (abstract, extends, cto_event_of_decls d.cto_defn_body.cto_defn_content_declarations)
| "AssetDeclaration" ->
(* XXX First parameter is inheritance TBD *)
CTOAsset (abstract, extends, cto_asset_of_decls d.cto_defn_body.cto_defn_content_declarations)
| "ParticipantDeclaration" ->
(* XXX First parameter is inheritance TBD *)
CTOParticipant (abstract, extends, cto_participant_of_decls d.cto_defn_body.cto_defn_content_declarations)
begin match d.cto_declaration_ttype with
| "concerto.metamodel.EnumDeclaration" ->
CTOEnum (cto_enum_of_properties d.cto_declaration_properties)
| "concerto.metamodel.ConceptDeclaration" ->
CTOConcept (abstract, extends, cto_fields_of_properties d.cto_declaration_properties)
| "concerto.metamodel.TransactionDeclaration" ->
CTOTransaction (abstract, extends, cto_fields_of_properties d.cto_declaration_properties)
| "concerto.metamodel.EventDeclaration" ->
CTOEvent (abstract, extends, cto_fields_of_properties d.cto_declaration_properties)
| "concerto.metamodel.AssetDeclaration" ->
CTOAsset (abstract, extends, cto_fields_of_properties d.cto_declaration_properties)
| "concerto.metamodel.ParticipantDeclaration" ->
CTOParticipant (abstract, extends, cto_fields_of_properties d.cto_declaration_properties)
| other ->
ergo_raise (ergo_system_error ("Can't import CTO kind: " ^ other))
end
Expand All @@ -139,21 +125,27 @@ let cto_declaration_of_defn d =
cto_declaration_annot = loc;
cto_declaration_type = decl_type; }

let cto_declarations_of_body dl =
List.map cto_declaration_of_defn dl
let cto_declarations_of_declarations dl =
List.map cto_declaration_of_declaration dl

let cto_import_of_import i =
cto_import_decl_of_import_namespace i.cto_import_namespace
let cto_import_decl_of_import ns =
let loc = dummy_provenance in (* XXX Not in JSON *)
let namespace = char_list_of_string ns.cto_import_namespace in
begin match ns.cto_import_name with
| None ->
ImportAll (loc, namespace)
| Some name ->
ImportName (loc, namespace, char_list_of_string name)
end

let cto_import f (m:model) : ErgoCompiler.cto_package =
filename := f;
let namespace = char_list_of_string m.cto_namespace in
let imports = List.map cto_import_of_import m.cto_imports in
let decls = cto_declarations_of_body m.cto_body in
let namespace = char_list_of_string m.cto_model_namespace in
let imports = List.map cto_import_decl_of_import m.cto_model_imports in
let decls = cto_declarations_of_declarations m.cto_model_declarations in
{ cto_package_namespace = namespace;
cto_package_file = Util.char_list_of_string !filename;
cto_package_prefix = Util.char_list_of_string (Util.class_prefix_of_filename !filename);
cto_package_annot = dummy_provenance; (* XXX Not in JSON *)
cto_package_imports = imports;
cto_package_declarations = decls; }

14 changes: 0 additions & 14 deletions compiler/lib/ergo_util.ml
View file
Expand Up @@ -203,20 +203,6 @@ let ergo_call contract_name =
Util.string_of_char_list
(ErgoCompiler.javascript_identifier_sanitizer (Util.char_list_of_string contract_name))

(** CTO import *)
let cto_import_decl_of_import_namespace ns =
begin match String.rindex_opt ns '.' with
| None ->
ergo_raise (ergo_system_error ("Malformed import: '" ^ ns ^ "' (should have at least one '.')"))
| Some i ->
let namespace = char_list_of_string (String.sub ns 0 i) in
let criteria_str = String.sub ns (i+1) (String.length ns - (i+1)) in
begin match criteria_str with
| "*" -> ImportAll (dummy_provenance, namespace)
| _ -> ImportName (dummy_provenance,namespace,char_list_of_string criteria_str)
end
end

(** Command line args *)
let patch_extension f ext1 ext2 =
begin try
Expand Down
8 changes: 4 additions & 4 deletions compiler/lib/ergo_util.mli
View file
Expand Up @@ -53,6 +53,10 @@ val mk_provenance_of_loc_pair : string -> Lexing.position -> Lexing.position ->
val ergo_version : string
val get_version : string -> (unit -> unit)

(** Command line args *)
val patch_cto_extension : string -> string
val unpatch_cto_extension : string -> string

val parse_args :
('conf -> (Arg.key * Arg.spec * Arg.doc) list)
-> Arg.usage_msg
Expand All @@ -62,10 +66,6 @@ val parse_args :

val patch_argv : string array -> string array

(** CTO *)
val cto_import_decl_of_import_namespace : string -> provenance import_decl
val unpatch_cto_extension : string -> string

(** Topological sort *)
val labels_of_graph : ('a,'ap,'b) ergo_input list -> (string * string list) list
val topo_sort_inputs : ('a,'ap,'b) ergo_input list -> ('a,'ap,'b) ergo_input list
Expand Down

0 comments on commit 708ff08

Please sign in to comment.