various refactorings to prepare tests; tests for ligodity don't pass
This commit is contained in:
parent
009b0331e9
commit
320d0c1a72
@ -98,7 +98,7 @@ let parsify_expression_ligodity = fun source ->
|
||||
let parsify = fun syntax source ->
|
||||
let%bind parsify = match syntax with
|
||||
| "pascaligo" -> ok parsify_pascaligo
|
||||
| "cameligo"
|
||||
| "cameligo" -> ok parsify_ligodity
|
||||
| _ -> simple_fail "unrecognized parser"
|
||||
in
|
||||
parsify source
|
||||
@ -106,7 +106,7 @@ let parsify = fun syntax source ->
|
||||
let parsify_expression = fun syntax source ->
|
||||
let%bind parsify = match syntax with
|
||||
| "pascaligo" -> ok parsify_expression_pascaligo
|
||||
| "cameligo"
|
||||
| "cameligo" -> ok parsify_expression_ligodity
|
||||
| _ -> simple_fail "unrecognized parser"
|
||||
in
|
||||
parsify source
|
||||
|
271
src/main/main.ml
271
src/main/main.ml
@ -1,6 +1,6 @@
|
||||
module Run_mini_c = Run_mini_c
|
||||
|
||||
open Trace
|
||||
(* open Trace *)
|
||||
module Parser = Parser
|
||||
module AST_Raw = Parser.Pascaligo.AST
|
||||
module AST_Simplified = Ast_simplified
|
||||
@ -8,159 +8,128 @@ module AST_Typed = Ast_typed
|
||||
module Mini_c = Mini_c
|
||||
module Typer = Typer
|
||||
module Transpiler = Transpiler
|
||||
|
||||
module Run = struct
|
||||
include Run_source
|
||||
include Run_simplified
|
||||
include Run_typed
|
||||
include Run_mini_c
|
||||
end
|
||||
|
||||
(* module Parser_multifix = Multifix
|
||||
* module Simplify_multifix = Simplify_multifix *)
|
||||
|
||||
|
||||
let simplify (p:AST_Raw.t) : Ast_simplified.program result = Simplify.Pascaligo.simpl_program p
|
||||
let simplify_expr (e:AST_Raw.expr) : Ast_simplified.expression result = Simplify.Pascaligo.simpl_expression e
|
||||
let unparse_simplified_expr (e:AST_Simplified.expression) : string result =
|
||||
ok @@ Format.asprintf "%a" AST_Simplified.PP.expression e
|
||||
|
||||
let type_ (p:AST_Simplified.program) : AST_Typed.program result = Typer.type_program p
|
||||
let type_expression ?(env:Typer.Environment.t = Typer.Environment.full_empty)
|
||||
(e:AST_Simplified.expression) : AST_Typed.annotated_expression result =
|
||||
Typer.type_expression env e
|
||||
let untype_expression (e:AST_Typed.annotated_expression) : AST_Simplified.expression result = Typer.untype_expression e
|
||||
|
||||
let transpile (p:AST_Typed.program) : Mini_c.program result = Transpiler.translate_program p
|
||||
let transpile_entry (p:AST_Typed.program) (name:string) : Mini_c.anon_function result = Transpiler.translate_entry p name
|
||||
let transpile_expression (e:AST_Typed.annotated_expression) : Mini_c.expression result = Transpiler.translate_annotated_expression e
|
||||
let transpile_value
|
||||
(e:AST_Typed.annotated_expression) : Mini_c.value result =
|
||||
let%bind f =
|
||||
let open Transpiler in
|
||||
let (f , _) = functionalize e in
|
||||
let%bind main = translate_main f in
|
||||
ok main
|
||||
in
|
||||
|
||||
let input = Mini_c.Combinators.d_unit in
|
||||
let%bind r = Run_mini_c.run_entry f input in
|
||||
ok r
|
||||
|
||||
let untranspile_value (v : Mini_c.value) (e:AST_Typed.type_value) : AST_Typed.annotated_expression result =
|
||||
Transpiler.untranspile v e
|
||||
|
||||
let compile : Mini_c.program -> string -> Compiler.Program.compiled_program result = Compiler.Program.translate_program
|
||||
|
||||
let type_file ?(debug_simplify = false) ?(debug_typed = false)
|
||||
(path:string) : AST_Typed.program result =
|
||||
let%bind raw = Parser.Pascaligo.parse_file path in
|
||||
let%bind simpl =
|
||||
trace (simple_error "simplifying") @@
|
||||
simplify raw in
|
||||
(if debug_simplify then
|
||||
Format.(printf "Simplified : %a\n%!" AST_Simplified.PP.program simpl)
|
||||
) ;
|
||||
let%bind typed =
|
||||
trace (simple_error "typing") @@
|
||||
type_ simpl in
|
||||
(if debug_typed then (
|
||||
Format.(printf "Typed : %a\n%!" AST_Typed.PP.program typed)
|
||||
)) ;
|
||||
ok typed
|
||||
(* let simplify (p:AST_Raw.t) : Ast_simplified.program result = Simplify.Pascaligo.simpl_program p
|
||||
* let simplify_expr (e:AST_Raw.expr) : Ast_simplified.expression result = Simplify.Pascaligo.simpl_expression e
|
||||
* let unparse_simplified_expr (e:AST_Simplified.expression) : string result =
|
||||
* ok @@ Format.asprintf "%a" AST_Simplified.PP.expression e
|
||||
*
|
||||
* let type_ (p:AST_Simplified.program) : AST_Typed.program result = Typer.type_program p
|
||||
* let type_expression ?(env:Typer.Environment.t = Typer.Environment.full_empty)
|
||||
* (e:AST_Simplified.expression) : AST_Typed.annotated_expression result =
|
||||
* Typer.type_expression env e
|
||||
* let untype_expression (e:AST_Typed.annotated_expression) : AST_Simplified.expression result = Typer.untype_expression e
|
||||
*
|
||||
* let transpile (p:AST_Typed.program) : Mini_c.program result = Transpiler.translate_program p
|
||||
* let transpile_entry (p:AST_Typed.program) (name:string) : Mini_c.anon_function result = Transpiler.translate_entry p name
|
||||
* let transpile_expression (e:AST_Typed.annotated_expression) : Mini_c.expression result = Transpiler.translate_annotated_expression e
|
||||
*
|
||||
* let untranspile_value (v : Mini_c.value) (e:AST_Typed.type_value) : AST_Typed.annotated_expression result =
|
||||
* Transpiler.untranspile v e
|
||||
*
|
||||
* let compile : Mini_c.program -> string -> Compiler.Program.compiled_program result = Compiler.Program.translate_program
|
||||
*
|
||||
* let easy_evaluate_typed (entry:string) (program:AST_Typed.program) : AST_Typed.annotated_expression result =
|
||||
* let%bind result =
|
||||
* let%bind mini_c_main =
|
||||
* transpile_entry program entry in
|
||||
* Run_mini_c.run_entry mini_c_main (Mini_c.Combinators.d_unit) in
|
||||
* let%bind typed_result =
|
||||
* let%bind typed_main = Ast_typed.get_entry program entry in
|
||||
* untranspile_value result typed_main.type_annotation in
|
||||
* ok typed_result
|
||||
*
|
||||
*
|
||||
* let easy_evaluate_typed = trace_f_2_ez easy_evaluate_typed (thunk "easy evaluate typed")
|
||||
*
|
||||
*
|
||||
* let easy_run_typed
|
||||
* ?(debug_mini_c = false) ?options (entry:string)
|
||||
* (program:AST_Typed.program) (input:AST_Typed.annotated_expression) : AST_Typed.annotated_expression result =
|
||||
* let%bind () =
|
||||
* let open Ast_typed in
|
||||
* let%bind (Declaration_constant (d , _)) = get_declaration_by_name program entry in
|
||||
* let%bind (arg_ty , _) =
|
||||
* trace_strong (simple_error "entry-point doesn't have a function type") @@
|
||||
* get_t_function @@ get_type_annotation d.annotated_expression in
|
||||
* Ast_typed.assert_type_value_eq (arg_ty , (Ast_typed.get_type_annotation input))
|
||||
* in
|
||||
*
|
||||
* let%bind mini_c_main =
|
||||
* trace (simple_error "transpile mini_c entry") @@
|
||||
* transpile_entry program entry in
|
||||
* (if debug_mini_c then
|
||||
* Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main)
|
||||
* ) ;
|
||||
*
|
||||
* let%bind mini_c_value = transpile_value input in
|
||||
*
|
||||
* let%bind mini_c_result =
|
||||
* let error =
|
||||
* let title () = "run Mini_c" in
|
||||
* let content () =
|
||||
* Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main
|
||||
* in
|
||||
* error title content in
|
||||
* trace error @@
|
||||
* Run_mini_c.run_entry ?options mini_c_main mini_c_value in
|
||||
* let%bind typed_result =
|
||||
* let%bind main_result_type =
|
||||
* let%bind typed_main = Ast_typed.get_functional_entry program entry in
|
||||
* match (snd typed_main).type_value' with
|
||||
* | T_function (_, result) -> ok result
|
||||
* | _ -> simple_fail "main doesn't have fun type" in
|
||||
* untranspile_value mini_c_result main_result_type in
|
||||
* ok typed_result
|
||||
*
|
||||
* let easy_run_typed_simplified
|
||||
* ?(debug_mini_c = false) ?(debug_michelson = false) ?options (entry:string)
|
||||
* (program:AST_Typed.program) (input:Ast_simplified.expression) : Ast_simplified.expression result =
|
||||
* let%bind mini_c_main =
|
||||
* trace (simple_error "transpile mini_c entry") @@
|
||||
* transpile_entry program entry in
|
||||
* (if debug_mini_c then
|
||||
* Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main)
|
||||
* ) ;
|
||||
*
|
||||
* let%bind typed_value =
|
||||
* let env =
|
||||
* let last_declaration = Location.unwrap List.(hd @@ rev program) in
|
||||
* match last_declaration with
|
||||
* | Declaration_constant (_ , (_ , post_env)) -> post_env
|
||||
* in
|
||||
* type_expression ~env input in
|
||||
* let%bind mini_c_value = transpile_value typed_value in
|
||||
*
|
||||
* let%bind mini_c_result =
|
||||
* let error =
|
||||
* let title () = "run Mini_c" in
|
||||
* let content () =
|
||||
* Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main
|
||||
* in
|
||||
* error title content in
|
||||
* trace error @@
|
||||
* Run_mini_c.run_entry ~debug_michelson ?options mini_c_main mini_c_value in
|
||||
* let%bind typed_result =
|
||||
* let%bind main_result_type =
|
||||
* let%bind typed_main = Ast_typed.get_functional_entry program entry in
|
||||
* match (snd typed_main).type_value' with
|
||||
* | T_function (_, result) -> ok result
|
||||
* | _ -> simple_fail "main doesn't have fun type" in
|
||||
* untranspile_value mini_c_result main_result_type in
|
||||
* let%bind annotated_result = untype_expression typed_result in
|
||||
* ok annotated_result *)
|
||||
|
||||
|
||||
let easy_evaluate_typed (entry:string) (program:AST_Typed.program) : AST_Typed.annotated_expression result =
|
||||
let%bind result =
|
||||
let%bind mini_c_main =
|
||||
transpile_entry program entry in
|
||||
Run_mini_c.run_entry mini_c_main (Mini_c.Combinators.d_unit) in
|
||||
let%bind typed_result =
|
||||
let%bind typed_main = Ast_typed.get_entry program entry in
|
||||
untranspile_value result typed_main.type_annotation in
|
||||
ok typed_result
|
||||
|
||||
let easy_evaluate_typed_simplified (entry:string) (program:AST_Typed.program) : Ast_simplified.expression result =
|
||||
let%bind result =
|
||||
let%bind mini_c_main =
|
||||
transpile_entry program entry in
|
||||
Run_mini_c.run_entry mini_c_main (Mini_c.Combinators.d_unit) in
|
||||
let%bind typed_result =
|
||||
let%bind typed_main = Ast_typed.get_entry program entry in
|
||||
untranspile_value result typed_main.type_annotation in
|
||||
let%bind annotated_result = untype_expression typed_result in
|
||||
ok annotated_result
|
||||
|
||||
let easy_evaluate_typed = trace_f_2_ez easy_evaluate_typed (thunk "easy evaluate typed")
|
||||
|
||||
let easy_run_typed
|
||||
?(debug_mini_c = false) ?options (entry:string)
|
||||
(program:AST_Typed.program) (input:AST_Typed.annotated_expression) : AST_Typed.annotated_expression result =
|
||||
let%bind () =
|
||||
let open Ast_typed in
|
||||
let%bind (Declaration_constant (d , _)) = get_declaration_by_name program entry in
|
||||
let%bind (arg_ty , _) =
|
||||
trace_strong (simple_error "entry-point doesn't have a function type") @@
|
||||
get_t_function @@ get_type_annotation d.annotated_expression in
|
||||
Ast_typed.assert_type_value_eq (arg_ty , (Ast_typed.get_type_annotation input))
|
||||
in
|
||||
|
||||
let%bind mini_c_main =
|
||||
trace (simple_error "transpile mini_c entry") @@
|
||||
transpile_entry program entry in
|
||||
(if debug_mini_c then
|
||||
Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main)
|
||||
) ;
|
||||
|
||||
let%bind mini_c_value = transpile_value input in
|
||||
|
||||
let%bind mini_c_result =
|
||||
let error =
|
||||
let title () = "run Mini_c" in
|
||||
let content () =
|
||||
Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main
|
||||
in
|
||||
error title content in
|
||||
trace error @@
|
||||
Run_mini_c.run_entry ?options mini_c_main mini_c_value in
|
||||
let%bind typed_result =
|
||||
let%bind main_result_type =
|
||||
let%bind typed_main = Ast_typed.get_functional_entry program entry in
|
||||
match (snd typed_main).type_value' with
|
||||
| T_function (_, result) -> ok result
|
||||
| _ -> simple_fail "main doesn't have fun type" in
|
||||
untranspile_value mini_c_result main_result_type in
|
||||
ok typed_result
|
||||
|
||||
let easy_run_typed_simplified
|
||||
?(debug_mini_c = false) ?(debug_michelson = false) ?options (entry:string)
|
||||
(program:AST_Typed.program) (input:Ast_simplified.expression) : Ast_simplified.expression result =
|
||||
let%bind mini_c_main =
|
||||
trace (simple_error "transpile mini_c entry") @@
|
||||
transpile_entry program entry in
|
||||
(if debug_mini_c then
|
||||
Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main)
|
||||
) ;
|
||||
|
||||
let%bind typed_value =
|
||||
let env =
|
||||
let last_declaration = Location.unwrap List.(hd @@ rev program) in
|
||||
match last_declaration with
|
||||
| Declaration_constant (_ , (_ , post_env)) -> post_env
|
||||
in
|
||||
type_expression ~env input in
|
||||
let%bind mini_c_value = transpile_value typed_value in
|
||||
|
||||
let%bind mini_c_result =
|
||||
let error =
|
||||
let title () = "run Mini_c" in
|
||||
let content () =
|
||||
Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main
|
||||
in
|
||||
error title content in
|
||||
trace error @@
|
||||
Run_mini_c.run_entry ~debug_michelson ?options mini_c_main mini_c_value in
|
||||
let%bind typed_result =
|
||||
let%bind main_result_type =
|
||||
let%bind typed_main = Ast_typed.get_functional_entry program entry in
|
||||
match (snd typed_main).type_value' with
|
||||
| T_function (_, result) -> ok result
|
||||
| _ -> simple_fail "main doesn't have fun type" in
|
||||
untranspile_value mini_c_result main_result_type in
|
||||
let%bind annotated_result = untype_expression typed_result in
|
||||
ok annotated_result
|
||||
|
||||
|
||||
module Contract = Contract
|
||||
(* module Contract = Contract *)
|
||||
|
@ -22,14 +22,6 @@ let run_aux ?options (program:compiled_program) (input_michelson:Michelson.t) :
|
||||
Memory_proto_alpha.interpret ?options descr (Item(input, Empty)) in
|
||||
ok (Ex_typed_value (output_ty, output))
|
||||
|
||||
let run_node (program:program) (input:Michelson.t) : Michelson.t result =
|
||||
let%bind compiled = translate_program program "main" in
|
||||
let%bind (Ex_typed_value (output_ty, output)) = run_aux compiled input in
|
||||
let%bind output =
|
||||
Trace.trace_tzresult_lwt (simple_error "error unparsing output") @@
|
||||
Memory_proto_alpha.unparse_michelson_data output_ty output in
|
||||
ok output
|
||||
|
||||
let run_entry ?(debug_michelson = false) ?options (entry:anon_function) (input:value) : value result =
|
||||
let%bind compiled =
|
||||
let error =
|
||||
@ -45,17 +37,3 @@ let run_entry ?(debug_michelson = false) ?options (entry:anon_function) (input:v
|
||||
let%bind ex_ty_value = run_aux ?options compiled input_michelson in
|
||||
let%bind (result : value) = Compiler.Uncompiler.translate_value ex_ty_value in
|
||||
ok result
|
||||
|
||||
let run (program:program) (input:value) : value result =
|
||||
let%bind input_michelson = translate_value input in
|
||||
let%bind compiled = translate_program program "main" in
|
||||
let%bind ex_ty_value = run_aux compiled input_michelson in
|
||||
let%bind (result : value) = Compiler.Uncompiler.translate_value ex_ty_value in
|
||||
ok result
|
||||
|
||||
let expression_to_value (e:expression) : value result =
|
||||
match (Combinators.Expression.get_content e) with
|
||||
| E_literal v -> ok v
|
||||
| _ -> fail
|
||||
@@ error (thunk "not a value")
|
||||
@@ (fun () -> Format.asprintf "%a" PP.expression e)
|
||||
|
24
src/main/run_simplified.ml
Normal file
24
src/main/run_simplified.ml
Normal file
@ -0,0 +1,24 @@
|
||||
open Trace
|
||||
|
||||
let run_simplityped
|
||||
?options
|
||||
?(debug_mini_c = false) ?(debug_michelson = false)
|
||||
(program : Ast_typed.program) (entry : string)
|
||||
(input : Ast_simplified.expression) : Ast_simplified.expression result =
|
||||
let%bind typed_input =
|
||||
let env =
|
||||
let last_declaration = Location.unwrap List.(hd @@ rev program) in
|
||||
match last_declaration with
|
||||
| Declaration_constant (_ , (_ , post_env)) -> post_env
|
||||
in
|
||||
Typer.type_expression env input in
|
||||
let%bind typed_result =
|
||||
Run_typed.run_typed ?options ~debug_mini_c ~debug_michelson entry program typed_input in
|
||||
let%bind annotated_result = Typer.untype_expression typed_result in
|
||||
ok annotated_result
|
||||
|
||||
let evaluate_simplityped (program : Ast_typed.program) (entry : string)
|
||||
: Ast_simplified.expression result =
|
||||
let%bind typed_result = Run_typed.evaluate_typed entry program in
|
||||
let%bind annotated_result = Typer.untype_expression typed_result in
|
||||
ok annotated_result
|
218
src/main/run_source.ml
Normal file
218
src/main/run_source.ml
Normal file
@ -0,0 +1,218 @@
|
||||
open Trace
|
||||
|
||||
include struct
|
||||
open Ast_simplified
|
||||
|
||||
let assert_entry_point_defined : program -> string -> unit result =
|
||||
fun program entry_point ->
|
||||
let aux : declaration -> bool = fun declaration ->
|
||||
match declaration with
|
||||
| Declaration_type _ -> false
|
||||
| Declaration_constant (name , _ , _) -> name = entry_point
|
||||
in
|
||||
trace_strong (simple_error "no entry-point with given name") @@
|
||||
Assert.assert_true @@ List.exists aux @@ List.map Location.unwrap program
|
||||
end
|
||||
|
||||
include struct
|
||||
open Ast_typed
|
||||
open Combinators
|
||||
|
||||
let get_entry_point_type : type_value -> (type_value * type_value) result = fun t ->
|
||||
let%bind (arg , result) =
|
||||
trace_strong (simple_error "entry-point doesn't have a function type") @@
|
||||
get_t_function t in
|
||||
let%bind (arg' , storage_param) =
|
||||
trace_strong (simple_error "entry-point doesn't have 2 parameters") @@
|
||||
get_t_pair arg in
|
||||
let%bind (ops , storage_result) =
|
||||
trace_strong (simple_error "entry-point doesn't have 2 results") @@
|
||||
get_t_pair result in
|
||||
let%bind () =
|
||||
trace_strong (simple_error "entry-point doesn't have a list of operation as first result") @@
|
||||
assert_t_list_operation ops in
|
||||
let%bind () =
|
||||
trace_strong (simple_error "entry-point doesn't identitcal type (storage) for second parameter and second result") @@
|
||||
assert_type_value_eq (storage_param , storage_result) in
|
||||
ok (arg' , storage_param)
|
||||
|
||||
let get_entry_point : program -> string -> (type_value * type_value) result = fun p e ->
|
||||
let%bind declaration = get_declaration_by_name p e in
|
||||
match declaration with
|
||||
| Declaration_constant (d , _) -> get_entry_point_type d.annotated_expression.type_annotation
|
||||
|
||||
let assert_valid_entry_point = fun p e ->
|
||||
let%bind _ = get_entry_point p e in
|
||||
ok ()
|
||||
end
|
||||
|
||||
let transpile_value
|
||||
(e:Ast_typed.annotated_expression) : Mini_c.value result =
|
||||
let%bind f =
|
||||
let open Transpiler in
|
||||
let (f , _) = functionalize e in
|
||||
let%bind main = translate_main f in
|
||||
ok main
|
||||
in
|
||||
|
||||
let input = Mini_c.Combinators.d_unit in
|
||||
let%bind r = Run_mini_c.run_entry f input in
|
||||
ok r
|
||||
|
||||
let parsify_pascaligo = fun source ->
|
||||
let%bind raw =
|
||||
trace (simple_error "parsing") @@
|
||||
Parser.Pascaligo.parse_file source in
|
||||
let%bind simplified =
|
||||
trace (simple_error "simplifying") @@
|
||||
Simplify.Pascaligo.simpl_program raw in
|
||||
ok simplified
|
||||
|
||||
let parsify_expression_pascaligo = fun source ->
|
||||
let%bind raw =
|
||||
trace (simple_error "parsing expression") @@
|
||||
Parser.Pascaligo.parse_expression source in
|
||||
let%bind simplified =
|
||||
trace (simple_error "simplifying expression") @@
|
||||
Simplify.Pascaligo.simpl_expression raw in
|
||||
ok simplified
|
||||
|
||||
let parsify_ligodity = fun source ->
|
||||
let%bind raw =
|
||||
trace (simple_error "parsing") @@
|
||||
Parser.Ligodity.parse_file source in
|
||||
let%bind simplified =
|
||||
trace (simple_error "simplifying") @@
|
||||
Simplify.Ligodity.simpl_program raw in
|
||||
ok simplified
|
||||
|
||||
let parsify_expression_ligodity = fun source ->
|
||||
let%bind raw =
|
||||
trace (simple_error "parsing expression") @@
|
||||
Parser.Ligodity.parse_expression source in
|
||||
let%bind simplified =
|
||||
trace (simple_error "simplifying expression") @@
|
||||
Simplify.Ligodity.simpl_expression raw in
|
||||
ok simplified
|
||||
|
||||
let parsify = fun syntax source ->
|
||||
let%bind parsify = match syntax with
|
||||
| "pascaligo" -> ok parsify_pascaligo
|
||||
| "cameligo" -> ok parsify_ligodity
|
||||
| _ -> simple_fail "unrecognized parser"
|
||||
in
|
||||
parsify source
|
||||
|
||||
let parsify_expression = fun syntax source ->
|
||||
let%bind parsify = match syntax with
|
||||
| "pascaligo" -> ok parsify_expression_pascaligo
|
||||
| "cameligo" -> ok parsify_expression_ligodity
|
||||
| _ -> simple_fail "unrecognized parser"
|
||||
in
|
||||
parsify source
|
||||
|
||||
let compile_contract_file : string -> string -> string -> string result = fun source entry_point syntax ->
|
||||
let%bind simplified = parsify syntax source in
|
||||
let%bind () =
|
||||
assert_entry_point_defined simplified entry_point in
|
||||
let%bind typed =
|
||||
trace (simple_error "typing") @@
|
||||
Typer.type_program simplified in
|
||||
let%bind mini_c =
|
||||
trace (simple_error "transpiling") @@
|
||||
Transpiler.translate_entry typed entry_point in
|
||||
let%bind michelson =
|
||||
trace (simple_error "compiling") @@
|
||||
Compiler.translate_contract mini_c in
|
||||
let str =
|
||||
Format.asprintf "%a" Michelson.pp_stripped michelson in
|
||||
ok str
|
||||
|
||||
let compile_contract_parameter : string -> string -> string -> string -> string result = fun source entry_point expression syntax ->
|
||||
let%bind (program , parameter_tv) =
|
||||
let%bind simplified = parsify syntax source in
|
||||
let%bind () =
|
||||
assert_entry_point_defined simplified entry_point in
|
||||
let%bind typed =
|
||||
trace (simple_error "typing file") @@
|
||||
Typer.type_program simplified in
|
||||
let%bind (param_ty , _) =
|
||||
get_entry_point typed entry_point in
|
||||
ok (typed , param_ty)
|
||||
in
|
||||
let%bind expr =
|
||||
let%bind typed =
|
||||
let%bind simplified = parsify_expression syntax expression in
|
||||
let env =
|
||||
let last_declaration = Location.unwrap List.(hd @@ rev program) in
|
||||
match last_declaration with
|
||||
| Declaration_constant (_ , (_ , post_env)) -> post_env
|
||||
in
|
||||
trace (simple_error "typing expression") @@
|
||||
Typer.type_expression env simplified in
|
||||
let%bind () =
|
||||
trace (simple_error "expression type doesn't match type parameter") @@
|
||||
Ast_typed.assert_type_value_eq (parameter_tv , typed.type_annotation) in
|
||||
let%bind mini_c =
|
||||
trace (simple_error "transpiling expression") @@
|
||||
transpile_value typed in
|
||||
let%bind michelson =
|
||||
trace (simple_error "compiling expression") @@
|
||||
Compiler.translate_value mini_c in
|
||||
let str =
|
||||
Format.asprintf "%a" Michelson.pp_stripped michelson in
|
||||
ok str
|
||||
in
|
||||
ok expr
|
||||
|
||||
|
||||
let compile_contract_storage : string -> string -> string -> string -> string result = fun source entry_point expression syntax ->
|
||||
let%bind (program , storage_tv) =
|
||||
let%bind simplified = parsify syntax source in
|
||||
let%bind () =
|
||||
assert_entry_point_defined simplified entry_point in
|
||||
let%bind typed =
|
||||
trace (simple_error "typing file") @@
|
||||
Typer.type_program simplified in
|
||||
let%bind (_ , storage_ty) =
|
||||
get_entry_point typed entry_point in
|
||||
ok (typed , storage_ty)
|
||||
in
|
||||
let%bind expr =
|
||||
let%bind simplified = parsify_expression syntax expression in
|
||||
let%bind typed =
|
||||
let env =
|
||||
let last_declaration = Location.unwrap List.(hd @@ rev program) in
|
||||
match last_declaration with
|
||||
| Declaration_constant (_ , (_ , post_env)) -> post_env
|
||||
in
|
||||
trace (simple_error "typing expression") @@
|
||||
Typer.type_expression env simplified in
|
||||
let%bind () =
|
||||
trace (simple_error "expression type doesn't match type storage") @@
|
||||
Ast_typed.assert_type_value_eq (storage_tv , typed.type_annotation) in
|
||||
let%bind mini_c =
|
||||
trace (simple_error "transpiling expression") @@
|
||||
transpile_value typed in
|
||||
let%bind michelson =
|
||||
trace (simple_error "compiling expression") @@
|
||||
Compiler.translate_value mini_c in
|
||||
let str =
|
||||
Format.asprintf "%a" Michelson.pp_stripped michelson in
|
||||
ok str
|
||||
in
|
||||
ok expr
|
||||
|
||||
let type_file ?(debug_simplify = false) ?(debug_typed = false)
|
||||
syntax (path:string) : Ast_typed.program result =
|
||||
let%bind simpl = parsify syntax path in
|
||||
(if debug_simplify then
|
||||
Format.(printf "Simplified : %a\n%!" Ast_simplified.PP.program simpl)
|
||||
) ;
|
||||
let%bind typed =
|
||||
trace (simple_error "typing") @@
|
||||
Typer.type_program simpl in
|
||||
(if debug_typed then (
|
||||
Format.(printf "Typed : %a\n%!" Ast_typed.PP.program typed)
|
||||
)) ;
|
||||
ok typed
|
64
src/main/run_typed.ml
Normal file
64
src/main/run_typed.ml
Normal file
@ -0,0 +1,64 @@
|
||||
open Trace
|
||||
|
||||
let transpile_value
|
||||
(e:Ast_typed.annotated_expression) : Mini_c.value result =
|
||||
let%bind f =
|
||||
let open Transpiler in
|
||||
let (f , _) = functionalize e in
|
||||
let%bind main = translate_main f in
|
||||
ok main
|
||||
in
|
||||
|
||||
let input = Mini_c.Combinators.d_unit in
|
||||
let%bind r = Run_mini_c.run_entry f input in
|
||||
ok r
|
||||
|
||||
let evaluate_typed (entry:string) (program:Ast_typed.program) : Ast_typed.annotated_expression result =
|
||||
trace (simple_error "easy evaluate typed") @@
|
||||
let%bind result =
|
||||
let%bind mini_c_main =
|
||||
Transpiler.translate_entry program entry in
|
||||
Run_mini_c.run_entry mini_c_main (Mini_c.Combinators.d_unit) in
|
||||
let%bind typed_result =
|
||||
let%bind typed_main = Ast_typed.get_entry program entry in
|
||||
Transpiler.untranspile result typed_main.type_annotation in
|
||||
ok typed_result
|
||||
|
||||
let run_typed
|
||||
?(debug_mini_c = false) ?(debug_michelson = false) ?options (entry:string)
|
||||
(program:Ast_typed.program) (input:Ast_typed.annotated_expression) : Ast_typed.annotated_expression result =
|
||||
let%bind () =
|
||||
let open Ast_typed in
|
||||
let%bind (Declaration_constant (d , _)) = get_declaration_by_name program entry in
|
||||
let%bind (arg_ty , _) =
|
||||
trace_strong (simple_error "entry-point doesn't have a function type") @@
|
||||
get_t_function @@ get_type_annotation d.annotated_expression in
|
||||
Ast_typed.assert_type_value_eq (arg_ty , (Ast_typed.get_type_annotation input))
|
||||
in
|
||||
|
||||
let%bind mini_c_main =
|
||||
trace (simple_error "transpile mini_c entry") @@
|
||||
Transpiler.translate_entry program entry in
|
||||
(if debug_mini_c then
|
||||
Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main)
|
||||
) ;
|
||||
|
||||
let%bind mini_c_value = transpile_value input in
|
||||
|
||||
let%bind mini_c_result =
|
||||
let error =
|
||||
let title () = "run Mini_c" in
|
||||
let content () =
|
||||
Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main
|
||||
in
|
||||
error title content in
|
||||
trace error @@
|
||||
Run_mini_c.run_entry ~debug_michelson ?options mini_c_main mini_c_value in
|
||||
let%bind typed_result =
|
||||
let%bind main_result_type =
|
||||
let%bind typed_main = Ast_typed.get_functional_entry program entry in
|
||||
match (snd typed_main).type_value' with
|
||||
| T_function (_, result) -> ok result
|
||||
| _ -> simple_fail "main doesn't have fun type" in
|
||||
Transpiler.untranspile mini_c_result main_result_type in
|
||||
ok typed_result
|
@ -351,6 +351,7 @@ and simpl_fun_declaration : Raw.fun_decl -> ((name * type_expression option) * e
|
||||
let arguments_name = "arguments" in
|
||||
let%bind params = bind_map_list simpl_param lst in
|
||||
let (binder , input_type) =
|
||||
(* let type_expression = T_record (SMap.of_list params) in *)
|
||||
let type_expression = T_tuple (List.map snd params) in
|
||||
(arguments_name , type_expression) in
|
||||
let%bind tpl_declarations =
|
||||
|
@ -1,10 +1,10 @@
|
||||
open Trace
|
||||
open Ligo
|
||||
open Ligo.Run
|
||||
open Test_helpers
|
||||
|
||||
let compile_contract_basic () : unit result =
|
||||
let%bind _ =
|
||||
Contract.compile_contract_file "./contracts/dispatch-counter.ligo" "main" "pascaligo"
|
||||
compile_contract_file "./contracts/dispatch-counter.ligo" "main" "pascaligo"
|
||||
in
|
||||
ok ()
|
||||
|
||||
|
@ -1,9 +1,11 @@
|
||||
(* Copyright Coase, Inc 2019 *)
|
||||
|
||||
open Trace
|
||||
open Ligo
|
||||
open Ligo.Run
|
||||
open Test_helpers
|
||||
|
||||
let type_file = type_file "pascaligo"
|
||||
|
||||
let get_program =
|
||||
let s = ref None in
|
||||
fun () -> match !s with
|
||||
|
@ -1,7 +1,9 @@
|
||||
open Trace
|
||||
open Ligo
|
||||
open Ligo.Run
|
||||
open Test_helpers
|
||||
|
||||
let type_file = type_file "pascaligo"
|
||||
|
||||
let get_program =
|
||||
let s = ref None in
|
||||
fun () -> match !s with
|
||||
@ -12,8 +14,8 @@ let get_program =
|
||||
ok program
|
||||
)
|
||||
|
||||
let a_heap_ez ?value_type (content:(int * AST_Typed.ae) list) =
|
||||
let open AST_Typed.Combinators in
|
||||
let a_heap_ez ?value_type (content:(int * Ast_typed.ae) list) =
|
||||
let open Ast_typed.Combinators in
|
||||
let content =
|
||||
let aux = fun (x, y) -> e_a_empty_nat x, y in
|
||||
List.map aux content in
|
||||
@ -24,7 +26,7 @@ let a_heap_ez ?value_type (content:(int * AST_Typed.ae) list) =
|
||||
e_a_empty_map content (t_nat ()) value_type
|
||||
|
||||
let ez lst =
|
||||
let open AST_Typed.Combinators in
|
||||
let open Ast_typed.Combinators in
|
||||
let value_type = t_pair
|
||||
(t_int ())
|
||||
(t_string ())
|
||||
@ -46,11 +48,11 @@ let dummy n =
|
||||
let is_empty () : unit result =
|
||||
let%bind program = get_program () in
|
||||
let aux n =
|
||||
let open AST_Typed.Combinators in
|
||||
let open Ast_typed.Combinators in
|
||||
let input = dummy n in
|
||||
let%bind result = easy_run_typed "is_empty" program input in
|
||||
let%bind result = run_typed "is_empty" program input in
|
||||
let expected = e_a_empty_bool (n = 0) in
|
||||
AST_Typed.assert_value_eq (expected, result)
|
||||
Ast_typed.assert_value_eq (expected, result)
|
||||
in
|
||||
let%bind _ = bind_list
|
||||
@@ List.map aux
|
||||
@ -60,15 +62,15 @@ let is_empty () : unit result =
|
||||
let get_top () : unit result =
|
||||
let%bind program = get_program () in
|
||||
let aux n =
|
||||
let open AST_Typed.Combinators in
|
||||
let open Ast_typed.Combinators in
|
||||
let input = dummy n in
|
||||
match n, easy_run_typed "get_top" program input with
|
||||
match n, run_typed "get_top" program input with
|
||||
| 0, Trace.Ok _ -> simple_fail "unexpected success"
|
||||
| 0, _ -> ok ()
|
||||
| _, result ->
|
||||
let%bind result' = result in
|
||||
let expected = e_a_empty_pair (e_a_empty_int 1) (e_a_empty_string "1") in
|
||||
AST_Typed.assert_value_eq (expected, result')
|
||||
Ast_typed.assert_value_eq (expected, result')
|
||||
in
|
||||
let%bind _ = bind_list
|
||||
@@ List.map aux
|
||||
@ -79,7 +81,7 @@ let pop_switch () : unit result =
|
||||
let%bind program = get_program () in
|
||||
let aux n =
|
||||
let input = dummy n in
|
||||
match n, easy_run_typed "pop_switch" program input with
|
||||
match n, run_typed "pop_switch" program input with
|
||||
| 0, Trace.Ok _ -> simple_fail "unexpected success"
|
||||
| 0, _ -> ok ()
|
||||
| _, result ->
|
||||
@ -89,7 +91,7 @@ let pop_switch () : unit result =
|
||||
@@ tl
|
||||
@@ range (n + 1)
|
||||
) in
|
||||
AST_Typed.assert_value_eq (expected, result')
|
||||
Ast_typed.assert_value_eq (expected, result')
|
||||
in
|
||||
let%bind _ = bind_list
|
||||
@@ List.map aux
|
||||
@ -100,9 +102,9 @@ let pop () : unit result =
|
||||
let%bind program = get_program () in
|
||||
let aux n =
|
||||
let input = dummy n in
|
||||
(match easy_run_typed "pop" program input with
|
||||
(match run_typed "pop" program input with
|
||||
| Trace.Ok (output , _) -> (
|
||||
Format.printf "\nPop output on %d : %a\n" n AST_Typed.PP.annotated_expression output ;
|
||||
Format.printf "\nPop output on %d : %a\n" n Ast_typed.PP.annotated_expression output ;
|
||||
)
|
||||
| Errors errs -> (
|
||||
Format.printf "\nPop output on %d : error\n" n) ;
|
||||
|
@ -1,14 +1,11 @@
|
||||
open Trace
|
||||
open Ligo
|
||||
open Ligo.Run
|
||||
open Test_helpers
|
||||
|
||||
open Ast_simplified.Combinators
|
||||
|
||||
let mtype_file path : Ast_typed.program result =
|
||||
let%bind raw = Parser.Camligo.User.parse_file path in
|
||||
let%bind simpl = Simplify.Camligo.main raw in
|
||||
let%bind typed = Ligo.Typer.type_program (Location.unwrap simpl) in
|
||||
ok typed
|
||||
let mtype_file = type_file "cameligo"
|
||||
let type_file = type_file "pascaligo"
|
||||
|
||||
let function_ () : unit result =
|
||||
let%bind program = type_file "./contracts/function.ligo" in
|
||||
@ -148,6 +145,9 @@ let include_ () : unit result =
|
||||
let record_ez_int names n =
|
||||
ez_e_record @@ List.map (fun x -> x, e_int n) names
|
||||
|
||||
let tuple_ez_int names n =
|
||||
e_tuple @@ List.map (fun _ -> e_int n) names
|
||||
|
||||
let multiple_parameters () : unit result =
|
||||
let%bind program = type_file "./contracts/multiple-parameters.ligo" in
|
||||
let aux ((name : string) , make_input , make_output) =
|
||||
@ -155,9 +155,9 @@ let multiple_parameters () : unit result =
|
||||
expect_eq_n program name make_input make_output'
|
||||
in
|
||||
let%bind _ = bind_list @@ List.map aux [
|
||||
("ab", record_ez_int ["a";"b"], fun n -> 2 * n) ;
|
||||
("abcd", record_ez_int ["a";"b";"c";"d"], fun n -> 4 * n + 2) ;
|
||||
("abcde", record_ez_int ["a";"b";"c";"d";"e"], fun n -> 2 * n + 3) ;
|
||||
("ab", tuple_ez_int ["a";"b"], fun n -> 2 * n) ;
|
||||
("abcd", tuple_ez_int ["a";"b";"c";"d"], fun n -> 4 * n + 2) ;
|
||||
("abcde", tuple_ez_int ["a";"b";"c";"d";"e"], fun n -> 2 * n + 3) ;
|
||||
] in
|
||||
ok ()
|
||||
|
||||
@ -437,7 +437,7 @@ let dispatch_counter_contract () : unit result =
|
||||
|
||||
let basic_mligo () : unit result =
|
||||
let%bind typed = mtype_file "./contracts/basic.mligo" in
|
||||
let%bind result = Ligo.easy_evaluate_typed "foo" typed in
|
||||
let%bind result = evaluate_typed "foo" typed in
|
||||
Ligo.AST_Typed.assert_value_eq (Ligo.AST_Typed.Combinators.e_a_empty_int (42 + 127), result)
|
||||
|
||||
let counter_mligo () : unit result =
|
||||
|
@ -3,7 +3,7 @@ open! Trace
|
||||
let test name f =
|
||||
Alcotest.test_case name `Quick @@ fun () ->
|
||||
let result =
|
||||
trace (fun () -> error (thunk "running test") (fun () -> name) ()) @@
|
||||
trace (fun () -> error (thunk "running test") (thunk name) ()) @@
|
||||
f () in
|
||||
match result with
|
||||
| Ok ((), annotations) -> ignore annotations; ()
|
||||
@ -20,7 +20,7 @@ let expect ?options program entry_point input expecter =
|
||||
let content () = Format.asprintf "Entry_point: %s" entry_point in
|
||||
error title content in
|
||||
trace run_error @@
|
||||
Ligo.easy_run_typed_simplified ~debug_michelson:true ?options entry_point program input in
|
||||
Ligo.Run.run_simplityped ~debug_michelson:true ?options program entry_point input in
|
||||
expecter result
|
||||
|
||||
let expect_eq ?options program entry_point input expected =
|
||||
@ -41,7 +41,7 @@ let expect_evaluate program entry_point expecter =
|
||||
let content () = Format.asprintf "Entry_point: %s" entry_point in
|
||||
error title content in
|
||||
trace error @@
|
||||
let%bind result = Ligo.easy_evaluate_typed_simplified entry_point program in
|
||||
let%bind result = Ligo.Run.evaluate_simplityped program entry_point in
|
||||
expecter result
|
||||
|
||||
let expect_eq_evaluate program entry_point expected =
|
||||
|
@ -469,7 +469,7 @@ let translate_main (l:AST.lambda) : anon_function result =
|
||||
| E_literal (D_function f) -> ok f
|
||||
| _ -> simple_fail "main is not a function"
|
||||
|
||||
(* From a non-functional expression [expr], build the functional expression [fun () -> expr] *)
|
||||
(* From an expression [expr], build the expression [fun () -> expr] *)
|
||||
let functionalize (e:AST.annotated_expression) : AST.lambda * AST.type_value =
|
||||
let t = e.type_annotation in
|
||||
let open! AST in
|
||||
@ -511,16 +511,6 @@ let translate_entry (lst:AST.program) (name:string) : anon_function result =
|
||||
|
||||
open Combinators
|
||||
|
||||
let rec exp x n =
|
||||
if n = 0
|
||||
then 1
|
||||
else
|
||||
let exp' = exp (x * x) (n / 2) in
|
||||
let m = if n mod 2 = 0 then 1 else x in
|
||||
m * exp'
|
||||
|
||||
let exp2 = exp 2
|
||||
|
||||
let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value * AST.type_value) result =
|
||||
let open Append_tree in
|
||||
let rec aux tv : (string * value * AST.type_value) result=
|
||||
|
24
vendors/ligo-utils/simple-utils/trace.ml
vendored
24
vendors/ligo-utils/simple-utils/trace.ml
vendored
@ -131,7 +131,7 @@ let mk_error
|
||||
let data' =
|
||||
let aux (key , value) = (key , `String (value ())) in
|
||||
X_option.map (fun x -> ("data" , `Assoc (List.map aux x))) data in
|
||||
let message' = X_option.map (fun x -> ("message " , `String (x ()))) message in
|
||||
let message' = X_option.map (fun x -> ("message" , `String (x ()))) message in
|
||||
`Assoc (X_option.collapse_list [ error_code' ; title' ; message' ; data' ])
|
||||
|
||||
let error title message () = mk_error ~title:(title) ~message:(message) ()
|
||||
@ -467,12 +467,26 @@ module Assert = struct
|
||||
end
|
||||
|
||||
let json_of_error = J.to_string
|
||||
|
||||
let error_pp out (e : error) =
|
||||
let open JSON_string_utils in
|
||||
let message = e |> member "message" |> string || "(no message)" in
|
||||
let title = e |> member "title" |> string || "(no title)" in
|
||||
let error_code = e |> member "error_code" |> int |> string_of_int || "no error code" in
|
||||
Format.fprintf out "%s (%s): %s" title error_code message
|
||||
let message = e |> member "message" |> J.to_string in
|
||||
let error_code =
|
||||
let error_code = e |> member "error_code" in
|
||||
match error_code with
|
||||
| `Null -> ""
|
||||
| _ -> " (" ^ (J.to_string error_code) ^ ")" in
|
||||
let title = e |> member "title" |> J.to_string in
|
||||
let data =
|
||||
let data = e |> member "data" in
|
||||
match data with
|
||||
| `Null -> ""
|
||||
| _ -> J.to_string data in
|
||||
Format.fprintf out "%s (%s): %s. %s" title error_code message data
|
||||
|
||||
(* let error_pp out (e : error) =
|
||||
* Format.fprintf out "%s" @@ json_of_error e *)
|
||||
|
||||
|
||||
let error_pp_short out (e : error) =
|
||||
let open JSON_string_utils in
|
||||
|
3
vendors/ligo-utils/simple-utils/x_option.ml
vendored
3
vendors/ligo-utils/simple-utils/x_option.ml
vendored
@ -27,8 +27,7 @@ let to_list = function
|
||||
| None -> []
|
||||
| Some x -> [ x ]
|
||||
let collapse_list = fun l ->
|
||||
List.concat
|
||||
@@ List.map to_list l
|
||||
List.concat @@ List.map to_list l
|
||||
|
||||
(* Combinators *)
|
||||
let bind_eager_or = fun a b -> match (a , b) with
|
||||
|
Loading…
Reference in New Issue
Block a user