diff --git a/src/bin/cli.mli b/src/bin/cli.mli new file mode 100644 index 000000000..7b2c6ac42 --- /dev/null +++ b/src/bin/cli.mli @@ -0,0 +1,27 @@ +(* +open Cmdliner + +val main : unit Term.t * Term.info + +val source : int -> string Term.t + +val entry_point : int -> string Term.t + +val expression : string -> int -> string Term.t + +val syntax : string Term.t + +val amount : string Term.t + +val compile_file : unit Term.t * Term.info + +val compile_parameter : unit Term.t * Term.info + +val compile_storage : unit Term.t * Term.info + +val dry_run : unit Term.t * Term.info + +val run_function : unit Term.t * Term.info + +val evaluate_value : unit Term.t * Term.info +*) diff --git a/src/bin/cli_helpers.mli b/src/bin/cli_helpers.mli new file mode 100644 index 000000000..18fce0b58 --- /dev/null +++ b/src/bin/cli_helpers.mli @@ -0,0 +1,3 @@ +open Trace + +val toplevel : display_format : string -> string result -> unit diff --git a/src/main/display.ml b/src/main/display.ml index 93eebbfe9..614ca60c7 100644 --- a/src/main/display.ml +++ b/src/main/display.ml @@ -62,7 +62,7 @@ let string_result_pp_hr = result_pp_hr (fun out s -> Format.fprintf out "%s" s) let result_pp_dev f out (r : _ result) = match r with | Ok (s , _) -> Format.fprintf out "%a" f s - | Error e -> Format.fprintf out "%a" (error_pp ~dev:false) (e ()) + | Error e -> Format.fprintf out "%a" (error_pp ~dev:true) (e ()) let string_result_pp_dev = result_pp_hr (fun out s -> Format.fprintf out "%s" s) diff --git a/src/main/display.mli b/src/main/display.mli new file mode 100644 index 000000000..dc6cc2408 --- /dev/null +++ b/src/main/display.mli @@ -0,0 +1,35 @@ +open Trace + +val error_pp : ?dev:bool -> Format.formatter -> error -> unit + +val result_pp_hr : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a Simple_utils.Trace.result -> unit + +val string_result_pp_hr : Format.formatter -> string Simple_utils.Trace.result -> unit + + +val result_pp_dev : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a Simple_utils.Trace.result -> unit + +val string_result_pp_dev : Format.formatter -> string Simple_utils.Trace.result -> unit + +val json_pp : Format.formatter -> Simple_utils.Trace.J.t -> unit + +val string_result_pp_json : Format.formatter -> string result -> unit + +type display_format = [ + | `Human_readable + | `Json + | `Dev +] + +val display_format_of_string : string -> display_format + +val formatted_string_result_pp : display_format -> Format.formatter -> string Simple_utils.Trace.result -> unit + +type michelson_format = [ + | `Michelson + | `Micheline +] + +val michelson_format_of_string : string -> michelson_format Simple_utils.Trace.result + +val michelson_pp : michelson_format -> Format.formatter -> Tezos_utils.Michelson.michelson -> unit diff --git a/src/passes/1-parser/camligo/generator.ml b/src/passes/1-parser/camligo/generator.ml index c8abd06bd..920bcfe7e 100644 --- a/src/passes/1-parser/camligo/generator.ml +++ b/src/passes/1-parser/camligo/generator.ml @@ -1,8 +1,8 @@ open Simple_utils type 'a name = { - content : 'a ; name : string ; + content : 'a ; } let make_name name content = { name ; content } @@ -736,4 +736,3 @@ let () = Format.printf "%a@.%a\n" PP_helpers.comment "AST" Print_AST.language language ) | _ -> exit 1 - diff --git a/src/passes/1-parser/camligo/generator.mli b/src/passes/1-parser/camligo/generator.mli new file mode 100644 index 000000000..129b93408 --- /dev/null +++ b/src/passes/1-parser/camligo/generator.mli @@ -0,0 +1,275 @@ +open Simple_utils + +type 'a name = { + name : string ; + content : 'a ; +} + +(* +val make_name : string -> 'a -> 'a name +val destruct : 'a name -> ( string * 'a ) +val get_name : 'a name -> string +val get_content : 'a name -> 'a +*) + +module Token = Lex.Token +type token = Token.token + +module O : sig + + type list_mode = + | Trail of token + | Trail_option of token + | Trail_force of token + | Trail_force_ne of token + | Lead of token + | Lead_ne of token + | Separated of token + | Separated_ne of token + | Separated_nene of token + | Naked + | Naked_ne + + type 'a list_element = list_mode * 'a + + type rhs_element = [ + | `Named of string + | `Token of token + | `List of string list_element + | `Option of string + ] + + type rhs = rhs_element list name + type rule = rhs list name + + type manual_rule_content = { + menhir_codes : string list ; + ast_code : string ; + } + type manual_rule = manual_rule_content name + + type singleton = + | Manual of manual_rule + | Generated of rule + + type name_element = [ + | `Named of string + | `Current + | `Lower + ] + + type element = [ + | `Named of string + | `Token of token + | `List of name_element list_element + | `Current + | `Lower + ] + + type operator = element list + type n_operator = operator name + + type n_operators = n_operator list + type level = n_operators name + type level_list = level list + type levels = level List.Ne.t + + type hierarchy = { + prefix : string ; + levels : levels ; + auxiliary_rules : rule list ; + } + type n_hierarchy = hierarchy name + val make_hierarchy : string -> levels -> rule list -> hierarchy + + type language = { + entry_point : string ; + singletons : singleton list ; + hierarchies : n_hierarchy list ; + } + + val get_op : n_operator -> operator + (* + val manual_singleton : string -> string list -> string -> singleton + val rule_singleton : rule -> singleton + val language : string -> singleton list -> n_hierarchy list -> language + val name_hierarchy : string -> string -> n_operators list -> rule list -> n_hierarchy + *) + +end + +module Check : sig + open O + + val well_formed : language -> unit + val associativity : language -> unit + +end + + +(* +val make_constructor : Format.formatter -> (string * string) -> unit +val make_operator : Format.formatter -> (string * string) -> unit +*) + +module Print_AST : sig + (* + open Format + val manual_rule : formatter -> O.manual_rule -> unit + val generated_rule : formatter -> O.rule -> unit + val singleton : formatter -> O.singleton -> unit + val singletons : formatter -> O.singleton list -> unit + val n_operator : string -> string -> formatter -> O.n_operator -> unit + val n_hierarchy : string -> formatter -> O.n_hierarchy -> unit + val n_hierarchies : bool -> formatter -> O.n_hierarchy list -> unit + val language : formatter -> O.language -> unit + *) +end + +module Print_Grammar : sig + (* + open Format + val letters : string array + val manual_rule : formatter -> O.manual_rule -> unit + val generated_rule : formatter -> O.rule -> unit + val singleton : formatter -> O.singleton -> unit + val n_operator_rule : string -> string -> formatter -> O.n_operator -> unit + val n_operator_code : string -> formatter -> O.n_operator -> unit + val n_operator : string -> string -> string -> formatter -> O.n_operator -> unit + val level : string -> string -> formatter -> O.level -> unit + val n_hierarchy : formatter -> O.n_hierarchy -> unit + val language : formatter -> O.language -> unit + *) +end + +(* +val infix : string -> [`Left | `Right] -> token -> O.n_operator +(* Ocaml is bad *) +val empty_infix : string -> [`Left | `Right] -> O.n_operator +val paren : string -> string -> O.n_operator +val expression_name : string +val type_expression_name : string +val restricted_type_expression_name : string +val program_name : string +val variable_name : string +val pattern_name : string +val constructor_name : string +val int_name : string +val tz_name : string +val unit_name : string +val string_name : string +val variable : O.singleton +val int : O.singleton +val tz : O.singleton +val unit : O.singleton +val string : O.singleton +val constructor : O.singleton +*) + +module Pattern : sig + (* + val application : O.n_operator + val data_structure : O.n_operator + val record_element : O.rule + val record : O.n_operator + val pair : O.n_operator + val type_annotation : [> `Current | `Named of string | `Token of token ] list name + val variable : O.n_operator + val constructor : O.n_operator + val module_ident : O.n_operator + val unit : O.n_operator + val restricted_pattern_name : string + val restricted_pattern : O.n_hierarchy + val main : O.n_hierarchy + val singletons : O.singleton list + *) +end + +module Expression : sig + (* + val application : O.n_operator + val type_annotation : [> `Current | `Named of string | `Token of token ] list name + val data_structure : O.n_operator + val fun_ : O.n_operator + val let_in : O.n_operator + val no_seq_name : string + val no_match_name : string + val record_element : O.rule + val record : O.n_operator + val ite : O.n_operator + val it : O.n_operator + + (* let sequence = infix "sequence" `Left SEMICOLON *) + val sequence : [> `List of O.list_mode * [> `Lower ] ] list name + val match_clause : [> `Named of string | `Token of token ] list name list name + val match_with : [> `Current + | `List of O.list_mode * [> `Named of string ] + | `Token of token ] list name + val lt : O.n_operator + val le : O.n_operator + val gt : O.n_operator + val eq : O.n_operator + val neq : O.n_operator + val cons : O.n_operator + val addition : O.n_operator + val substraction : O.n_operator + val multiplication : O.n_operator + val division : O.n_operator + val arith_variable : O.n_operator + val int : O.n_operator + val tz : O.n_operator + val unit : O.n_operator + val string : O.n_operator + val constructor : O.n_operator + val module_ident : O.n_operator + *) + val access : O.n_operator + (* + val accessor : O.n_operator + val assignment : O.n_operator + val tuple : [> `List of O.list_mode * [> `Lower ] ] list name + val name : [> `Current | `Token of token ] list name + val main_hierarchy_name : string + val main_hierarchy : O.n_hierarchy + val no_sequence_expression : O.n_hierarchy + val no_match_expression : O.n_hierarchy + val expression : O.n_hierarchy + val singletons : O.singleton list + *) +end + +module Type_expression : sig + + (* + val record_element : O.rule + val record : O.n_operator + val application : O.n_operator + val tuple : [> `List of O.list_mode * [> `Lower ] ] list name + val type_variable : O.n_operator + val restricted_type_expression : O.n_hierarchy + val type_expression : O.n_hierarchy + val singletons : O.singleton list + *) + +end + +module Program : sig + + (* + val statement_name : string + val program : O.rule + val param_name : string + val param : O.rule + val type_annotation_name : string + val type_annotation : O.rule + val let_content_name : string + val let_content : O.rule + val statement : O.rule + val singletons : O.singleton list + *) + +end + +(* +val language : O.language +*) diff --git a/src/passes/1-parser/camligo/lex/generator.mli b/src/passes/1-parser/camligo/lex/generator.mli new file mode 100644 index 000000000..d08c6868a --- /dev/null +++ b/src/passes/1-parser/camligo/lex/generator.mli @@ -0,0 +1,43 @@ +(* +type pre_token = { + name : string ; + pattern : string ; +} + +val make : string -> string -> pre_token + +val keyword : string -> pre_token +val symbol : string -> string -> pre_token + +module Print_mly : sig +(* + open Format + val token : formatter -> pre_token -> unit + val tokens : formatter -> pre_token list -> unit +*) +end + +module Print_mll : sig +(* + open Format + + val pre : string + val post : string + + val token : formatter -> pre_token -> unit + val tokens : formatter -> pre_token list -> unit +*) +end + +module Print_ml : sig +(* + open Format + + val pre : string + val token : formatter -> pre_token -> unit + val tokens : formatter -> pre_token list -> unit +*) +end + +val tokens : pre_token list +*) diff --git a/src/passes/1-parser/camligo/location.mli b/src/passes/1-parser/camligo/location.mli new file mode 100644 index 000000000..f6bbb44d4 --- /dev/null +++ b/src/passes/1-parser/camligo/location.mli @@ -0,0 +1,20 @@ +(* +type file_location = { + filename : string ; + start_line : int ; + start_column : int ; + end_line : int ; + end_column : int ; +} + +type virtual_location = string + +type t = + | File of file_location + | Virtual of virtual_location + +val make : Lexing.position -> Lexing.position -> t + +val virtual_location : string -> t +val dummy : string +*) diff --git a/src/passes/1-parser/camligo/user.mli b/src/passes/1-parser/camligo/user.mli new file mode 100644 index 000000000..a3e14101a --- /dev/null +++ b/src/passes/1-parser/camligo/user.mli @@ -0,0 +1,3 @@ +open! Trace + +val parse_file : string -> Ast.entry_point result diff --git a/src/passes/2-simplify/ligodity.mli b/src/passes/2-simplify/ligodity.mli new file mode 100644 index 000000000..5a444d7b6 --- /dev/null +++ b/src/passes/2-simplify/ligodity.mli @@ -0,0 +1,63 @@ +[@@@warning "-45"] + +open Trace + +open Ast_simplified + +module Raw = Parser.Ligodity.AST +module SMap = Map.String +module Option = Simple_utils.Option + +(* +val nseq_to_list : 'a * 'a list -> 'a list +val npseq_to_list : 'a * ( 'b * 'a ) list -> 'a list +*) +val npseq_to_nelist : 'a * ( 'b * 'c ) list -> 'a * 'c list +(* +val pseq_to_list : ('a * ('b * 'a) list) option -> 'a list +val get_value : 'a Raw.reg -> 'a +*) + +module Errors : sig + (* + val wrong_pattern : string -> Raw.pattern -> unit -> error + val multiple_patterns : string -> Raw.pattern list -> unit -> error + val unknown_predefined_type : string Raw.reg -> unit -> error + val unsupported_arith_op : Raw.expr -> unit -> error + val unsupported_string_catenation : Raw.expr -> unit -> error + val untyped_fun_param : 'a Raw.reg -> unit -> error + val unsupported_tuple_pattern : Raw.pattern -> unit -> error + val unsupported_cst_constr : Raw.pattern -> unit -> error + val unsupported_non_var_pattern : Raw.pattern -> unit -> error + val simplifying_expr : Raw.expr -> unit -> error + val only_constructors : Raw.pattern -> unit -> error + val unsupported_sugared_lists : Raw.wild -> unit -> error + val bad_set_definition : unit -> error + val bad_list_definition : unit -> error + val bad_map_definition : unit -> error + val corner_case : loc:string -> string -> unit -> error + *) +end + + +(* +val r_split : 'a Raw.reg -> 'a * Location.t +val pattern_to_var : Raw.pattern -> Raw.variable result +val pattern_to_typed_var : Raw.pattern -> ( Raw.variable * Raw.type_expr option ) result +val expr_to_typed_expr : Raw.expr -> ( Raw.expr * Raw.type_expr option ) result +val patterns_to_var : Raw.pattern list -> Raw.variable result +val simpl_type_expression : Raw.type_expr -> type_expression result +val simpl_list_type_expression : Raw.type_expr list -> type_expression result +*) +val simpl_expression : Raw.expr -> expr result +(* +val simpl_fun : Raw.fun_expr Raw.reg -> expr result +val simpl_logic_expression : ?te_annot:type_expression -> Raw.logic_expr -> expr result +val simpl_list_expression : Raw.list_expr -> expression result +val simpl_binop : string -> Raw.wild Raw.bin_op Region.reg -> expression result +val simpl_unop : string -> Raw.wild Raw.un_op Region.reg -> expression result +val simpl_tuple_expression : ?loc:Location.t -> Raw.expr list -> expression result +val simpl_declaration : Raw.declaration -> declaration Location.wrap result +val simpl_cases : (Raw.pattern * 'a) list -> 'a matching result +*) +val simpl_program : Raw.ast -> program result diff --git a/src/passes/2-simplify/pascaligo.mli b/src/passes/2-simplify/pascaligo.mli new file mode 100644 index 000000000..0d22c29c6 --- /dev/null +++ b/src/passes/2-simplify/pascaligo.mli @@ -0,0 +1,82 @@ +open Trace +open Ast_simplified + +module Raw = Parser.Pascaligo.AST +module SMap = Map.String + +(* +val nseq_to_list : 'a * 'a list -> 'a list +val npseq_to_list : 'a * ( 'b * 'a ) list -> 'a list +*) +val npseq_to_nelist : 'a * ( 'b * 'c ) list -> 'a * 'c list +(* +val pseq_to_list : ('a * ('b * 'a) list) option -> 'a list +val get_value : 'a Raw.reg -> 'a +*) + +module Errors : sig + (* + val unsupported_cst_constr : Raw.pattern -> unit -> error + val unsupported_ass_None : Raw.wild -> unit -> error + val unsupported_entry_decl : 'a Raw.reg -> unit -> error + val unsupported_proc_decl : 'a Raw.reg -> unit -> error + *) + val bad_bytes : Location.t -> string -> unit -> error + (* + val unsupported_local_proc : Raw.wild -> unit -> error + val corner_case : loc:string -> string -> unit -> error + val unknown_predefined_type : string Raw.reg -> unit -> error + *) + val unsupported_arith_op : Raw.expr -> unit -> error + (* + val unsupported_string_catenation : Raw.expr -> unit -> error + val unsupported_set_expr : Raw.expr -> unit -> error + *) + val unsupported_proc_calls : 'a Raw.reg -> unit -> error + (* + val unsupported_for_loops : Raw.wild -> unit -> error + val unsupported_deep_map_assign : 'a Raw.reg -> unit -> error + val unsupported_empty_record_patch : 'a Raw.reg -> unit -> error + val unsupported_map_patches : 'a Raw.reg -> unit -> error + val unsupported_set_patches : 'a Raw.reg -> unit -> error + val unsupported_deep_map_rm : 'a Raw.reg -> unit -> error + val unsupported_set_removal : 'a Raw.reg -> unit -> error + val unsupported_non_var_pattern : Raw.pattern -> unit -> error + val only_constructors : Raw.pattern -> unit -> error + val unsupported_tuple_pattern : Raw.pattern -> unit -> error + val unsupported_deep_Some_patterns : Raw.pattern -> unit -> error + val unsupported_deep_list_patterns : 'a Raw.reg -> unit -> error + val unsupported_sub_blocks : 'a Raw.reg -> unit -> error + val simplifying_instruction : Raw.instruction -> unit -> error + *) +end + +(* +val r_split : 'a Raw.reg -> 'a * Location.t +val return : expr -> ( expr option -> expr result ) result +val return_let_in : ?loc:Location.t -> string * type_expression option -> expr -> ( expr option -> expr result ) result +val simpl_type_expression : Raw.type_expr -> type_expression result +val simpl_list_type_expression : Raw.type_expr list -> type_expression result +*) +val simpl_expression : Raw.expr -> expr result +(* +val simpl_logic_expression : Raw.logic_expr -> expression result +val simpl_list_expression : Raw.list_expr -> expression result +val simpl_set_expression : Raw.set_expr -> expression result +val simpl_binop : string -> Raw.wild Raw.bin_op Region.reg -> expression result +val simpl_unop : string -> Raw.wild Raw.un_op Region.reg -> expression result +val simpl_tuple_expression : ?loc:Location.t -> Raw.expr list -> expression result +val simpl_local_declaration : Raw.local_decl -> ( expr option -> expr result) result +val simpl_data_declaration : Raw.data_decl -> ( expr option -> expr result ) result +val simpl_param : Raw.param_decl -> (type_name * type_expression) result +val simpl_fun_declaration : loc:Location.t -> Raw.fun_decl -> ((name * type_expression option) * expression) result +val simpl_declaration : Raw.declaration -> declaration Location.wrap result +val simpl_single_instruction : Raw.single_instr -> (expression option -> expression result) result +val simpl_path : Raw.path -> string * Ast_simplified.access_path +val simpl_cases : (Raw.pattern * 'a) list -> 'a matching result +val simpl_instruction_block : Raw.instruction -> (expression option -> expression result) result +val simpl_instruction : Raw.instruction -> (expression option -> expression result) result +val simpl_statements : Raw.statements -> (expression option -> expression result) result +val simpl_block : Raw.block -> (expression option -> expression result) result +*) +val simpl_program : Raw.ast -> program result diff --git a/src/passes/4-typer/typer.mli b/src/passes/4-typer/typer.mli new file mode 100644 index 000000000..cd7c00012 --- /dev/null +++ b/src/passes/4-typer/typer.mli @@ -0,0 +1,53 @@ +open Trace + +module I = Ast_simplified +module O = Ast_typed + +module SMap = O.SMap +module Environment = O.Environment + +type environment = Environment.t + +module Errors : sig + (* + val unbound_type_variable : environment -> string -> unit -> error + val unbound_variable : environment -> string -> Location.t -> unit -> error + val match_empty_variant : 'a I.matching -> Location.t -> unit -> error + val match_missing_case : 'a I.matching -> Location.t -> unit -> error + val match_redundant_case : 'a I.matching -> Location.t -> unit -> error + val unbound_constructor : environment -> string -> Location.t -> unit -> error + val unrecognized_constant : string -> Location.t -> unit -> error + *) + val wrong_arity : string -> int -> int -> Location.t -> unit -> error + (* + val match_tuple_wrong_arity : 'a list -> 'b list -> Location.t -> unit -> error + + (* TODO: this should be a trace_info? *) + val program_error : I.program -> unit -> error + val constant_declaration_error : string -> I.expr -> O.type_value option -> unit -> error + val match_error : ?msg:string -> expected:'a I.matching -> actual:O.type_value -> Location.t -> unit -> error + val needs_annotation : I.expression -> string -> unit -> error + val type_error_approximate : ?msg:string -> expected:string -> actual:O.type_value -> expression:I.expression -> Location.t -> unit -> error + val type_error : ?msg:string -> expected:O.type_value -> actual:O.type_value -> expression:I.expression -> Location.t -> unit -> error + val bad_tuple_index : int -> I.expression -> O.type_value -> Location.t -> unit -> error + val bad_record_access : string -> I.expression -> O.type_value -> Location.t -> unit -> error + val not_supported_yet : string -> I.expression -> unit -> error + val not_supported_yet_untranspile : string -> O.expression -> unit -> error + val constant_error : Location.t -> O.type_value list -> O.type_value option -> unit -> error + *) +end + +val type_program : I.program -> O.program result +val type_declaration : environment -> I.declaration -> (environment * O.declaration option) result +val type_match : (environment -> 'i -> 'o result) -> environment -> O.type_value -> 'i I.matching -> I.expression -> Location.t -> 'o O.matching result +val evaluate_type : environment -> I.type_expression -> O.type_value result +val type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.annotated_expression result +val type_constant : string -> O.type_value list -> O.type_value option -> Location.t -> (string * O.type_value) result +(* +val untype_type_value : O.type_value -> (I.type_expression) result +val untype_literal : O.literal -> I.literal result +*) +val untype_expression : O.annotated_expression -> I.expression result +(* +val untype_matching : ('o -> 'i result) -> 'o O.matching -> ('i I.matching) result +*) diff --git a/src/passes/6-transpiler/transpiler.mli b/src/passes/6-transpiler/transpiler.mli new file mode 100644 index 000000000..60600ea53 --- /dev/null +++ b/src/passes/6-transpiler/transpiler.mli @@ -0,0 +1,59 @@ +open! Trace + +module AST = Ast_typed +module Append_tree = Tree.Append +open Mini_c + +val temp_unwrap_loc : 'a Location.wrap -> 'a +(* +val temp_unwrap_loc_list : AST.declaration Location.wrap list -> AST.declaration list +val list_of_map : 'a AST.type_name_map -> 'a list +val kv_list_of_map : 'a AST.type_name_map -> ( string * 'a ) list +val map_of_kv_list : ( string * 'a ) list -> 'a AST.type_name_map +*) + +module Errors : sig + (* + val corner_case : loc:string -> string -> unit -> error + val unrecognized_type_constant : string -> unit -> error + val row_loc : Location.t -> string * ( unit -> string ) + val unsupported_pattern_matching : string -> Location.t -> unit -> error + val unsupported_iterator : Location.t -> unit -> error + *) + val not_functional_main : Location.t -> unit -> error + val missing_entry_point : string -> unit -> error + val wrong_mini_c_value : string -> value -> unit -> error + val bad_untranspile : string -> value -> unit -> error + val unknown_untranspile : string -> value -> unit -> error +end + +(* +val translate_type : AST.type_value -> type_value result +val tuple_access_to_lr : type_value -> type_value list -> int -> (type_value * [`Left | `Right]) list result +val record_access_to_lr : type_value -> type_value AST.type_name_map -> string -> (type_value * [`Left | `Right]) list result +val translate_literal : AST.literal -> value +val transpile_environment_element_type : AST.environment_element -> type_value result +val transpile_small_environment : AST.small_environment -> Environment.t result +val transpile_environment : AST.full_environment -> Environment.t result +val tree_of_sum : AST.type_value -> (type_name * AST.type_value) Append_tree.t result +*) +val transpile_annotated_expression : AST.annotated_expression -> expression result +(* +val transpile_lambda_deep : Mini_c.Environment.t -> AST.lambda -> Mini_c.expression result +val transpile_lambda : Environment.t -> AST.lambda -> expression result +val transpile_declaration : environment -> AST.declaration -> toplevel_statement result +*) + +val transpile_program : AST.program -> program result +val check_storage : anon_function -> 'a -> Location.t -> (anon_function * 'a) result +(* +val translate_main : AST.lambda -> Location.t ->( anon_function * ( type_value * type_value )) result + +(* From an expression [expr], build the expression [fun () -> expr] *) +val translate_entry : AST.program -> string -> ( anon_function * ( type_value * type_value )) result +val functionalize : AST.annotated_expression -> AST.lambda * AST.type_value +*) +val extract_constructor : value -> ( string * AST.type_value ) Append_tree.t' -> (string * value * AST.type_value) result +val extract_tuple : value -> AST.type_value Append_tree.t' -> (value * AST.type_value) list result +val extract_record : value -> ( string * AST.type_value ) Append_tree.t' -> ( string * ( value * AST.type_value )) list result +val untranspile : value -> AST.type_value -> AST.annotated_expression result diff --git a/src/passes/8-compiler/compiler_environment.mli b/src/passes/8-compiler/compiler_environment.mli new file mode 100644 index 000000000..a82e6e48a --- /dev/null +++ b/src/passes/8-compiler/compiler_environment.mli @@ -0,0 +1,33 @@ +open Proto_alpha_utils +open Trace +open Mini_c +open Michelson + +(* +module Stack = Meta_michelson.Stack +*) +val empty: environment +val get : environment -> string -> michelson result +val set : environment -> string -> michelson result + +val pack_closure : environment -> selector -> michelson result +val unpack_closure : environment -> michelson result + +(* +val add : environment -> (string * type_value) -> michelson result +val select : ?rev:bool -> ?keep:bool -> environment -> string list -> michelson result + +val select_env : environment -> environment -> michelson result + +val clear : environment -> (michelson * environment) result + +val pack : environment -> michelson result + +val unpack : environment -> michelson result + +val pack_select : environment -> string list -> michelson result + +val add_packed_anon : environment -> type_value -> michelson result + +val pop : environment -> environment result +*) diff --git a/src/passes/8-compiler/compiler_program.mli b/src/passes/8-compiler/compiler_program.mli new file mode 100644 index 000000000..4d13bdf7d --- /dev/null +++ b/src/passes/8-compiler/compiler_program.mli @@ -0,0 +1,48 @@ +open Trace +open Mini_c + +open Michelson +open Memory_proto_alpha.Protocol.Script_ir_translator +open Operators.Compiler + +(* +module Contract_types = Meta_michelson.Types +module Stack = Meta_michelson.Stack +*) +type compiled_program = { + input : ex_ty ; + output : ex_ty ; + body : michelson ; +} + +val get_operator : string -> type_value -> expression list -> predicate result +val translate_expression : expression -> environment -> michelson result +val translate_function_body : anon_function -> environment_element list -> type_value -> michelson result +val translate_value : value -> type_value -> michelson result + +val translate_program : program -> string -> compiled_program result + +val translate_contract : anon_function -> (type_value * type_value ) -> michelson result + +val translate_entry : anon_function -> type_value * type_value -> compiled_program result + +(* + +open Operators.Compiler + +val get_predicate : string -> type_value -> expression list -> predicate result + +val translate_function : anon_function -> michelson result + +val translate_expression : ?push_var_name:string -> expression -> environment -> ( michelson * environment ) result + +val translate_quote_body : anon_function -> michelson result + +val get_main : program -> string -> anon_function result + + +module Errors : sig + val corner_case : loc:string -> string -> unit -> error +end + +*) diff --git a/src/passes/8-compiler/compiler_type.mli b/src/passes/8-compiler/compiler_type.mli new file mode 100644 index 000000000..ffa4760e2 --- /dev/null +++ b/src/passes/8-compiler/compiler_type.mli @@ -0,0 +1,95 @@ +open Trace +open Mini_c.Types +open Proto_alpha_utils.Memory_proto_alpha +open Protocol +open Script_ir_translator + +module O = Tezos_utils.Michelson +(* +module Contract_types = Meta_michelson.Types +*) + +module Ty : sig + + open Script_typed_ir + (* + open Script_int_repr + *) + (* + val nat_k : n num comparable_ty + val tez_k : Alpha_context.Tez.tez comparable_ty + val int_k : z num comparable_ty + val string_k : string comparable_ty + val address_k : Alpha_context.Contract.t comparable_ty + val timestamp_k : Alpha_context.Script_timestamp.t comparable_ty + val bytes_k : Tezos_protocol_environment_alpha__Environment.MBytes.t comparable_ty + (* val timestamp_k = Timestamp_key None *) +*) +(* + val unit : unit ty + val bytes : Tezos_protocol_environment_alpha__Environment.MBytes.t ty + val nat : n num ty + val tez : Alpha_context.Tez.tez ty + val int : z num ty + *) + val big_map : 'a comparable_ty -> 'b ty -> ( 'a , 'b ) big_map ty + val signature : Alpha_context.signature ty + (* + val operation : Alpha_context.packed_internal_operation ty + val bool : bool ty + *) + val mutez : Alpha_context.Tez.tez ty + (* + val string : string ty + *) + val key : Alpha_context.public_key ty + (* + val list : 'a ty -> 'a list ty + val set : 'a comparable_ty -> 'a set ty + val address : Alpha_context.Contract.t ty + val option : 'a ty -> 'a option ty + val contract : 'a ty -> 'a typed_contract ty + val lambda : 'a ty -> 'b ty -> ( 'a , 'b ) lambda ty + val timestamp : Alpha_context.Script_timestamp.t ty + val map : 'a comparable_ty -> 'b ty -> ( 'a , 'b ) map ty + val pair : 'a ty -> 'b ty -> ('a , 'b ) pair ty + *) + val union : 'a ty -> 'b ty -> ( 'a , 'b ) union ty + (* + val not_comparable : string -> unit -> error + val not_compilable_type : string -> unit -> error + + val comparable_type_base : type_base -> ex_comparable_ty result + val comparable_type : type_value -> ex_comparable_ty result + val base_type : type_base -> ex_ty result + *) + val type_ : type_value -> ex_ty result + + val environment_representation : environment -> ex_ty result + + val environment : environment -> ex_stack_ty result + (* + val not_comparable : string -> unit -> error + val not_compilable_type : string -> unit -> error + + val comparable_type_base : type_base -> ex_comparable_ty result + + val comparable_type : type_value -> ex_comparable_ty result + + val base_type : type_base -> ex_ty result + + *) +end + +val type_ : type_value -> O.t result + +val environment_element : string * type_value -> (int, O.prim) Tezos_micheline.Micheline.node result + +val environment : ( 'a * type_value ) list -> O.t list result +val lambda_closure : environment * type_value * type_value -> (int, O.prim) Tezos_micheline.Micheline.node result + +val environment_closure : environment -> (int , O.prim ) Tezos_micheline.Micheline.node result +(* +val base_type : type_base -> O.michelson result + +*) diff --git a/src/passes/8-compiler/uncompiler.mli b/src/passes/8-compiler/uncompiler.mli new file mode 100644 index 000000000..d8b07a19d --- /dev/null +++ b/src/passes/8-compiler/uncompiler.mli @@ -0,0 +1,6 @@ +open Mini_c.Types +open Proto_alpha_utils.Memory_proto_alpha +open X +open Proto_alpha_utils.Trace + +val translate_value : ?bm_opt:value -> ex_typed_value -> value result diff --git a/src/passes/operators/helpers.mli b/src/passes/operators/helpers.mli new file mode 100644 index 000000000..63b9b49c6 --- /dev/null +++ b/src/passes/operators/helpers.mli @@ -0,0 +1,77 @@ +module Typer : sig + open Trace + open Ast_typed + + module Errors : sig + val wrong_param_number : name -> int -> 'a list -> unit -> error + val error_uncomparable_types : type_value -> type_value -> unit -> error + end + + type type_result = string * type_value + type typer' = type_value list -> type_value option -> type_result result + type typer = string * typer' + + (* + val typer'_0 : name -> (type_value option -> type_value result) -> typer' + *) + val typer_0 : name -> ( type_value option -> type_value result ) -> typer + (* + val typer'_1 : name -> (type_value -> type_value result) -> typer' + *) + val typer_1 : name -> (type_value -> type_value result) -> typer + (* + val typer'_1_opt : name -> (type_value -> type_value option -> type_value result) -> typer' + *) + val typer_1_opt : name -> (type_value -> type_value option -> type_value result) -> typer + (* + val typer'_2 : name -> (type_value -> type_value -> type_value result) -> typer' + *) + val typer_2 : name -> (type_value -> type_value -> type_value result) -> typer + (* + val typer'_3 : name -> (type_value -> type_value -> type_value -> type_value result) -> typer' + *) + val typer_3 : name -> (type_value -> type_value -> type_value -> type_value result) -> typer + (* + val typer'_4 : name -> (type_value -> type_value -> type_value -> type_value -> type_value result) -> typer' + *) + val typer_4 : name -> (type_value -> type_value -> type_value -> type_value -> type_value result) -> typer + (* + val typer'_5 : name -> (type_value -> type_value -> type_value -> type_value -> type_value -> type_value result) -> typer' + *) + val typer_5 : name -> (type_value -> type_value -> type_value -> type_value -> type_value -> type_value result) -> typer + (* + val typer'_6 : name -> (type_value -> type_value -> type_value -> type_value -> type_value -> type_value -> type_value result) -> typer' + *) + val typer_6 : name -> (type_value -> type_value -> type_value -> type_value -> type_value -> type_value -> type_value result) -> typer + + val constant : name -> type_value -> typer + + val eq_1 : type_value -> type_value -> bool + val eq_2 : ( type_value * type_value ) -> type_value -> bool + val assert_eq_1 : ?msg:string -> type_value -> type_value -> unit result + + val comparator : name -> typer + val boolean_operator_2 : name -> typer + +end + +module Compiler : sig + open Tezos_utils.Michelson + + type predicate = + | Constant of michelson + | Unary of michelson + | Binary of michelson + | Ternary of michelson + | Tetrary of michelson + | Pentary of michelson + | Hexary of michelson + val simple_constant : t -> predicate + val simple_unary : t -> predicate + val simple_binary : t -> predicate + val simple_ternary : t -> predicate + val simple_tetrary : t -> predicate + val simple_pentary : t -> predicate + val simple_hexary : t -> predicate + +end diff --git a/src/passes/operators/operators.mli b/src/passes/operators/operators.mli new file mode 100644 index 000000000..2224cc74e --- /dev/null +++ b/src/passes/operators/operators.mli @@ -0,0 +1,129 @@ + +module Simplify : sig + + module Pascaligo : sig + val constants : ( string * string ) list + val type_constants : ( string * string ) list + end + + module Camligo : sig + val constants : ( string * string ) list + val type_constants : ( string * string ) list + end + + module Ligodity : sig + val constants : ( string * string ) list + val type_constants : ( string * string ) list + end + +end + +module Typer : sig + open Helpers.Typer + open Ast_typed + + (* + val none : typer + val set_empty : typer + val sub : typer + val some : typer + val map_remove : typer + val map_add : typer + val map_update : typer + val map_mem : typer + val map_find : typer + *) + val map_find_opt : typer + (* + val map_iter : typer + val map_map : typer + val map_fold : typer + val big_map_remove : typer + val big_map_add : typer + val big_map_update : typer + val big_map_mem : typer + val big_map_find : typer + val size : typer + val slice : typer + val failwith_ : typer + val get_force : typer + val int : typer + val bytes_pack : typer + val bytes_unpack : typer + val hash256 : typer + val hash512 : typer + val blake2b : typer + val hash_key : typer + val check_signature : typer + val sender : typer + val source : typer + val unit : typer + val amount : typer + *) + val balance : typer + (* + val address : typer + val now : typer + val transaction : typer + *) + val originate : typer + (* + val get_contract : typer + *) + val set_delegate : typer + (* + val abs : typer + val neg : typer + val assertion : typer + val times : typer + val div : typer + val mod_ : typer + val add : typer + val set_mem : typer + val set_add : typer + val set_remove : typer + val set_iter : typer + val list_iter : typer + val list_map : typer + val not_ : typer + val or_ : typer + val xor : typer + val and_ : typer + *) + val lsl_ : typer + val lsr_ : typer + (* + val concat : typer + *) + val cons : typer + val constant_typers : typer' type_name_map + +end + +module Compiler : sig + (* + include Helpers.Compiler + *) + open Tezos_utils.Michelson + + type predicate = + | Constant of michelson + | Unary of michelson + | Binary of michelson + | Ternary of michelson + | Tetrary of michelson + | Pentary of michelson + | Hexary of michelson + val operators : predicate Map.String.t + val simple_constant : t -> predicate + val simple_unary : t -> predicate + val simple_binary : t -> predicate + val simple_ternary : t -> predicate + val simple_tetrary : t -> predicate + val simple_pentary : t -> predicate + val simple_hexary : t -> predicate + +(* + val predicates : predicate Map.String.t +*) +end diff --git a/src/rope/rope_test.mli b/src/rope/rope_test.mli new file mode 100644 index 000000000..d946fb7e2 --- /dev/null +++ b/src/rope/rope_test.mli @@ -0,0 +1,19 @@ +module A = struct + (* + open Rope + + val _ : unit + *) +end + +module B = struct + (* + open Rope_top_level_open + + (* type foo = S | NotCaptured *) + (* let d = NotCaptured *) + (* let s = NotCaptured *) + + val _ : unit + *) +end diff --git a/src/stages/ast_simplified/PP.mli b/src/stages/ast_simplified/PP.mli new file mode 100644 index 000000000..4a08aaf28 --- /dev/null +++ b/src/stages/ast_simplified/PP.mli @@ -0,0 +1,44 @@ +open Types +open Format + +(* +val list_sep_d : (formatter -> 'a -> unit) -> formatter -> 'a list -> unit + +val smap_sep_d : (formatter -> 'a -> unit) -> formatter -> 'a Map.String.t -> unit + +val type_expression : formatter -> type_expression -> unit +*) + +val literal : formatter -> literal -> unit + +val expression : formatter -> expression -> unit +(* +val option_type_name : formatter -> string * type_expression option -> unit +val assoc_expression : formatter -> (expr * expr) -> unit + +val access : formatter -> access -> unit + +val access_path : formatter -> access_path -> unit +*) + +val type_annotation : formatter -> type_expression option -> unit +val single_record_patch : formatter -> string * expr -> unit + +val single_tuple_patch : formatter -> int * expr -> unit +(* + +val matching_variant_case : (formatter -> 'a -> unit) -> formatter -> (constructor_name * name) * 'a -> unit + +val matching : (formatter -> 'a -> unit) -> formatter -> 'a matching -> unit +*) + +(* Shows the type expected for the matched value *) +val matching_type : formatter -> 'a matching -> unit + +(* +val matching_variant_case_type : formatter -> ( ( constructor_name * name) * 'a) -> unit + +val declaration : formatter -> declaration -> unit + +*) +val program : formatter -> program -> unit diff --git a/src/stages/ast_simplified/combinators.mli b/src/stages/ast_simplified/combinators.mli new file mode 100644 index 000000000..a5cc91887 --- /dev/null +++ b/src/stages/ast_simplified/combinators.mli @@ -0,0 +1,124 @@ +open Types +open Simple_utils.Trace +(* +module Option = Simple_utils.Option + +module SMap = Map.String + +module Errors : sig + val bad_kind : name -> Location.t -> unit -> error +end +*) +val t_bool : type_expression +val t_string : type_expression +val t_bytes : type_expression +val t_int : type_expression +val t_operation : type_expression +val t_nat : type_expression +val t_tez : type_expression +val t_unit : type_expression +val t_address : type_expression +(* +val t_option : type_expression -> type_expression +*) +val t_list : type_expression -> type_expression +val t_variable : type_name -> type_expression +(* +val t_tuple : type_expression list -> type_expression +val t_record : te_map -> type_expression +*) +val t_pair : ( type_expression * type_expression ) -> type_expression + +val t_record_ez : (string * type_expression) list -> type_expression + +val t_sum : te_map -> type_expression +val ez_t_sum : ( string * type_expression ) list -> type_expression + +val t_function : type_expression -> type_expression -> type_expression +val t_map : type_expression -> type_expression -> type_expression +(* +val t_set : type_expression -> type_expression + +val make_name : string -> name + +*) +val e_var : ?loc:Location.t -> string -> expression +val e_literal : ?loc:Location.t -> literal -> expression +val e_unit : ?loc:Location.t -> unit -> expression +val e_int : ?loc:Location.t -> int -> expression +val e_nat : ?loc:Location.t -> int -> expression +val e_timestamp : ?loc:Location.t -> int -> expression +val e_bool : ?loc:Location.t -> bool -> expression +val e_string : ?loc:Location.t -> string -> expression +val e_address : ?loc:Location.t -> string -> expression +val e_mutez : ?loc:Location.t -> int -> expression +val e'_bytes : string -> expression' result +val e_bytes : ?loc:Location.t -> string -> expression result +val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression +(* +val e_record : ?loc:Location.t -> ( expr * expr ) list -> expression +*) +val e_tuple : ?loc:Location.t -> expression list -> expression +val e_some : ?loc:Location.t -> expression -> expression +val e_none : ?loc:Location.t -> unit -> expression +val e_map_add : ?loc:Location.t -> expression -> expression -> expression -> expression +val e_map : ?loc:Location.t -> ( expression * expression ) list -> expression +val e_set : ?loc:Location.t -> expression list -> expression +val e_list : ?loc:Location.t -> expression list -> expression +val e_pair : ?loc:Location.t -> expression -> expression -> expression +val e_constructor : ?loc:Location.t -> name -> expression -> expression +val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression +val e_matching_bool : ?loc:Location.t -> expression -> expression -> expression -> expression +val e_accessor : ?loc:Location.t -> expression -> access_path -> expression +val e_accessor_props : ?loc:Location.t -> expression -> name list -> expression +val e_variable : ?loc:Location.t -> name -> expression +val e_skip : ?loc:Location.t -> unit -> expression +val e_loop : ?loc:Location.t -> expression -> expression -> expression +val e_sequence : ?loc:Location.t -> expression -> expression -> expression +val e_let_in : ?loc:Location.t -> ( name * type_expression option ) -> expression -> expression -> expression +val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression +val e_application : ?loc:Location.t -> expression -> expression -> expression +val e_binop : ?loc:Location.t -> name -> expression -> expression -> expression +val e_constant : ?loc:Location.t -> name -> expression list -> expression +val e_look_up : ?loc:Location.t -> expression -> expression -> expression +val e_assign : ?loc:Location.t -> name -> access_path -> expression -> expression + +val make_option_typed : ?loc:Location.t -> expression -> type_expression option -> expression +val ez_e_record : ?loc:Location.t -> ( string * expression ) list -> expression + +val e_typed_none : ?loc:Location.t -> type_expression -> expression + +val e_typed_list : ?loc:Location.t -> expression list -> type_expression -> expression + +val e_typed_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression +val e_typed_big_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression + +val e_typed_set : ?loc:Location.t -> expression list -> type_expression -> expression + +val e_lambda : ?loc:Location.t -> string -> type_expression option -> type_expression option -> expression -> expression +val e_record : ?loc:Location.t -> expr_map -> expression + +val e_ez_record : ?loc:Location.t -> ( string * expr ) list -> expression +(* +val get_e_accessor : expression' -> ( expression * access_path ) result +*) + +val assert_e_accessor : expression' -> unit result + +val get_access_record : access -> string result + +val get_e_pair : expression' -> ( expression * expression ) result + +val get_e_list : expression' -> ( expression list ) result +val get_e_tuple : expression' -> ( expression list ) result +(* +val get_e_failwith : expression -> expression result +val is_e_failwith : expression -> bool +*) +val extract_pair : expression -> ( expression * expression ) result + +val extract_list : expression -> (expression list) result + +val extract_record : expression -> (string * expression) list result + +val extract_map : expression -> (expression * expression) list result diff --git a/src/stages/ast_simplified/misc.mli b/src/stages/ast_simplified/misc.mli new file mode 100644 index 000000000..efafd75e6 --- /dev/null +++ b/src/stages/ast_simplified/misc.mli @@ -0,0 +1,18 @@ +open Trace +open Types +(* + +module Errors : sig + val different_literals_because_different_types : name -> literal -> literal -> unit -> error + + val different_literals : name -> literal -> literal -> unit -> error + + val error_uncomparable_literals : name -> literal -> literal -> unit -> error +end + +val assert_literal_eq : ( literal * literal ) -> unit result +*) + +val assert_value_eq : ( expression * expression ) -> unit result + +val is_value_eq : ( expression * expression ) -> bool diff --git a/src/stages/ast_typed/PP.mli b/src/stages/ast_typed/PP.mli new file mode 100644 index 000000000..0d9d1a62c --- /dev/null +++ b/src/stages/ast_typed/PP.mli @@ -0,0 +1,33 @@ +open Types +open Format + +val value : formatter -> annotated_expression -> unit + +val type_value : formatter -> type_value -> unit + +val single_record_patch : formatter -> ( string * ae ) -> unit + +val program : formatter -> program -> unit + +val expression : formatter -> expression -> unit + +val literal : formatter -> literal -> unit + +val annotated_expression : formatter -> annotated_expression -> unit + +(* +val list_sep_d : ( formatter -> 'a -> unit ) -> formatter -> 'a list -> unit +val smap_sep_d : ( formatter -> 'a -> unit ) -> formatter -> 'a Map.String.t -> unit + +val lambda : formatter -> lambda -> unit + +val assoc_annotated_expression : formatter -> (ae * ae) -> unit + +val matching_variant_case : ( formatter -> 'a -> unit ) -> formatter -> ( constructor_name * name ) * 'a -> unit + +val matching : ( formatter -> 'a -> unit ) -> formatter -> 'a matching -> unit + +val pre_access : formatter -> access -> unit + +val declaration : formatter -> declaration -> unit +*) diff --git a/src/stages/ast_typed/combinators.mli b/src/stages/ast_typed/combinators.mli new file mode 100644 index 000000000..082293b76 --- /dev/null +++ b/src/stages/ast_typed/combinators.mli @@ -0,0 +1,152 @@ +open Trace +open Types + +val make_n_e : name -> annotated_expression -> named_expression +val make_n_t : name -> type_value -> named_type_value +val make_t : type_value' -> S.type_expression option -> type_value +val make_a_e : ?location:Location.t -> expression -> type_value -> full_environment -> annotated_expression + +val t_bool : ?s:S.type_expression -> unit -> type_value +val t_string : ?s:S.type_expression -> unit -> type_value +val t_bytes : ?s:S.type_expression -> unit -> type_value +val t_key : ?s:S.type_expression -> unit -> type_value +val t_key_hash : ?s:S.type_expression -> unit -> type_value +val t_operation : ?s:S.type_expression -> unit -> type_value +val t_timestamp : ?s:S.type_expression -> unit -> type_value +val t_set : type_value -> ?s:S.type_expression -> unit -> type_value +val t_contract : type_value -> ?s:S.type_expression -> unit -> type_value +val t_int : ?s:S.type_expression -> unit -> type_value +val t_nat : ?s:S.type_expression -> unit -> type_value +val t_tez : ?s:S.type_expression -> unit -> type_value +val t_address : ?s:S.type_expression -> unit -> type_value +val t_unit : ?s:S.type_expression -> unit -> type_value +val t_option : type_value -> ?s:S.type_expression -> unit -> type_value +val t_pair : type_value -> type_value -> ?s:S.type_expression -> unit -> type_value +val t_list : type_value -> ?s:S.type_expression -> unit -> type_value +val t_tuple : type_value list -> ?s:S.type_expression -> unit -> type_value +val t_record : tv_map -> ?s:S.type_expression -> unit -> type_value +val make_t_ez_record : (string * type_value) list -> type_value +(* +val ez_t_record : ( string * type_value ) list -> ?s:S.type_expression -> unit -> type_value +*) + +val t_map : type_value -> type_value -> ?s:S.type_expression -> unit -> type_value +val t_big_map : type_value -> type_value -> ?s:S.type_expression -> unit -> type_value +val t_sum : tv_map -> ?s:S.type_expression -> unit -> type_value +val make_t_ez_sum : ( string * type_value ) list -> type_value +val t_function : type_value -> type_value -> ?s:S.type_expression -> unit -> type_value +val t_shallow_closure : type_value -> type_value -> ?s:S.type_expression -> unit -> type_value +val get_type_annotation : annotated_expression -> type_value +val get_type' : type_value -> type_value' +val get_environment : annotated_expression -> full_environment +val get_expression : annotated_expression -> expression +val get_lambda : expression -> lambda result +val get_lambda_with_type : annotated_expression -> (lambda * ( tv * tv) ) result +val get_t_bool : type_value -> unit result +(* +val get_t_int : type_value -> unit result +val get_t_nat : type_value -> unit result +val get_t_unit : type_value -> unit result +val get_t_tez : type_value -> unit result +val get_t_bytes : type_value -> unit result +val get_t_string : type_value -> unit result +*) +val get_t_contract : type_value -> type_value result +val get_t_option : type_value -> type_value result +val get_t_list : type_value -> type_value result +val get_t_set : type_value -> type_value result +(* +val get_t_key : type_value -> unit result +val get_t_signature : type_value -> unit result +val get_t_key_hash : type_value -> unit result +*) +val get_t_tuple : type_value -> type_value list result +val get_t_pair : type_value -> ( type_value * type_value ) result +val get_t_function : type_value -> ( type_value * type_value ) result +val get_t_sum : type_value -> type_value SMap.t result +val get_t_record : type_value -> type_value SMap.t result +val get_t_map : type_value -> ( type_value * type_value ) result +val get_t_big_map : type_value -> ( type_value * type_value ) result +val get_t_map_key : type_value -> type_value result +val get_t_map_value : type_value -> type_value result +val get_t_big_map_key : type_value -> type_value result +val get_t_big_map_value : type_value -> type_value result + +val assert_t_map : type_value -> unit result + +val is_t_map : type_value -> bool +val is_t_big_map : type_value -> bool + +val assert_t_tez : type_value -> unit result +val assert_t_key : type_value -> unit result +val assert_t_signature : type_value -> unit result +val assert_t_key_hash : type_value -> unit result + +val assert_t_list : type_value -> unit result + +val is_t_list : type_value -> bool +val is_t_set : type_value -> bool +val is_t_nat : type_value -> bool +val is_t_string : type_value -> bool +val is_t_bytes : type_value -> bool +val is_t_int : type_value -> bool + +val assert_t_bytes : type_value -> unit result +(* +val assert_t_operation : type_value -> unit result +*) +val assert_t_list_operation : type_value -> unit result +val assert_t_int : type_value -> unit result +val assert_t_nat : type_value -> unit result +val assert_t_bool : type_value -> unit result +val assert_t_unit : type_value -> unit result +(* +val e_record : ae_map -> expression +val ez_e_record : ( string * annotated_expression ) list -> expression + +val e_some : value -> expression +val e_none : expression +val e_map : ( value * value ) list -> expression +val e_unit : expression +val e_int : int -> expression +val e_nat : int -> expression +val e_tez : int -> expression +val e_bool : bool -> expression +val e_string : string -> expression +*) +val e_address : string -> expression +val e_operation : Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation -> expression +(* +val e_lambda : lambda -> expression +val e_pair : value -> value -> expression +val e_application : value -> value -> expression +val e_variable : name -> expression +val e_list : value list -> expression +val e_let_in : string -> value -> value -> expression +*) + +val e_a_unit : full_environment -> annotated_expression +val e_a_int : int -> full_environment -> annotated_expression +val e_a_nat : int -> full_environment -> annotated_expression +val e_a_mutez : int -> full_environment -> annotated_expression +val e_a_bool : bool -> full_environment -> annotated_expression +val e_a_string : string -> full_environment -> annotated_expression +val e_a_address : string -> full_environment -> annotated_expression +val e_a_pair : annotated_expression -> annotated_expression -> full_environment -> annotated_expression +val e_a_some : annotated_expression -> full_environment -> annotated_expression +val e_a_lambda : lambda -> tv -> tv -> full_environment -> annotated_expression +val e_a_none : type_value -> full_environment -> annotated_expression +val e_a_tuple : annotated_expression list -> full_environment -> annotated_expression +val e_a_record : ae_map -> full_environment -> annotated_expression +val e_a_application : annotated_expression -> annotated_expression -> full_environment -> annotated_expression +val e_a_variable : name -> type_value -> full_environment -> annotated_expression +val ez_e_a_record : ( name * annotated_expression ) list -> full_environment -> annotated_expression +val e_a_map : ( annotated_expression * annotated_expression ) list -> type_value -> type_value -> full_environment -> annotated_expression +val e_a_list : annotated_expression list -> type_value -> full_environment -> annotated_expression +val e_a_let_in : name -> annotated_expression -> annotated_expression -> full_environment -> annotated_expression + +val get_a_int : annotated_expression -> int result +val get_a_unit : annotated_expression -> unit result +val get_a_bool : annotated_expression -> bool result +val get_a_record_accessor : annotated_expression -> (annotated_expression * name) result +val get_declaration_by_name : program -> string -> declaration result diff --git a/src/stages/ast_typed/combinators_environment.mli b/src/stages/ast_typed/combinators_environment.mli new file mode 100644 index 000000000..5c327cddd --- /dev/null +++ b/src/stages/ast_typed/combinators_environment.mli @@ -0,0 +1,22 @@ +open Types + +val make_a_e_empty : expression -> type_value -> annotated_expression + +val e_a_empty_unit : annotated_expression +val e_a_empty_int : int -> annotated_expression +val e_a_empty_nat : int -> annotated_expression +val e_a_empty_mutez : int -> annotated_expression +val e_a_empty_bool : bool -> annotated_expression +val e_a_empty_string : string -> annotated_expression +val e_a_empty_address : string -> annotated_expression +val e_a_empty_pair : annotated_expression -> annotated_expression -> annotated_expression +val e_a_empty_some : annotated_expression -> annotated_expression +val e_a_empty_none : type_value -> annotated_expression +val e_a_empty_tuple : annotated_expression list -> annotated_expression +val e_a_empty_record : ae_map -> annotated_expression +val e_a_empty_map : (annotated_expression * annotated_expression ) list -> type_value -> type_value -> annotated_expression +val e_a_empty_list : annotated_expression list -> type_value -> annotated_expression +val ez_e_a_empty_record : ( name * annotated_expression ) list -> annotated_expression +val e_a_empty_lambda : lambda -> tv -> tv -> annotated_expression + +val env_sum_type : ?env:full_environment -> ?name:name -> (name * type_value) list -> full_environment diff --git a/src/stages/ast_typed/environment.mli b/src/stages/ast_typed/environment.mli new file mode 100644 index 000000000..bdd6c16d8 --- /dev/null +++ b/src/stages/ast_typed/environment.mli @@ -0,0 +1,62 @@ +open Types +open Trace + +type t = full_environment +type element = environment_element + +val get_trace : string -> t -> element result +val empty : environment +val full_empty : t +val add : string -> element -> t -> t +val add_ez_binder : string -> type_value -> t -> t +val add_ez_declaration : string -> annotated_expression -> t -> t +val add_ez_ae : string -> annotated_expression -> t -> t +val add_type : string -> type_value -> t -> t +val get_opt : string -> t -> element option +val get_type_opt : string -> t -> type_value option +val get_constructor : string -> t -> (type_value * type_value) option + +module Small : sig + type t = small_environment + val get_environment : t -> environment +(* + + val empty : t + + val get_type_environment : t -> type_environment + val map_environment : ( environment -> environment ) -> t -> t + val map_type_environment : ( type_environment -> type_environment ) -> t -> t + + val add : string -> element -> t -> t + val add_type : string -> type_value -> t -> t + val get_opt : string -> t -> element option + val get_type_opt : string -> t -> type_value option + *) +end +(* + +val make_element : type_value -> full_environment -> environment_element_definition -> element +val make_element_binder : type_value -> full_environment -> element +val make_element_declaration : full_environment -> annotated_expression -> element +*) + + + +module PP : sig + open Format + + val list_sep_scope : (formatter -> 'a -> unit) -> formatter -> 'a list -> unit + val full_environment : formatter -> full_environment -> unit +(* + val environment_element : formatter -> ( string * environment_element ) -> unit + + val type_environment_element : formatter -> ( string * type_value ) -> unit + + val environment : formatter -> environment -> unit + + val type_environment : formatter -> type_environment -> unit + + val small_environment : formatter -> small_environment -> unit + + *) +end diff --git a/src/stages/ast_typed/misc.mli b/src/stages/ast_typed/misc.mli new file mode 100644 index 000000000..3324c22fb --- /dev/null +++ b/src/stages/ast_typed/misc.mli @@ -0,0 +1,70 @@ +open Trace +open Types + +val assert_value_eq : ( value * value ) -> unit result + +val assert_type_value_eq : ( type_value * type_value ) -> unit result + +val merge_annotation : type_value option -> type_value option -> error_thunk -> type_value result + +(* No information about what made it fail *) +val type_value_eq : ( type_value * type_value ) -> bool + +module Free_variables : sig + type bindings = string list + + val matching_expression : bindings -> matching_expr -> bindings + val lambda : bindings -> lambda -> bindings + + val annotated_expression : bindings -> annotated_expression -> bindings + + val empty : bindings + val singleton : string -> bindings + +(* + val mem : string -> bindings -> bool + val union : bindings -> bindings -> bindings + val unions : bindings list -> bindings + val of_list : string list -> bindings + + val expression : bindings -> expression -> bindings + + val matching_variant_case : (bindings -> 'a -> bindings) -> bindings -> ((constructor_name * name) * 'a) -> bindings + + val matching : (bindings -> 'a -> bindings) -> bindings -> 'a matching -> bindings + + *) +end + +module Errors : sig + (* + val different_kinds : type_value -> type_value -> unit -> error + val different_constants : string -> string -> unit -> error + val different_size_type : name -> type_value -> type_value -> unit -> error + val different_props_in_record : string -> string -> unit -> error + val different_size_constants : type_value -> type_value -> unit -> error + val different_size_tuples : type_value -> type_value -> unit -> error + val different_size_sums : type_value -> type_value -> unit -> error + val different_size_records : type_value -> type_value -> unit -> error + val different_types : name -> type_value -> type_value -> unit -> error + val different_literals : name -> literal -> literal -> unit -> error + val different_values : name -> value -> value -> unit -> error + val different_literals_because_different_types : name -> literal -> literal -> unit -> error + val different_values_because_different_types : name -> value -> value -> unit -> error + val error_uncomparable_literals : name -> literal -> literal -> unit -> error + val error_uncomparable_values : name -> value -> value -> unit -> error + val different_size_values : name -> value -> value -> unit -> error + val missing_key_in_record_value : string -> unit -> error + *) + val not_functional_main : Location.t -> unit -> error +end + + + + +(* +val assert_literal_eq : ( literal * literal ) -> unit result +*) + +val get_entry : program -> string -> annotated_expression result +val program_environment : program -> full_environment diff --git a/src/stages/ast_typed/misc_smart.mli b/src/stages/ast_typed/misc_smart.mli new file mode 100644 index 000000000..249ddc893 --- /dev/null +++ b/src/stages/ast_typed/misc_smart.mli @@ -0,0 +1,25 @@ +open Trace +open Types + +val program_to_main : program -> string -> lambda result + +module Captured_variables : sig + + type bindings = string list + val matching : (bindings -> 'a -> bindings result) -> bindings -> 'a matching -> bindings result + + val matching_expression : bindings -> matching_expr -> bindings result + + val mem : string -> bindings -> bool +(* + val singleton : string -> bindings + val union : bindings -> bindings -> bindings + val unions : bindings list -> bindings + val empty : bindings + val of_list : string list -> bindings + + val annotated_expression : bindings -> annotated_expression -> bindings result + val matching_variant_case : (bindings -> 'a -> bindings result) -> bindings -> ((constructor_name * name) * 'a) -> bindings result + +*) +end diff --git a/src/stages/mini_c/PP.mli b/src/stages/mini_c/PP.mli new file mode 100644 index 000000000..e59300cc7 --- /dev/null +++ b/src/stages/mini_c/PP.mli @@ -0,0 +1,32 @@ +open Types +open Format + +(* +val list_sep_d : ( formatter -> 'a -> unit ) -> formatter -> 'a list -> unit +val space_sep : formatter -> unit -> unit +val lr : formatter -> [< `Left ] -> unit +val type_base : formatter -> type_base -> unit +*) + +val type_ : formatter -> type_value -> unit +val environment_element : formatter -> environment_element -> unit +val environment : formatter -> environment -> unit +val value : formatter -> value -> unit + +(* +val value_assoc : formatter -> (value * value) -> unit +*) +val expression' : formatter -> expression' -> unit + +val expression : formatter -> expression -> unit +val expression_with_type : formatter -> expression -> unit +val function_ : formatter -> anon_function -> unit + +(* +val assignment : formatter -> assignment -> unit +*) +val declaration : formatter -> assignment -> unit +(* +val tl_statement : formatter -> assignment * 'a -> unit +*) +val program : formatter -> program -> unit diff --git a/src/stages/mini_c/combinators.mli b/src/stages/mini_c/combinators.mli new file mode 100644 index 000000000..7005b2c7e --- /dev/null +++ b/src/stages/mini_c/combinators.mli @@ -0,0 +1,85 @@ +open Trace +open Types + +module Expression : sig + type t' = expression' + type t = expression + + val get_content : t -> t' + val get_type : t -> type_value + (* + val is_toplevel : t -> bool +*) + val make : t' -> type_value -> t + val make_tpl : t' * type_value -> t + + val pair : t -> t -> t' +end + +val get_bool : value ->bool result +val get_int : value -> int result +val get_nat : value -> int result +val get_mutez : value -> int result +val get_timestamp : value -> int result +val get_string : value -> string result +val get_bytes : value -> bytes result +val get_unit : value -> unit result +val get_option : value -> value option result +val get_map : value -> ( value * value ) list result +val get_big_map : value -> ( value * value ) list result +val get_list : value -> value list result +val get_set : value -> value list result +val get_function_with_ty : expression -> ( anon_function * ( type_value * type_value) ) result +val get_function : expression -> value result +val get_t_function : type_value -> ( type_value * type_value ) result +val get_t_closure : type_value -> ( environment * type_value * type_value ) result +val get_t_option : type_value -> type_value result +val get_pair : value -> ( value * value ) result +val get_t_pair : type_value -> ( type_value * type_value ) result +val get_t_or : type_value -> ( type_value * type_value ) result +val get_t_map : type_value -> ( type_value * type_value ) result +val get_t_big_map : type_value -> ( type_value * type_value ) result +val get_t_list : type_value -> type_value result +val get_t_set : type_value -> type_value result +val get_left : value -> value result +val get_right : value -> value result +val get_or : value -> ( bool * value ) result +(* +val wrong_type : string -> type_value -> unit -> error +*) +val get_t_left : type_value -> type_value result +val get_t_right : type_value -> type_value result +val get_t_contract : type_value -> type_value result +val get_t_operation : type_value -> unit result +val get_operation : value -> Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation result + +val t_int : type_value +val t_unit : type_value +val t_nat : type_value +val t_function : type_value -> type_value -> type_value +val t_deep_closure : environment -> type_value -> type_value -> type_value +val t_pair : type_value annotated -> type_value annotated -> type_value +val t_union : type_value annotated -> type_value annotated -> type_value +(* +val quote : string -> type_value -> type_value -> Expression.t -> anon_function + + +val e_int : Expression.t' -> Expression.t +*) +val e_unit : Expression.t +val e_skip : Expression.t +val e_var_int : string -> Expression.t +val e_let_in : string -> type_value -> Expression.t -> Expression.t -> Expression.t + +val ez_e_sequence : Expression.t' -> Expression.t -> expression +(* +val ez_e_return : Expression.t -> Expression.t +*) +val d_unit : value +(* +val basic_quote : type_value -> type_value -> Expression.t -> anon_function result +*) +val basic_int_quote : expression -> expression result + +val environment_wrap : environment -> environment -> environment_wrap +val id_environment_wrap : environment -> environment_wrap diff --git a/src/stages/mini_c/combinators_smart.mli b/src/stages/mini_c/combinators_smart.mli new file mode 100644 index 000000000..68ff160f2 --- /dev/null +++ b/src/stages/mini_c/combinators_smart.mli @@ -0,0 +1,3 @@ +open Types + +val basic_int_quote_env : environment diff --git a/src/stages/mini_c/environment.mli b/src/stages/mini_c/environment.mli new file mode 100644 index 000000000..a9ac6afef --- /dev/null +++ b/src/stages/mini_c/environment.mli @@ -0,0 +1,58 @@ +(* open Trace *) +open Types + + +module Environment : sig + + type element = environment_element + type t = environment + + val empty : t + val add : element -> t -> t + val concat : t list -> t + (* + val get_opt : string -> t -> type_value option + val has : string -> t -> bool + *) + val get_i : string -> t -> (type_value * int) + val of_list : element list -> t + val to_list : t -> element list + val get_names : t -> string list + val remove : int -> t -> t + val select : ?rev:bool -> ?keep:bool -> string list -> t -> t + (* + val fold : ('a -> element -> 'a ) -> 'a -> t -> 'a + val filter : ( element -> bool ) -> t -> t + *) + (* + vatl closure_representation : t -> type_value + *) +end + +type element = environment_element +type t = environment + +val empty : t +val add : element -> t -> t +val concat : t list -> t +(* +val get_opt : string -> t -> type_value option +*) +val has : string -> t -> bool +(* +val get_i : string -> t -> (type_value * int) +*) +val of_list : element list -> t +(* +val to_list : t -> element list +val get_names : t -> string list +val remove : int -> t -> t + +*) +val select : ?rev:bool -> ?keep:bool -> string list -> t -> t +val fold : ('a -> element -> 'a ) -> 'a -> t -> 'a +val filter : ( element -> bool ) -> t -> t + +(* +val closure_representation : t -> type_value +*) diff --git a/vendors/rope/rope.mli b/vendors/rope/rope.mli index 0fb2e14f3..d9a045069 100644 --- a/vendors/rope/rope.mli +++ b/vendors/rope/rope.mli @@ -1,3 +1,4 @@ +(* module RopeImplementation = Rope_implementation type impl = RopeImplementation.t type 'a t = @@ -16,3 +17,4 @@ val finish : impl -> impl val ( ~% ) : (((impl -> 'a) -> 'a) -> 'b) t -> 'b val ( % ) : 'a -> ('a -> 'b) t -> 'b val ( #% ) : ((impl -> impl) -> 'a -> 'b) -> 'a -> 'b +*) diff --git a/vendors/rope/rope_implementation.mli b/vendors/rope/rope_implementation.mli index b478569a7..6e08373c1 100644 --- a/vendors/rope/rope_implementation.mli +++ b/vendors/rope/rope_implementation.mli @@ -1,4 +1,6 @@ +(* type t val of_string : string -> t val cat : t -> t -> t val to_string : t -> string +*) diff --git a/vendors/rope/rope_top_level_open.mli b/vendors/rope/rope_top_level_open.mli index b0e50e2e8..a03932aad 100644 --- a/vendors/rope/rope_top_level_open.mli +++ b/vendors/rope/rope_top_level_open.mli @@ -1,3 +1,5 @@ +(* open Rope val ( #% ) : ((impl -> impl) -> 'a -> 'b) -> 'a -> 'b +*)