diff --git a/src/lib_utils/trace.ml b/src/lib_utils/trace.ml index 8e22fd4b0..3c9d6b724 100644 --- a/src/lib_utils/trace.ml +++ b/src/lib_utils/trace.ml @@ -313,9 +313,16 @@ module Assert = struct Option.unopt ~default msg in assert_equal ~msg expected actual + let assert_none ?(msg="not a none") opt = match opt with + | None -> ok () + | _ -> simple_fail msg + let assert_list_size ?(msg="lst doesn't have the right size") lst n = assert_true ~msg List.(length lst = n) + let assert_list_empty ?(msg="lst isn't empty") lst = + assert_true ~msg List.(length lst = 0) + let assert_list_same_size ?(msg="lists don't have same size") a b = assert_true ~msg List.(length a = length b) diff --git a/src/ligo/contracts/basic.mligo b/src/ligo/contracts/basic.mligo new file mode 100644 index 000000000..34be829e0 --- /dev/null +++ b/src/ligo/contracts/basic.mligo @@ -0,0 +1,3 @@ +type toto = int + +let foo : toto = 42 + 127 diff --git a/src/ligo/multifix/generator.ml b/src/ligo/multifix/generator.ml index 4d61dcc00..e0be25303 100644 --- a/src/ligo/multifix/generator.ml +++ b/src/ligo/multifix/generator.ml @@ -32,6 +32,7 @@ module O = struct | `Named of string | `Token of token | `List of string list_element + | `Option of string ] type rhs = rhs_element list name @@ -61,7 +62,6 @@ module O = struct | `Lower ] - type operator = element list type n_operator = operator name @@ -166,6 +166,7 @@ module Print_AST = struct match e with | `Named s -> Some (s ^ " Location.wrap") | `List ( _, s) -> Some ("(" ^ s ^ " Location.wrap list)") + | `Option s -> Some ("(" ^ s ^ " Location.wrap option)") | `Token _ -> None in List.filter_map aux rhs.content in @@ -246,6 +247,7 @@ module Print_Grammar = struct let aux : _ -> O.rhs_element -> _ = fun ppf e -> (match e with | `Named s -> fprintf ppf "%s = wrap(%s)" letters.(!i) s + | `Option s -> fprintf ppf "%s = option(wrap(%s))" letters.(!i) s | `List (mode, s) -> fprintf ppf "%s = %swrap(%s))" letters.(!i) @@ -271,7 +273,7 @@ module Print_Grammar = struct let i = ref 0 in let aux : O.rhs_element -> _ = fun e -> let s = (match e with - | `Named _ | `List _ -> Some (letters.(!i)) + | `Named _ | `List _ | `Option _ -> Some (letters.(!i)) | `Token _ -> i := !i - 1 ; None) in i := !i + 1 ; s in @@ -626,13 +628,9 @@ module Type_expression = struct let application = empty_infix "application" `Left - (* let pair = infix "pair" `Left COMMA *) let tuple = make_name "tuple" [ `List (Separated_nene COMMA, `Lower) ] - (* let pair = make_name "tuple" [ - * `List (Separated COMMA, `Lower) - * ] *) let type_variable : O.n_operator = make_name "variable" [ `Named variable_name ] @@ -671,14 +669,44 @@ module Program = struct make_name "implicit_named_param" [ `Token TILDE ; `Named variable_name ] ; ] + let type_annotation_name = "type_annotation_" + + let type_annotation : O.rule = make_name type_annotation_name [ + make_name "" [ `Token COLON ; `Named type_expression_name ] ; + ] + + let let_content_name = "let_content" + let let_content : O.rule = make_name let_content_name [ + make_name "" [ + `Named variable_name ; + `List (Naked, param_name) ; + `Option type_annotation_name ; + `Token EQUAL ; + `Named expression_name ; + ] ; + ] + + (* let statement : O.rule = make_name statement_name [ + * make_name "variable_declaration" [`Token LET ; `List (Naked_ne, param_name) ; `Token EQUAL ; `Named expression_name] ; + * make_name "init_declaration" [`Token LET_INIT ; `List (Naked_ne, param_name) ; `Token EQUAL ; `Named expression_name] ; + * make_name "entry_declaration" [`Token LET_ENTRY ; `List (Naked_ne, param_name) ; `Token EQUAL ; `Named expression_name] ; + * make_name "type_declaration" [`Token TYPE ; `Named variable_name ; `Token EQUAL ; `Named type_expression_name] ; + * ] *) + let statement : O.rule = make_name statement_name [ - make_name "variable_declaration" [`Token LET ; `List (Naked_ne, param_name) ; `Token EQUAL ; `Named expression_name] ; - make_name "init_declaration" [`Token LET_INIT ; `List (Naked_ne, param_name) ; `Token EQUAL ; `Named expression_name] ; - make_name "entry_declaration" [`Token LET_ENTRY ; `List (Naked_ne, param_name) ; `Token EQUAL ; `Named expression_name] ; + make_name "variable_declaration" [`Token LET ; `Named let_content_name] ; + make_name "init_declaration" [`Token LET_INIT ; `Named let_content_name] ; + make_name "entry_declaration" [`Token LET_ENTRY ; `Named let_content_name] ; make_name "type_declaration" [`Token TYPE ; `Named variable_name ; `Token EQUAL ; `Named type_expression_name] ; ] - let singletons = List.map O.rule_singleton [program ; statement ; param] + let singletons = List.map O.rule_singleton [ + let_content ; + type_annotation ; + program ; + statement ; + param ; + ] end diff --git a/src/ligo/simplify_multifix.ml b/src/ligo/simplify_multifix.ml index bce76d617..0d7e5dfac 100644 --- a/src/ligo/simplify_multifix.ml +++ b/src/ligo/simplify_multifix.ml @@ -5,8 +5,23 @@ module O = Ast_simplified let unwrap : type a . a Location.wrap -> a = Location.unwrap +let type_constants = [ + ("unit", 0) ; + ("string", 0) ; + ("nat", 0) ; + ("int", 0) ; + ("bool", 0) ; + ("list", 1) ; + ("option", 1) ; + ("set", 1) ; + ("map", 2) ; +] + let type_variable : string -> O.type_expression result = fun str -> - ok @@ O.T_variable str + match List.assoc_opt str type_constants with + | Some 0 -> ok @@ O.T_constant (str, []) + | Some _ -> simple_fail "non-nullary type constructor" + | None -> ok @@ O.T_variable str let rec type_expression : I.type_expression -> O.type_expression result = fun te -> match te with @@ -60,21 +75,23 @@ let rec expression : I.expression -> O.annotated_expression result = fun e -> | E_main m -> let%bind m' = bind_map_location expression_main m in ok @@ unwrap m' - | E_record r -> - let aux : I.e_record_element -> _ = fun re -> - match re with - | E_record_element_record_implicit _ -> simple_fail "no implicit record element yet" - | E_record_element_record_explicit (s, e) -> - let%bind e' = bind_map_location expression_no_seq e in - ok (s, e') - in - let%bind r' = bind_map_list (bind_map_location aux) r in - let e_map = - let lst = List.map ((fun (x, y) -> unwrap x, unwrap y) >| unwrap) r' in - let open Map.String in - List.fold_left (fun prec (k , v) -> add k v prec) empty lst - in - ok @@ O.(ae @@ E_record e_map) + | E_record r -> expression_record r + +and expression_record : _ -> O.annotated_expression result = fun r -> + let aux : I.e_record_element -> _ = fun re -> + match re with + | E_record_element_record_implicit _ -> simple_fail "no implicit record element yet" + | E_record_element_record_explicit (s, e) -> + let%bind e' = bind_map_location expression_no_seq e in + ok (s, e') + in + let%bind r' = bind_map_list (bind_map_location aux) r in + let e_map = + let lst = List.map ((fun (x, y) -> unwrap x, unwrap y) >| unwrap) r' in + let open Map.String in + List.fold_left (fun prec (k , v) -> add k v prec) empty lst + in + ok @@ O.(ae @@ E_record e_map) and expression_main : I.expression_main -> O.annotated_expression result = fun em -> let return x = ok O.(ae x) in @@ -141,42 +158,39 @@ and expression_main : I.expression_main -> O.annotated_expression result = fun e and expression_no_seq : I.expression_no_seq -> O.annotated_expression result = fun mns -> match mns with - | _ -> simple_fail "todo" + | Es_record r -> expression_record r + | Es_let_in _ + | Es_ifthen _ + | Es_ifthenelse _ + -> simple_fail "not block expressions in local expressions yet" + | Es_fun _ -> simple_fail "no local functions yet" + | Es_match _ -> simple_fail "no match in expressions yet" + | Es_main e -> + expression_main (unwrap e) + +let let_content : I.let_content -> _ result = fun (Let_content (n, args, ty_opt, e)) -> + let%bind () = + trace_strong (simple_error "no sugar-candy for args yet") @@ + Assert.assert_list_empty args in + let%bind ty = + trace_option (simple_error "top-level declarations need a type") @@ + ty_opt in + let%bind e' = bind_map_location expression e in + let%bind () = + trace_strong (simple_error "no annotation for a top-level expression") @@ + Assert.assert_none (unwrap e').type_annotation in + let e'' = (unwrap e').expression in + let%bind ty' = + let (I.Type_annotation_ ty') = unwrap ty in + bind_map_location type_expression ty' in + let ae = O.annotated_expression e'' (Some (unwrap ty')) in + ok @@ O.Declaration_constant {name = (unwrap n) ; annotated_expression = ae} let statement : I.statement -> O.declaration result = fun s -> match s with - | Statement_variable_declaration ([n], e) -> - let%bind (name, ty) = - let%bind pattern = - match unwrap n with - | Param_restricted_pattern c -> ok c - | Param_implicit_named_param _ -> simple_fail "" in - match unwrap pattern with - | Pr_restrict c -> ( - match unwrap c with - | P_type_annotation (l, te) -> ( - let%bind v = match unwrap l with - | P_variable v -> ok v - | _ -> simple_fail "no sugar-candy for regular declarations yet" - in - ok (v, te) - ) - | _ -> simple_fail "no sugar-candy for regular declarations yet" - ) - | Pr_variable _ -> simple_fail "provide type for top-level declarations!" - | Pr_unit _ -> simple_fail "define unit is meaningless" - in - let name' = unwrap name in - let%bind e' = bind_map_location expression e in - let%bind ty' = bind_map_location restricted_type_expression ty in - let%bind e'' = match (unwrap e').type_annotation with - | None -> ok (unwrap e').expression - | Some _ -> simple_fail "can't add an annotation at the expression of a declaration" in - let ae = O.annotated_expression e'' (Some (unwrap ty')) in - ok @@ O.Declaration_constant {name = name' ; annotated_expression = ae} - | Statement_variable_declaration _ -> simple_fail "no sugar-candy for fun declarations yet" - | Statement_init_declaration _ -> simple_fail "no init declaration yet" - | Statement_entry_declaration _ -> simple_fail "no entry declaration yet" + | Statement_variable_declaration x -> let_content (unwrap x) + | Statement_init_declaration x -> let_content (unwrap x) + | Statement_entry_declaration x -> let_content (unwrap x) | Statement_type_declaration (n, te) -> let%bind te' = bind_map_location type_expression te in ok @@ O.Declaration_type {type_name = unwrap n ; type_expression = unwrap te'} diff --git a/src/ligo/test/multifix_tests.ml b/src/ligo/test/multifix_tests.ml index c313ec8bd..b079c6a59 100644 --- a/src/ligo/test/multifix_tests.ml +++ b/src/ligo/test/multifix_tests.ml @@ -7,11 +7,19 @@ let basic () : unit result = ok () let simplify () : unit result = - let%bind raw = User.parse_file "./contracts/new-syntax.mligo" in + let%bind raw = User.parse_file "./contracts/basic.mligo" in let%bind _simpl = Ligo.Simplify_multifix.main raw in ok () -let main = "Parser Multifix", [ +let integration () : unit result = + let%bind raw = User.parse_file "./contracts/basic.mligo" in + let%bind simpl = Ligo.Simplify_multifix.main raw in + let%bind typed = Ligo.Typer.type_program (Location.unwrap simpl) in + let%bind result = Ligo.easy_evaluate_typed "foo" typed in + Ligo.AST_Typed.assert_value_eq (Ligo.AST_Typed.Combinators.e_a_int (42 + 127), result) + +let main = "Multifix", [ test "basic" basic ; - test "simplify" simplify ; + test "simplfiy" simplify ; + test "integration" integration ; ]