diff --git a/src/ligo/ast_typed.ml b/src/ligo/ast_typed.ml index 4d1acd66d..f6319ace0 100644 --- a/src/ligo/ast_typed.ml +++ b/src/ligo/ast_typed.ml @@ -44,19 +44,21 @@ and type_value = { simplified : S.type_expression option ; } +and lambda = { + binder: name ; + input_type: tv ; + output_type: tv ; + result: ae ; + body: block ; +} + and expression = (* Base *) | Literal of literal | Constant of name * ae list (* For language constants, like (Cons hd tl) or (plus i j) *) | Variable of name | Application of ae * ae - | Lambda of { - binder: name ; - input_type: tv ; - output_type: tv ; - result: ae ; - body: block ; - } + | Lambda of lambda (* Tuple *) | Tuple of ae list | Tuple_accessor of ae * int (* Access n'th tuple's element *) @@ -100,8 +102,20 @@ and matching = } | Match_tuple of name list * b +open! Ligo_helpers.Trace + + let type_value type_value simplified = { type_value ; simplified } let annotated_expression expression type_annotation = { expression ; type_annotation } +let get_entry (p:program) (entry : string) = + let aux (d:declaration) = + match d with + | Constant_declaration {name ; annotated_expression = {expression = Lambda l ; type_annotation}} when entry = name -> + Some (l, type_annotation) + | _ -> None + in + trace_option (simple_error "no entry point with given name") + @@ Tezos_utils.List.find_map aux p module PP = struct open Format @@ -120,7 +134,6 @@ module PP = struct type_value' ppf tv.type_value end -open! Ligo_helpers.Trace module Errors = struct let different_kinds a b = diff --git a/src/ligo/ligo.ml b/src/ligo/ligo.ml index 5546de6e0..33d369b3b 100644 --- a/src/ligo/ligo.ml +++ b/src/ligo/ligo.ml @@ -88,3 +88,21 @@ let transpile_value ?(env:Mini_c.Environment.t = Mini_c.Environment.empty) let untranspile_value (v : Mini_c.value) (e:AST_Typed.type_value) : AST_Typed.annotated_expression result = Transpiler.untranspile v e +let easy_run_main (path:string) (input:string) : AST_Typed.annotated_expression result = + let%bind raw = parse_file path in + let%bind simpl = simplify raw in + let%bind typed = type_ simpl in + let%bind typed_main = Ast_typed.get_entry typed "main" in + let%bind main_result_type = match (snd typed_main).type_value with + | Type_function (_, result) -> ok result + | _ -> simple_fail "main doesn't have fun type" in + let%bind mini_c_main = Transpiler.translate_main (fst typed_main) (snd typed_main) in + + let%bind raw_expr = parse_expression input in + let%bind simpl_expr = simplify_expr raw_expr in + let%bind typed_expr = type_expression simpl_expr in + let%bind mini_c_value = transpile_value typed_expr in + + let%bind mini_c_result = Mini_c.Run.run_entry mini_c_main mini_c_value in + let%bind typed_result = untranspile_value mini_c_result main_result_type in + ok typed_result diff --git a/src/ligo/mini_c.ml b/src/ligo/mini_c.ml index 03b97c650..434e39f9f 100644 --- a/src/ligo/mini_c.ml +++ b/src/ligo/mini_c.ml @@ -882,12 +882,12 @@ module Translate_program = struct body : michelson ; } - let translate (p:program) : compiled_program result = + let translate_program (p:program) (entry:string) : compiled_program result = let is_main ((s, _):toplevel_statement) = match s with - | "main", (Function_expression f, `Function (_, _), _) when f.capture_type = No_capture -> Some f + | name , (Function_expression f, `Function (_, _), _) when f.capture_type = No_capture && name = entry -> Some f | _ -> None in let%bind main = - trace_option (simple_error "no functional main") @@ + trace_option (simple_error "no functional entry") @@ Tezos_utils.List.find_map is_main p in let {input;output} : anon_function_content = main in let%bind body = translate_function_body main in @@ -895,6 +895,13 @@ module Translate_program = struct let%bind output = Translate_type.Ty.type_ output in ok ({input;output;body}:compiled_program) + let translate_entry (p:anon_function) : compiled_program result = + let {input;output} : anon_function_content = p.content in + let%bind body = translate_function_body p.content in + let%bind input = Translate_type.Ty.type_ input in + let%bind output = Translate_type.Ty.type_ output in + ok ({input;output;body}:compiled_program) + end module Translate_ir = struct @@ -931,10 +938,11 @@ end module Run = struct open Tezos_utils.Micheline + open! Translate_program - let run_aux (program:program) (input_michelson:Michelson.t) : ex_typed_value result = + let run_aux (program:compiled_program) (input_michelson:Michelson.t) : ex_typed_value result = let open Meta_michelson.Wrap in - let%bind {input;output;body} = Translate_program.translate program in + let {input;output;body} : compiled_program = program in let (Ex_ty input_ty) = input in let (Ex_ty output_ty) = output in let%bind input = @@ -952,15 +960,24 @@ module Run = struct ok (Ex_typed_value (output_ty, output)) let run_node (program:program) (input:Michelson.t) : Michelson.t result = - let%bind (Ex_typed_value (output_ty, output)) = run_aux program input in + 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") @@ Tezos_utils.Memory_proto_alpha.unparse_michelson_data output_ty output in ok output + let run_entry (entry:anon_function) (input:value) : value result = + let%bind compiled = translate_entry entry in + let%bind input_michelson = translate_value input in + let%bind ex_ty_value = run_aux compiled input_michelson in + let%bind (result : value) = Translate_ir.translate_value ex_ty_value in + ok result + let run (program:program) (input:value) : value result = - let%bind input_michelson = Translate_program.translate_value input in - let%bind ex_ty_value = run_aux program input_michelson in + 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) = Translate_ir.translate_value ex_ty_value in ok result diff --git a/src/ligo/transpiler.ml b/src/ligo/transpiler.ml index 4ea2fe758..9b9186990 100644 --- a/src/ligo/transpiler.ml +++ b/src/ligo/transpiler.ml @@ -176,30 +176,33 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express | Constant (name, lst) -> let%bind lst' = bind_list @@ List.map (translate_annotated_expression env) lst in ok (Predicate (name, lst'), tv, env) - | Lambda { binder ; input_type ; output_type ; body ; result } -> - (* Try to type it in an empty env, if it succeeds, transpiles it as a quote value, else, as a closure expression. *) - let%bind empty_env = - let%bind input = translate_type input_type in - ok Environment.(add (binder, input) empty) in - match to_option (translate_block empty_env body), to_option (translate_annotated_expression empty_env result) with - | Some body, Some result -> - let capture_type = No_capture in - let%bind input = translate_type input_type in - let%bind output = translate_type output_type in - let content = {binder;input;output;body;result;capture_type} in - ok (Literal (`Function {capture=None;content}), tv, env) - | _ -> - (* Shallow capture. Capture the whole environment. Extend it with a new scope. Append it the input. *) - let%bind input = translate_type input_type in - let sub_env = Environment.extend env in - let full_env = Environment.add (binder, input) sub_env in - let%bind (_, post_env) as body = translate_block full_env body in - let%bind result = translate_annotated_expression post_env result in - let capture_type = Shallow_capture sub_env in - let input = Environment.to_mini_c_type full_env in - let%bind output = translate_type output_type in - let content = {binder;input;output;body;result;capture_type} in - ok (Function_expression content, tv, env) + | Lambda l -> translate_lambda env l tv + +and translate_lambda env l tv = + let { binder ; input_type ; output_type ; body ; result } : AST.lambda = l in + (* Try to type it in an empty env, if it succeeds, transpiles it as a quote value, else, as a closure expression. *) + let%bind empty_env = + let%bind input = translate_type input_type in + ok Environment.(add (binder, input) empty) in + match to_option (translate_block empty_env body), to_option (translate_annotated_expression empty_env result) with + | Some body, Some result -> + let capture_type = No_capture in + let%bind input = translate_type input_type in + let%bind output = translate_type output_type in + let content = {binder;input;output;body;result;capture_type} in + ok (Literal (`Function {capture=None;content}), tv, env) + | _ -> + (* Shallow capture. Capture the whole environment. Extend it with a new scope. Append it the input. *) + let%bind input = translate_type input_type in + let sub_env = Environment.extend env in + let full_env = Environment.add (binder, input) sub_env in + let%bind (_, post_env) as body = translate_block full_env body in + let%bind result = translate_annotated_expression post_env result in + let capture_type = Shallow_capture sub_env in + let input = Environment.to_mini_c_type full_env in + let%bind output = translate_type output_type in + let content = {binder;input;output;body;result;capture_type} in + ok (Function_expression content, tv, env) let translate_declaration env (d:AST.declaration) : toplevel_statement result = match d with @@ -217,6 +220,13 @@ let translate_program (lst:AST.program) : program result = let%bind (statements, _) = List.fold_left aux (ok ([], Environment.empty)) lst in ok statements +let translate_main (l:AST.lambda) (t:AST.type_value) : anon_function result = + let%bind t' = translate_type t in + let%bind (expr, _, _) = translate_lambda Environment.empty l t' in + match expr with + | Literal (`Function f) -> ok f + | _ -> simple_fail "main is not a function" + open Combinators let rec exp x n = @@ -303,7 +313,7 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression | Type_record m -> let lst = kv_list_of_map m in let%bind node = match Append_tree.of_list lst with - | Empty -> simple_fail "empty tuple" + | Empty -> simple_fail "empty record" | Full t -> ok t in let%bind lst = extract_record v node in let%bind lst = bind_list