From 0f7f726d13f86973efa6522b6c2474a2fc3eb4b4 Mon Sep 17 00:00:00 2001 From: Galfour Date: Wed, 24 Apr 2019 09:14:43 +0000 Subject: [PATCH] extend camligo simplifier --- src/ligo/ast_simplified/combinators.ml | 11 ++ src/ligo/operators/operators.ml | 1 + src/ligo/parser/camligo/generator.ml | 2 +- src/ligo/simplify/camligo.ml | 168 +++++++++++++++++++++---- src/ligo/test/multifix_tests.ml | 2 +- 5 files changed, 161 insertions(+), 23 deletions(-) diff --git a/src/ligo/ast_simplified/combinators.ml b/src/ligo/ast_simplified/combinators.ml index 833e70f71..3c15fb89c 100644 --- a/src/ligo/ast_simplified/combinators.ml +++ b/src/ligo/ast_simplified/combinators.ml @@ -1,4 +1,5 @@ open Types +open Trace module SMap = Map.String @@ -6,6 +7,16 @@ let get_name : named_expression -> string = fun x -> x.name let get_type_name : named_type_expression -> string = fun x -> x.type_name let get_type_annotation (x:annotated_expression) = x.type_annotation +let i_assignment : _ -> instruction = fun x -> I_assignment x +let named_expression name annotated_expression = { name ; annotated_expression } +let named_typed_expression name expression ty = { name ; annotated_expression = { expression ; type_annotation = Some ty } } + +let get_untyped_expression : annotated_expression -> expression result = fun ae -> + let%bind () = + trace_strong (simple_error "expression is typed") @@ + Assert.assert_none ae.type_annotation in + ok ae.expression + let t_bool : type_expression = T_constant ("bool", []) let t_string : type_expression = T_constant ("string", []) let t_bytes : type_expression = T_constant ("bytes", []) diff --git a/src/ligo/operators/operators.ml b/src/ligo/operators/operators.ml index 49a7b661d..d66d44037 100644 --- a/src/ligo/operators/operators.ml +++ b/src/ligo/operators/operators.ml @@ -13,6 +13,7 @@ module Simplify = struct ("option" , 1) ; ("set" , 1) ; ("map" , 2) ; + ("big_map" , 2) ; ] let constants = [ diff --git a/src/ligo/parser/camligo/generator.ml b/src/ligo/parser/camligo/generator.ml index e0be25303..bd5ef27ec 100644 --- a/src/ligo/parser/camligo/generator.ml +++ b/src/ligo/parser/camligo/generator.ml @@ -210,7 +210,7 @@ module Print_AST = struct let levels = List.Ne.map get_content ((get_content nh).levels) in let nops = List.Ne.concat levels in let name = get_name nh in - fprintf ppf "%s %s = @.@[%a@]" t + fprintf ppf "%s %s =@.@[%a@]" t name (list_sep (n_operator nh.content.prefix name) new_line) nops diff --git a/src/ligo/simplify/camligo.ml b/src/ligo/simplify/camligo.ml index 8acfe85c3..2db20b0aa 100644 --- a/src/ligo/simplify/camligo.ml +++ b/src/ligo/simplify/camligo.ml @@ -14,6 +14,46 @@ let type_variable : string -> O.type_expression result = fun str -> | Some _ -> simple_fail "non-nullary type constructor" | None -> ok @@ O.T_variable str +let get_param_restricted_pattern : I.param -> I.restricted_pattern Location.wrap result = fun p -> + match p with + | I.Param_restricted_pattern c -> ok c + | _ -> simple_fail "not a restricted param pattern" + +let get_unrestricted_pattern : I.restricted_pattern -> I.pattern Location.wrap result = fun rp -> + match rp with + | I.Pr_restrict p -> ok p + | _ -> simple_fail "not an unrestricted pattern" + +let get_p_type_annotation : I.pattern -> (I.pattern Location.wrap * I.restricted_type_expression Location.wrap) result = fun p -> + match p with + | I.P_type_annotation pta -> ok pta + | _ -> simple_fail "not a pattern type annotation" + +let get_p_variable : I.pattern -> string Location.wrap result = fun p -> + match p with + | I.P_variable v -> ok v + | _ -> simple_fail "not a pattern variable" + +let get_p_typed_variable : I.pattern -> (string Location.wrap * I.restricted_type_expression Location.wrap) result = fun p -> + let%bind (p' , rte) = get_p_type_annotation p in + let%bind var = get_p_variable (unwrap p') in + ok (var , rte) + +let get_arg : I.param -> _ result = fun arg -> + let%bind rp = + get_param_restricted_pattern arg >>? + Function.compose get_unrestricted_pattern unwrap in + let%bind (var , rte) = get_p_typed_variable (unwrap rp) in + ok (var , rte) + +let get_type_annotation_ : I.type_annotation_ -> I.type_expression Location.wrap result = fun p -> + match p with + | I.Type_annotation_ p -> ok p + +let get_e_match_clause : I.e_match_clause -> (I.pattern Location.wrap * I.expression_no_match Location.wrap) result = fun e -> + match e with + | E_match_clause c -> ok c + let rec type_expression : I.type_expression -> O.type_expression result = fun te -> match te with | T_variable tv -> @@ -37,15 +77,31 @@ let rec type_expression : I.type_expression -> O.type_expression result = fun te List.fold_left (fun prec (k , v) -> add k v prec) empty lst in ok @@ O.T_record te_map - | T_application (f, arg) -> - let%bind (f', arg') = bind_map_pair (bind_map_location type_expression) (f, arg) in - let%bind name = match unwrap f' with - | O.T_variable v -> ok v - | _ -> simple_fail "can't apply to non-vars" in - let args = match unwrap arg' with - | T_tuple lst -> lst - | x -> [ x ] in - ok @@ O.T_constant (name, args) + | T_application (arg , f) -> + let%bind arg' = bind_map_location type_expression arg in + match unwrap f with + | I.T_variable v -> ( + match List.assoc_opt v.wrap_content type_constants with + | Some n -> ( + match arg'.wrap_content with + | T_tuple lst -> ( + let%bind () = + trace (simple_error "bad arity") @@ + Assert.assert_list_size lst n in + ok @@ O.T_constant (v.wrap_content , lst) + ) + | _ -> simple_fail "bad arity" + ) + | None -> ( + let error = + let title () = "unrecognized type-constant" in + let content () = Format.asprintf "%s" v.wrap_content in + error title content + in + fail error + ) + ) + | _ -> simple_fail "type applying to non-var" let restricted_type_expression : I.restricted_type_expression -> O.type_expression result = fun rte -> match rte with @@ -68,6 +124,71 @@ let rec expression : I.expression -> O.annotated_expression result = fun e -> ok @@ unwrap m' | E_record r -> expression_record r +and expression_no_match_block : I.expression_no_match -> O.block result = fun e -> + match e with + | I.Em_let_in _|I.Em_fun _|I.Em_record _|I.Em_ifthenelse _|I.Em_ifthen _ + |I.Em_main _ -> simple_fail "lel" + +and sequence_block : I.expression Location.wrap list -> O.block result = fun s -> + let%bind blocks = bind_map_list (bind_map_location expression_block) s in + let block = List.(concat @@ map unwrap blocks) in + ok block + +and let_in_block : (I.pattern Location.wrap * I.expression Location.wrap * I.expression Location.wrap) -> O.block result = + fun (var , expr , body) -> + let%bind (var' , te) = get_p_typed_variable (unwrap var) in + let%bind expr' = + let%bind expr' = bind_map_location expression expr in + bind_map_location O.Combinators.get_untyped_expression expr' in + let%bind te' = bind_map_location restricted_type_expression te in + let instruction = O.Combinators.(i_assignment @@ named_typed_expression (unwrap var') (unwrap expr') (unwrap te')) in + let%bind body' = bind_map_location expression_block body in + ok @@ instruction :: (unwrap body') + +and if_then_else_block : (I.expression Location.wrap * I.expression Location.wrap * I.expression Location.wrap) -> O.block result = + fun (cond , branch_true , branch_false) -> + let%bind cond' = bind_map_location expression cond in + let%bind branch_true' = bind_map_location expression_block branch_true in + let%bind branch_false' = bind_map_location expression_block branch_false in + ok [ O.I_matching ((unwrap cond') , Match_bool { match_true = (unwrap branch_true') ; match_false = (unwrap branch_false') }) ] + +and if_then_block : (I.expression Location.wrap * I.expression Location.wrap) -> O.block result = + fun (cond , branch_true) -> + let%bind cond' = bind_map_location expression cond in + let%bind branch_true' = bind_map_location expression_block branch_true in + let branch_false = O.I_skip in + ok [ O.I_matching ((unwrap cond') , Match_bool { match_true = (unwrap branch_true') ; match_false = [ branch_false ] }) ] + +and match_clauses : type a . (I.pattern * a) list -> a O.matching result = fun _clauses -> + let match_bool _ = simple_fail "" in + let match_stuff _ = simple_fail "" in + bind_find_map_list (simple_error "no weird matching yet") (fun f -> f ()) [ match_bool ; match_stuff ] + +and match_block : _ -> O.block result = fun (case , clauses) -> + let%bind case' = bind_map_location expression case in + let%bind clauses' = + let u = List.map unwrap clauses in + let%bind cs = bind_map_list get_e_match_clause u in + let ucs = List.map (Tuple.map_h_2 unwrap unwrap) cs in + let%bind ucs' = + let aux (x , y) = + let%bind y' = expression_no_match_block y in + ok (x , y') in + bind_map_list aux ucs in + ok ucs' in + let%bind matching = match_clauses clauses' in + ok [ O.I_matching ((unwrap case') , matching) ] + +and expression_block : I.expression -> O.block result = fun e -> + match e with + | I.E_sequence s -> sequence_block s + | I.E_let_in li -> let_in_block li + | I.E_ifthenelse ite -> if_then_else_block ite + | I.E_ifthen it -> if_then_block it + | I.E_match cc -> match_block cc + |I.E_fun _|I.E_record _ + |I.E_main _ -> simple_fail "no regular expression in blocks" + and expression_record : _ -> O.annotated_expression result = fun r -> let aux : I.e_record_element -> _ = fun re -> match re with @@ -163,19 +284,24 @@ let let_content : I.let_content -> _ result = fun (Let_content (n, args, ty_opt, 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 args' = bind_map_list (bind_map_location get_arg) args in let%bind ty' = - let (I.Type_annotation_ ty') = unwrap ty in - bind_map_location type_expression ty' in - let ae = make_e_a_full e'' (unwrap ty') in - ok @@ O.Declaration_constant {name = (unwrap n) ; annotated_expression = ae} + let%bind tya = + trace_option (simple_error "top-level declarations need a type") @@ + ty_opt in + let%bind ty = get_type_annotation_ (unwrap tya) in + bind_map_location type_expression ty in + match args' with + | [] -> ( (* No arguments. Simplify as regular value. *) + let%bind e' = + let%bind e' = bind_map_location expression e in + bind_map_location O.Combinators.get_untyped_expression e' in + let ae = make_e_a_full (unwrap e') (unwrap ty') in + ok @@ O.Declaration_constant {name = (unwrap n) ; annotated_expression = ae} + ) + | _lst -> ( (* Arguments without fun. *) + simple_fail "no syntactic sugar for functions yet" + ) let statement : I.statement -> O.declaration result = fun s -> match s with diff --git a/src/ligo/test/multifix_tests.ml b/src/ligo/test/multifix_tests.ml index 995a4dbc9..134ddf253 100644 --- a/src/ligo/test/multifix_tests.ml +++ b/src/ligo/test/multifix_tests.ml @@ -7,7 +7,7 @@ let basic () : unit result = ok () let simplify () : unit result = - let%bind raw = User.parse_file "./contracts/basic.mligo" in + let%bind raw = User.parse_file "./contracts/new-syntax.mligo" in let%bind _simpl = Simplify.Camligo.main raw in ok ()