refactor more

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) =

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)

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
  *

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 ;

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

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

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 ;