diff --git a/src/ligo/ast_simplified/PP.ml b/src/ligo/ast_simplified/PP.ml index f8fc9cc65..b6d7beb0a 100644 --- a/src/ligo/ast_simplified/PP.ml +++ b/src/ligo/ast_simplified/PP.ml @@ -59,6 +59,8 @@ and annotated_expression ppf (ae:annotated_expression) = match ae.type_annotatio | None -> fprintf ppf "%a" expression ae.expression | Some t -> fprintf ppf "(%a) : %a" expression ae.expression type_expression t +and value : _ -> value -> unit = fun x -> annotated_expression x + and block ppf (b:block) = (list_sep instruction (tag "@;")) ppf b and single_record_patch ppf ((p, ae) : string * ae) = diff --git a/src/ligo/ast_simplified/combinators.ml b/src/ligo/ast_simplified/combinators.ml index 9e53ab31a..b567c4afd 100644 --- a/src/ligo/ast_simplified/combinators.ml +++ b/src/ligo/ast_simplified/combinators.ml @@ -2,6 +2,7 @@ open Types module SMap = Map.String + let t_bool : type_expression = T_constant ("bool", []) let t_string : type_expression = T_constant ("string", []) let t_bytes : type_expression = T_constant ("bytes", []) @@ -43,6 +44,8 @@ let e_bool b : expression = E_literal (Literal_bool b) let e_string s : expression = E_literal (Literal_string s) let e_bytes b : expression = E_literal (Literal_bytes (Bytes.of_string b)) +let e_a_int n : annotated_expression = make_e_a_full (e_int n) t_int + let e_lambda (binder : string) (input_type : type_expression) (output_type : type_expression) diff --git a/src/ligo/ast_simplified/misc.ml b/src/ligo/ast_simplified/misc.ml index 48530be56..02788c082 100644 --- a/src/ligo/ast_simplified/misc.ml +++ b/src/ligo/ast_simplified/misc.ml @@ -1,3 +1,111 @@ +open Trace +open Types + +let assert_literal_eq (a, b : literal * literal) : unit result = + match (a, b) with + | Literal_bool a, Literal_bool b when a = b -> ok () + | Literal_bool _, Literal_bool _ -> simple_fail "different bools" + | Literal_bool _, _ -> simple_fail "bool vs non-bool" + | Literal_int a, Literal_int b when a = b -> ok () + | Literal_int _, Literal_int _ -> simple_fail "different ints" + | Literal_int _, _ -> simple_fail "int vs non-int" + | Literal_nat a, Literal_nat b when a = b -> ok () + | Literal_nat _, Literal_nat _ -> simple_fail "different nats" + | Literal_nat _, _ -> simple_fail "nat vs non-nat" + | Literal_string a, Literal_string b when a = b -> ok () + | Literal_string _, Literal_string _ -> simple_fail "different strings" + | Literal_string _, _ -> simple_fail "string vs non-string" + | Literal_bytes a, Literal_bytes b when a = b -> ok () + | Literal_bytes _, Literal_bytes _ -> simple_fail "different bytess" + | Literal_bytes _, _ -> simple_fail "bytes vs non-bytes" + | Literal_unit, Literal_unit -> ok () + | Literal_unit, _ -> simple_fail "unit vs non-unit" + +let rec assert_value_eq (a, b: (value*value)) : unit result = + let error_content () = + Format.asprintf "%a vs %a" PP.value a PP.value b + in + trace (fun () -> error (thunk "not equal") error_content ()) @@ + match (a.expression, b.expression) with + | E_literal a, E_literal b -> + assert_literal_eq (a, b) + | E_constant (ca, lsta), E_constant (cb, lstb) when ca = cb -> ( + let%bind lst = + generic_try (simple_error "constants with different number of elements") + (fun () -> List.combine lsta lstb) in + let%bind _all = bind_list @@ List.map assert_value_eq lst in + ok () + ) + | E_constant _, E_constant _ -> + simple_fail "different constants" + | E_constant _, _ -> + let error_content () = + Format.asprintf "%a vs %a" + PP.annotated_expression a + PP.annotated_expression b + in + fail @@ (fun () -> error (thunk "comparing constant with other stuff") error_content ()) + + | E_constructor (ca, a), E_constructor (cb, b) when ca = cb -> ( + let%bind _eq = assert_value_eq (a, b) in + ok () + ) + | E_constructor _, E_constructor _ -> + simple_fail "different constructors" + | E_constructor _, _ -> + simple_fail "comparing constructor with other stuff" + + | E_tuple lsta, E_tuple lstb -> ( + let%bind lst = + generic_try (simple_error "tuples with different number of elements") + (fun () -> List.combine lsta lstb) in + let%bind _all = bind_list @@ List.map assert_value_eq lst in + ok () + ) + | E_tuple _, _ -> + simple_fail "comparing tuple with other stuff" + + | E_record sma, E_record smb -> ( + let aux _ a b = + match a, b with + | Some a, Some b -> Some (assert_value_eq (a, b)) + | _ -> Some (simple_fail "different record keys") + in + let%bind _all = bind_smap @@ Map.String.merge aux sma smb in + ok () + ) + | E_record _, _ -> + simple_fail "comparing record with other stuff" + + | E_map lsta, E_map lstb -> ( + let%bind lst = generic_try (simple_error "maps of different lengths") + (fun () -> + let lsta' = List.sort compare lsta in + let lstb' = List.sort compare lstb in + List.combine lsta' lstb') in + let aux = fun ((ka, va), (kb, vb)) -> + let%bind _ = assert_value_eq (ka, kb) in + let%bind _ = assert_value_eq (va, vb) in + ok () in + let%bind _all = bind_map_list aux lst in + ok () + ) + | E_map _, _ -> + simple_fail "comparing map with other stuff" + + | E_list lsta, E_list lstb -> ( + let%bind lst = + generic_try (simple_error "list of different lengths") + (fun () -> List.combine lsta lstb) in + let%bind _all = bind_map_list assert_value_eq lst in + ok () + ) + | E_list _, _ -> + simple_fail "comparing list with other stuff" + + | _, _ -> simple_fail "comparing not a value" + + (* module Rename = struct * open Trace * diff --git a/src/ligo/ast_simplified/types.ml b/src/ligo/ast_simplified/types.ml index ce5d83b29..fc1472b06 100644 --- a/src/ligo/ast_simplified/types.ml +++ b/src/ligo/ast_simplified/types.ml @@ -11,6 +11,8 @@ and declaration = | Declaration_constant of named_expression (* | Macro_declaration of macro_declaration *) +and value = annotated_expression + and annotated_expression = { expression: expression ; type_annotation: te option ; diff --git a/src/ligo/ligo.ml b/src/ligo/ligo.ml index 5234ccc70..d2c0446b0 100644 --- a/src/ligo/ligo.ml +++ b/src/ligo/ligo.ml @@ -1,8 +1,6 @@ -open Ligo_parser - +open Trace module Parser = Parser -module Lexer = Lexer -module AST_Raw = AST +module AST_Raw = Ligo_parser.AST module AST_Simplified = Ast_simplified module AST_Typed = Ast_typed module Mini_c = Mini_c @@ -11,103 +9,6 @@ module Transpiler = Transpiler module Parser_multifix = Multifix module Simplify_multifix = Simplify_multifix -open Trace - -let parse_file (source: string) : AST_Raw.t result = - let pp_input = - let prefix = Filename.(source |> basename |> remove_extension) - and suffix = ".pp.ligo" - in prefix ^ suffix in - - let cpp_cmd = Printf.sprintf "cpp -traditional-cpp %s -o %s" - source pp_input in - let%bind () = sys_command cpp_cmd in - - let%bind channel = - generic_try (simple_error "error opening file") @@ - (fun () -> open_in pp_input) in - let lexbuf = Lexing.from_channel channel in - let module Lexer = Lexer.Make(LexToken) in - let Lexer.{read ; close} = - Lexer.open_token_stream None in - specific_try (fun () -> function - | Parser.Error -> ( - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - let str = Format.sprintf - "Parse error at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n" - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) - start.pos_fname source - in - simple_error str - ) - | _ -> - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - let str = Format.sprintf - "Unrecognized error at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n" - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) - start.pos_fname source - in - simple_error str - ) @@ (fun () -> - let raw = Parser.contract read lexbuf in - close () ; - raw - ) >>? fun raw -> - ok raw - -let parse (s:string) : AST_Raw.t result = - let lexbuf = Lexing.from_string s in - let module Lexer = Lexer.Make(LexToken) in - let Lexer.{read ; close} = - Lexer.open_token_stream None in - specific_try (fun () -> function - | Parser.Error -> ( - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - let str = Format.sprintf - "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n" - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in - simple_error str - ) - | _ -> simple_error "unrecognized parse_ error" - ) @@ (fun () -> - let raw = Parser.contract read lexbuf in - close () ; - raw - ) >>? fun raw -> - ok raw - -let parse_expression (s:string) : AST_Raw.expr result = - let lexbuf = Lexing.from_string s in - let module Lexer = Lexer.Make(LexToken) in - let Lexer.{read ; close} = - Lexer.open_token_stream None in - specific_try (fun () -> function - | Parser.Error -> ( - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - let str = Format.sprintf - "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n" - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in - simple_error str - ) - | _ -> simple_error "unrecognized parse_ error" - ) @@ (fun () -> - let raw = Parser.interactive_expr read lexbuf in - close () ; - raw - ) >>? fun raw -> - ok raw let simplify (p:AST_Raw.t) : Ast_simplified.program result = Simplify.simpl_program p let simplify_expr (e:AST_Raw.expr) : Ast_simplified.annotated_expression result = Simplify.simpl_expression e @@ -144,7 +45,7 @@ let compile : Mini_c.program -> string -> Compiler.Program.compiled_program resu let type_file ?(debug_simplify = false) ?(debug_typed = false) (path:string) : AST_Typed.program result = - let%bind raw = parse_file path in + let%bind raw = Parser.parse_file path in let%bind simpl = trace (simple_error "simplifying") @@ simplify raw in @@ -202,6 +103,37 @@ let easy_run_typed untranspile_value mini_c_result main_result_type in ok typed_result +let easy_run_typed_simplified + ?(debug_mini_c = false) (entry:string) + (program:AST_Typed.program) (input:Ast_simplified.annotated_expression) : AST_Typed.annotated_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.content) + ) ; + + let%bind typed_value = type_expression 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.content + in + error title content in + trace error @@ + Run.Mini_c.run_entry 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_main_typed ?(debug_mini_c = false) (program:AST_Typed.program) (input:AST_Typed.annotated_expression) : AST_Typed.annotated_expression result = @@ -210,7 +142,7 @@ let easy_run_main_typed let easy_run_main (path:string) (input:string) : AST_Typed.annotated_expression result = let%bind typed = type_file path in - let%bind raw_expr = parse_expression input in + let%bind raw_expr = Parser.parse_expression input in let%bind simpl_expr = simplify_expr raw_expr in let%bind typed_expr = type_expression simpl_expr in easy_run_main_typed typed typed_expr @@ -218,7 +150,7 @@ let easy_run_main (path:string) (input:string) : AST_Typed.annotated_expression let compile_file (source: string) (entry_point:string) : Micheline.Michelson.t result = let%bind raw = trace (simple_error "parsing") @@ - parse_file source in + Parser.parse_file source in let%bind simplified = trace (simple_error "simplifying") @@ simplify raw in diff --git a/src/ligo/parser.ml b/src/ligo/parser.ml new file mode 100644 index 000000000..05f8809c6 --- /dev/null +++ b/src/ligo/parser.ml @@ -0,0 +1,99 @@ +open Trace +open Ligo_parser +module AST_Raw = Ligo_parser.AST + +let parse_file (source: string) : AST_Raw.t result = + let pp_input = + let prefix = Filename.(source |> basename |> remove_extension) + and suffix = ".pp.ligo" + in prefix ^ suffix in + + let cpp_cmd = Printf.sprintf "cpp -traditional-cpp %s -o %s" + source pp_input in + let%bind () = sys_command cpp_cmd in + + let%bind channel = + generic_try (simple_error "error opening file") @@ + (fun () -> open_in pp_input) in + let lexbuf = Lexing.from_channel channel in + let module Lexer = Lexer.Make(LexToken) in + let Lexer.{read ; close} = + Lexer.open_token_stream None in + specific_try (fun () -> function + | Parser.Error -> ( + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + let str = Format.sprintf + "Parse error at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n" + (Lexing.lexeme lexbuf) + start.pos_lnum (start.pos_cnum - start.pos_bol) + end_.pos_lnum (end_.pos_cnum - end_.pos_bol) + start.pos_fname source + in + simple_error str + ) + | _ -> + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + let str = Format.sprintf + "Unrecognized error at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n" + (Lexing.lexeme lexbuf) + start.pos_lnum (start.pos_cnum - start.pos_bol) + end_.pos_lnum (end_.pos_cnum - end_.pos_bol) + start.pos_fname source + in + simple_error str + ) @@ (fun () -> + let raw = Parser.contract read lexbuf in + close () ; + raw + ) >>? fun raw -> + ok raw + +let parse_string (s:string) : AST_Raw.t result = + let lexbuf = Lexing.from_string s in + let module Lexer = Lexer.Make(LexToken) in + let Lexer.{read ; close} = + Lexer.open_token_stream None in + specific_try (fun () -> function + | Parser.Error -> ( + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + let str = Format.sprintf + "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n" + (Lexing.lexeme lexbuf) + start.pos_lnum (start.pos_cnum - start.pos_bol) + end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in + simple_error str + ) + | _ -> simple_error "unrecognized parse_ error" + ) @@ (fun () -> + let raw = Parser.contract read lexbuf in + close () ; + raw + ) >>? fun raw -> + ok raw + +let parse_expression (s:string) : AST_Raw.expr result = + let lexbuf = Lexing.from_string s in + let module Lexer = Lexer.Make(LexToken) in + let Lexer.{read ; close} = + Lexer.open_token_stream None in + specific_try (fun () -> function + | Parser.Error -> ( + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + let str = Format.sprintf + "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n" + (Lexing.lexeme lexbuf) + start.pos_lnum (start.pos_cnum - start.pos_bol) + end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in + simple_error str + ) + | _ -> simple_error "unrecognized parse_ error" + ) @@ (fun () -> + let raw = Parser.interactive_expr read lexbuf in + close () ; + raw + ) >>? fun raw -> + ok raw diff --git a/src/ligo/test/integration_tests.ml b/src/ligo/test/integration_tests.ml index 3916a2e9c..57f64f254 100644 --- a/src/ligo/test/integration_tests.ml +++ b/src/ligo/test/integration_tests.ml @@ -2,27 +2,18 @@ open Trace open Ligo open Test_helpers -let pass (source:string) : unit result = - let%bind raw = - trace (simple_error "parsing") @@ - parse_file source in - let%bind simplified = - trace (simple_error "simplifying") @@ - simplify raw in - let%bind typed = - trace (simple_error "typing") @@ - type_ simplified in - let%bind _mini_c = - trace (simple_error "transpiling") @@ - transpile typed in - ok () - -let basic () : unit result = - pass "./contracts/toto.ligo" - let function_ () : unit result = - let%bind _ = pass "./contracts/function.ligo" in - let%bind _ = easy_run_main "./contracts/function.ligo" "2" in + let%bind program = type_file "./contracts/function.ligo" in + let aux n = + let open Ast_simplified.Combinators in + let input = e_a_int n in + let%bind result = easy_run_typed_simplified "main" program input in + let expected = Ast_typed.Combinators.e_a_empty_int n in + Ast_typed.assert_value_eq (expected , result) + in + let%bind _ = bind_list + @@ List.map aux + @@ [0 ; 2 ; 42 ; 163 ; -1] in ok () let complex_function () : unit result = @@ -562,7 +553,6 @@ let counter_contract () : unit result = ok () let main = "Integration (End to End)", [ - test "basic" basic ; test "function" function_ ; test "complex function" complex_function ; test "closure" closure ;