From badda06e7b7842444279a81a00902c33eacc9334 Mon Sep 17 00:00:00 2001 From: Galfour Date: Fri, 12 Apr 2019 13:30:11 +0000 Subject: [PATCH] start simplify liquidity --- src/lib_utils/function.ml | 2 + src/lib_utils/location.ml | 2 + src/lib_utils/tezos_utils.ml | 2 + src/lib_utils/trace.ml | 6 ++ src/ligo/ligo.ml | 1 + src/ligo/multifix/.gitignore | 1 + src/ligo/multifix/dune | 1 + src/ligo/multifix/generator.ml | 170 ++++++++++++++++--------------- src/ligo/multifix/pre_parser.mly | 2 +- src/ligo/simplify_mixfix.ml | 2 - src/ligo/simplify_multifix.ml | 18 ++++ src/ligo/test/multifix_tests.ml | 6 ++ 12 files changed, 130 insertions(+), 83 deletions(-) create mode 100644 src/lib_utils/function.ml create mode 100644 src/ligo/multifix/.gitignore delete mode 100644 src/ligo/simplify_mixfix.ml create mode 100644 src/ligo/simplify_multifix.ml diff --git a/src/lib_utils/function.ml b/src/lib_utils/function.ml new file mode 100644 index 000000000..d60c3b391 --- /dev/null +++ b/src/lib_utils/function.ml @@ -0,0 +1,2 @@ +let compose = fun f g x -> f (g x) +let (>|) = compose diff --git a/src/lib_utils/location.ml b/src/lib_utils/location.ml index 5fbea6e3b..825cdd0bb 100644 --- a/src/lib_utils/location.ml +++ b/src/lib_utils/location.ml @@ -29,3 +29,5 @@ type 'a wrap = { } let wrap ~loc wrap_content = { wrap_content ; location = loc } +let unwrap { wrap_content ; _ } = wrap_content +let map f x = { x with wrap_content = f x.wrap_content } diff --git a/src/lib_utils/tezos_utils.ml b/src/lib_utils/tezos_utils.ml index 32a7e47ab..aecd41270 100644 --- a/src/lib_utils/tezos_utils.ml +++ b/src/lib_utils/tezos_utils.ml @@ -6,6 +6,8 @@ module Time = Tezos_base.TzPervasives.Time module Memory_proto_alpha = X_memory_proto_alpha module Micheline = X_tezos_micheline + +module Function = Function module Error_monad = X_error_monad module Trace = Trace module PP_helpers = PP diff --git a/src/lib_utils/trace.ml b/src/lib_utils/trace.ml index 3cf4c80ec..7134a545a 100644 --- a/src/lib_utils/trace.ml +++ b/src/lib_utils/trace.ml @@ -110,6 +110,12 @@ let bind_map_smap f smap = bind_smap (X_map.String.map f smap) let bind_map_list f lst = bind_list (List.map f lst) +let bind_location (x:_ Location.wrap) = + x.wrap_content >>? fun wrap_content -> + ok { x with wrap_content } + +let bind_map_location f x = bind_location (Location.map f x) + let bind_fold_list f init lst = let aux x y = x >>? fun x -> diff --git a/src/ligo/ligo.ml b/src/ligo/ligo.ml index 7b7d949e6..9e8576995 100644 --- a/src/ligo/ligo.ml +++ b/src/ligo/ligo.ml @@ -9,6 +9,7 @@ module Mini_c = Mini_c module Typer = Typer module Transpiler = Transpiler module Parser_multifix = Multifix +module Simplify_multifix = Simplify_multifix open Trace diff --git a/src/ligo/multifix/.gitignore b/src/ligo/multifix/.gitignore new file mode 100644 index 000000000..5ff5d89f9 --- /dev/null +++ b/src/ligo/multifix/.gitignore @@ -0,0 +1 @@ +ast.ml diff --git a/src/ligo/multifix/dune b/src/ligo/multifix/dune index 31e067ec1..22b8c87a1 100644 --- a/src/ligo/multifix/dune +++ b/src/ligo/multifix/dune @@ -38,6 +38,7 @@ (targets ast.ml) (deps generator.exe) (action (system "./generator.exe ast > ast.ml")) + (mode promote-until-clean) ) ;; Generating Generator diff --git a/src/ligo/multifix/generator.ml b/src/ligo/multifix/generator.ml index 4eeecb4c5..6f28b6428 100644 --- a/src/ligo/multifix/generator.ml +++ b/src/ligo/multifix/generator.ml @@ -70,11 +70,12 @@ module O = struct type levels = level List.Ne.t type hierarchy = { + prefix : string ; levels : levels ; auxiliary_rules : rule list ; } type n_hierarchy = hierarchy name - let make_hierarchy levels auxiliary_rules : hierarchy = { levels ; auxiliary_rules } + let make_hierarchy prefix levels auxiliary_rules : hierarchy = { levels ; auxiliary_rules ; prefix } type language = { entry_point : string ; @@ -89,11 +90,11 @@ module O = struct let language entry_point singletons hierarchies = {entry_point ; singletons ; hierarchies} - let name_hierarchy name : n_operators list -> rule list -> n_hierarchy = fun nopss rules -> + let name_hierarchy name prefix : n_operators list -> rule list -> n_hierarchy = fun nopss rules -> let nopss' = List.Ne.of_list nopss in let name_i = fun i x -> make_name (name ^ "_" ^ (string_of_int i)) x in let levels : levels = List.Ne.mapi name_i nopss' in - make_name name @@ make_hierarchy levels rules + make_name name @@ make_hierarchy prefix levels rules end @@ -139,6 +140,15 @@ module Check = struct end +let make_constructor : _ -> (string * string) -> unit = fun ppf (gr, rhs) -> + let gr = String.capitalize_ascii gr in + match rhs with + | "" -> Format.fprintf ppf "%s" gr + | s -> Format.fprintf ppf "%s_%s" gr s + +let make_operator : _ -> (string * string) -> unit = fun ppf (prefix, op) -> + Format.fprintf ppf "%s_%s" prefix op + module Print_AST = struct open Format open PP_helpers @@ -157,11 +167,11 @@ module Print_AST = struct in List.filter_map aux rhs.content in let type_element = fun ppf te -> fprintf ppf "%s" te in - fprintf ppf "| `%s_%s of (%a)" - (String.capitalize_ascii gr.name) rhs.name + fprintf ppf "| %a of (%a)" + make_constructor (gr.name, rhs.name) (list_sep type_element (const " * ")) type_elements in - fprintf ppf "%s = [@. @[%a@]]" gr.name + fprintf ppf "%s =@. @[%a@]" gr.name (list_sep aux new_line) gr.content let singleton : _ -> O.singleton -> _ = fun ppf s -> @@ -173,10 +183,10 @@ module Print_AST = struct match ss with | [] -> () | hd :: tl -> - fprintf ppf "%a\n" (prepend "type " singleton) hd ; - fprintf ppf "%a" (list_sep (prepend "and " singleton) (const "\n")) tl + fprintf ppf "%a\n" (prepend "type " (singleton)) hd ; + fprintf ppf "%a" (list_sep (prepend "and " (singleton)) (const "\n")) tl - let n_operator level_name : _ -> O.n_operator -> _ = fun ppf nop -> + let n_operator prefix level_name : _ -> O.n_operator -> _ = fun ppf nop -> let type_elements = let aux : O.element -> string option = fun e -> match e with @@ -188,17 +198,17 @@ module Print_AST = struct | `Current | `Lower -> Some (level_name ^ " Location.wrap") in List.filter_map aux (get_content nop) in let type_element = fun ppf te -> fprintf ppf "%s" te in - fprintf ppf "| `%s of (%a)" - (get_name nop) + fprintf ppf "| %a of (%a)" + make_operator (prefix, nop.name) (list_sep type_element (const " * ")) type_elements let n_hierarchy t : _ -> O.n_hierarchy -> _ = fun ppf nh -> 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 name) new_line) nops + (list_sep (n_operator nh.content.prefix name) new_line) nops let n_hierarchies (first:bool) : _ -> O.n_hierarchy list -> _ = fun ppf ss -> match ss with @@ -260,7 +270,7 @@ module Print_Grammar = struct i := !i + 1 ; s in let content = List.filter_map aux rhs.content in - fprintf ppf "`%s_%s (%a)" (String.capitalize_ascii gr.name) rhs.name (list_sep string (const " , ")) content + fprintf ppf "%a (%a)" make_constructor (gr.name, rhs.name) (list_sep string (const " , ")) content in let aux : _ -> O.rhs -> _ = fun ppf rhs -> fprintf ppf "| %a { %a }" @@ -304,7 +314,7 @@ module Print_Grammar = struct in (list_sep element (const " ")) ppf (get_content nop) - let n_operator_code : _ -> O.n_operator -> _ = fun ppf nop -> + let n_operator_code prefix : _ -> O.n_operator -> _ = fun ppf nop -> let (name, elements) = destruct nop in let elements' = let i = ref 0 in @@ -316,24 +326,24 @@ module Print_Grammar = struct in i := !i + 1 ; r in List.filter_map aux elements in - fprintf ppf "`%s (%a)" name (list_sep string (const " , ")) elements' + fprintf ppf "%a (%a)" make_operator (prefix, name) (list_sep string (const " , ")) elements' - let n_operator prev_lvl_name cur_lvl_name : _ -> O.n_operator -> _ = fun ppf nop -> + let n_operator prefix prev_lvl_name cur_lvl_name : _ -> O.n_operator -> _ = fun ppf nop -> let name = get_name nop in fprintf ppf "%a@;| %a { %a }" comment name (n_operator_rule prev_lvl_name cur_lvl_name) nop - n_operator_code nop + (n_operator_code prefix) nop - let level prev_lvl_name : _ -> O.level -> _ = fun ppf l -> + let level prefix prev_lvl_name : _ -> O.level -> _ = fun ppf l -> let name = get_name l in match prev_lvl_name with | "" -> ( fprintf ppf "%s :@. @[%a@]" name - (list_sep (n_operator prev_lvl_name name) new_line) (get_content l) ; + (list_sep (n_operator prefix prev_lvl_name name) new_line) (get_content l) ; ) | _ -> ( fprintf ppf "%s :@. @[%a@;| %s { $1 }@]" name - (list_sep (n_operator prev_lvl_name name) new_line) (get_content l) + (list_sep (n_operator prefix prev_lvl_name name) new_line) (get_content l) prev_lvl_name ) @@ -341,10 +351,10 @@ module Print_Grammar = struct let name = get_name nh in fprintf ppf "%a@.%%inline %s : %s_0 { $1 }@.@;" comment ("Top-level for " ^ name) name name; let (hd, tl) = List.Ne.rev (get_content nh).levels in - fprintf ppf "%a" (level "") hd ; + fprintf ppf "%a" (level nh.content.prefix "") hd ; let aux prev_name lvl = new_lines 2 ppf () ; - fprintf ppf "%a" (level prev_name) lvl ; + fprintf ppf "%a" (level nh.content.prefix prev_name) lvl ; get_name lvl in let _last_name = List.fold_left aux (get_name hd) tl in @@ -399,9 +409,9 @@ module Pattern = struct open Token open O - let application = empty_infix "P_application" `Left + let application = empty_infix "application" `Left - let list : O.n_operator = make_name "P_list" [ + let list : O.n_operator = make_name "list" [ `Token LIST ; `Token LSQUARE ; `List (Lead SEMICOLON, `Current) ; `Token RSQUARE ; ] @@ -409,37 +419,37 @@ module Pattern = struct make_name "" [`Named variable_name ; `Token EQUAL ; `Named pattern_name] ] - let record : O.n_operator = make_name "P_record" [ + let record : O.n_operator = make_name "record" [ `Token LBRACKET ; `List (Trail SEMICOLON, `Named record_element.name) ; `Token RBRACKET ; ] - let pair = infix "P_pair" `Left COMMA + let pair = infix "pair" `Left COMMA - let variable : O.n_operator = make_name "P_variable" [ `Named variable_name ] - let constructor : O.n_operator = make_name "P_constructor" [ `Named constructor_name ] + let variable : O.n_operator = make_name "variable" [ `Named variable_name ] + let constructor : O.n_operator = make_name "constructor" [ `Named constructor_name ] - let module_ident : O.n_operator = make_name "P_module_ident" [ + let module_ident : O.n_operator = make_name "module_ident" [ `List (Trail_force_ne DOT, `Named constructor_name) ; `Named variable_name ; ] - let unit : O.n_operator = make_name "P_unit" [ `Named unit_name ] + let unit : O.n_operator = make_name "unit" [ `Named unit_name ] - let restricted_pattern_name = "resitrcted_pattern" + let restricted_pattern_name = "restricted_pattern" - let restricted_pattern = O.name_hierarchy restricted_pattern_name [ + let restricted_pattern = O.name_hierarchy restricted_pattern_name "Pr" [ [variable ; unit] ; - [paren "P_restrict" pattern_name] + [paren "restrict" pattern_name] ] [] - let main = O.name_hierarchy pattern_name [ + let main = O.name_hierarchy pattern_name "P" [ [record] ; [application] ; [pair] ; [list] ; [variable ; constructor ; module_ident ; unit] ; - [paren "P_paren" pattern_name] + [paren "paren" pattern_name] ] [] let singletons = [O.rule_singleton record_element] @@ -450,18 +460,18 @@ module Expression = struct open Token open O - let application = empty_infix "E_application" `Right + let application = empty_infix "application" `Right - let list : O.n_operator = make_name "E_list" [ + let list : O.n_operator = make_name "list" [ `Token LSQUARE ; `List (Trail SEMICOLON, `Current) ; `Token RSQUARE ; ] - let fun_ : O.n_operator = make_name "E_fun" [ + let fun_ : O.n_operator = make_name "fun" [ `Token FUN ; `Named pattern_name ; `Token ARROW ; `Current ; ] - let let_in : O.n_operator = make_name "E_let_in" [ + let let_in : O.n_operator = make_name "let_in" [ `Token LET ; `Named pattern_name ; `Token EQUAL ; `Current ; `Token IN ; `Current ; @@ -475,13 +485,13 @@ module Expression = struct make_name "record_implicit" [`Named variable_name ] ; ] - let record : O.n_operator = make_name "E_record" [ + let record : O.n_operator = make_name "record" [ `Token LBRACKET ; `List (Trail SEMICOLON, `Named record_element.name) ; `Token RBRACKET ; ] - let ite : O.n_operator = make_name "E_ifthenelse" [ + let ite : O.n_operator = make_name "ifthenelse" [ `Token IF ; `Current ; `Token THEN ; @@ -490,57 +500,57 @@ module Expression = struct `Current ; ] - let it : O.n_operator = make_name "E_ifthen" [ + let it : O.n_operator = make_name "ifthen" [ `Token IF ; `Current ; `Token THEN ; `Lower ; ] - let sequence = infix "E_sequence" `Left SEMICOLON + let sequence = infix "sequence" `Left SEMICOLON let match_clause = make_name "e_match_clause" [ make_name "" [`Named pattern_name ; `Token ARROW ; `Named no_match_name] ] - let match_with = make_name "E_match" [ + let match_with = make_name "match" [ `Token MATCH ; `Current ; `Token WITH ; `List (Lead_ne VBAR, `Named match_clause.name) ; ] - let lt = infix "E_lt" `Left LT - let le = infix "E_le" `Left LE - let gt = infix "E_gt" `Left GT - let eq = infix "E_eq" `Left EQUAL + let lt = infix "lt" `Left LT + let le = infix "le" `Left LE + let gt = infix "gt" `Left GT + let eq = infix "eq" `Left EQUAL - let cons = infix "E_cons" `Left DOUBLE_COLON + let cons = infix "cons" `Left DOUBLE_COLON - let addition = infix "E_addition" `Left PLUS - let substraction = infix "E_substraction" `Left MINUS + let addition = infix "addition" `Left PLUS + let substraction = infix "substraction" `Left MINUS - let multiplication = infix "E_multiplication" `Left TIMES - let division = infix "E_division" `Left DIV + let multiplication = infix "multiplication" `Left TIMES + let division = infix "division" `Left DIV - let arith_variable : O.n_operator = make_name "E_variable" [ `Named variable_name ] - let int : O.n_operator = make_name "E_int" [ `Named int_name ] - let tz : O.n_operator = make_name "E_tz" [ `Named tz_name ] - let unit : O.n_operator = make_name "E_unit" [ `Named unit_name ] - let string : O.n_operator = make_name "E_string" [ `Named string_name ] - let constructor : O.n_operator = make_name "E_constructor" [ `Named constructor_name ] + let arith_variable : O.n_operator = make_name "variable" [ `Named variable_name ] + let int : O.n_operator = make_name "int" [ `Named int_name ] + let tz : O.n_operator = make_name "tz" [ `Named tz_name ] + let unit : O.n_operator = make_name "unit" [ `Named unit_name ] + let string : O.n_operator = make_name "string" [ `Named string_name ] + let constructor : O.n_operator = make_name "constructor" [ `Named constructor_name ] - let module_ident : O.n_operator = make_name "E_module_ident" [ + let module_ident : O.n_operator = make_name "module_ident" [ `List (Trail_force_ne DOT, `Named constructor_name) ; `Named variable_name ; ] - let access : O.n_operator = infix "E_access" `Right DOT - let accessor : O.n_operator = make_name "E_accessor" [ + let access : O.n_operator = infix "access" `Right DOT + let accessor : O.n_operator = make_name "accessor" [ `Named variable_name ; `List (Lead_ne DOT, `Named variable_name) ; ] - let assignment : O.n_operator = infix "E_assign" `Left LEFT_ARROW + let assignment : O.n_operator = infix "assign" `Left LEFT_ARROW - let pair = infix "E_pair" `Left COMMA + let pair = infix "pair" `Left COMMA - let name = make_name "E_name" [`Token TILDE ; `Current] + let name = make_name "name" [`Token TILDE ; `Current] - let no_sequence_expression = O.name_hierarchy no_seq_name [ + let no_sequence_expression = O.name_hierarchy no_seq_name "Es" [ [let_in ; fun_ ; record ; ite ; it ; match_with] ; [pair] ; [application] ; @@ -552,10 +562,10 @@ module Expression = struct [list] ; [name] ; [arith_variable ; constructor ; module_ident ; accessor ; int ; unit ; string ; tz] ; - [paren "E_no_seq_bottom" expression_name] + [paren "no_seq_bottom" expression_name] ] [] - let no_match_expression = O.name_hierarchy no_match_name [ + let no_match_expression = O.name_hierarchy no_match_name "Em" [ [let_in ; fun_ ; record ; ite ; it ] ; [pair] ; [application] ; @@ -567,10 +577,10 @@ module Expression = struct [list] ; [name] ; [arith_variable ; constructor ; module_ident ; accessor ; int ; unit ; string ; tz] ; - [paren "E_no_match_bottom" expression_name] + [paren "no_match_bottom" expression_name] ] [] - let expression = O.name_hierarchy expression_name [ + let expression = O.name_hierarchy expression_name "E" [ [sequence] ; [let_in ; fun_ ; record ; ite ; it ; match_with] ; [pair] ; @@ -583,7 +593,7 @@ module Expression = struct [list] ; [name] ; [arith_variable ; constructor ; module_ident ; accessor ; int ; unit ; string ; tz] ; - [paren "E_paren" expression_name] + [paren "paren" expression_name] ] [] let singletons = List.map O.rule_singleton [record_element ; match_clause] @@ -594,11 +604,11 @@ module Type_expression = struct open Token open O - let list : O.n_operator = make_name "T_list" [ + let list : O.n_operator = make_name "list" [ `Token LIST ; `Token LSQUARE ; `List (Lead SEMICOLON, `Current) ; `Token RSQUARE ; ] - let let_in : O.n_operator = make_name "T_let_in" [ + let let_in : O.n_operator = make_name "let_in" [ `Token LET ; `Named variable_name ; `Token EQUAL ; `Current ; `Token IN ; `Current ; @@ -608,25 +618,25 @@ module Type_expression = struct make_name "" [`Named variable_name ; `Token COLON ; `Named type_expression_name] ] - let record : O.n_operator = make_name "T_record" [ + let record : O.n_operator = make_name "record" [ `Token LBRACKET ; `List (Trail SEMICOLON, `Named record_element.name) ; `Token RBRACKET ; ] - let application = empty_infix "T_application" `Left + let application = empty_infix "application" `Left - let pair = infix "T_pair" `Left COMMA + let pair = infix "pair" `Left COMMA - let arith_variable : O.n_operator = make_name "T_variable" [ `Named variable_name ] + let arith_variable : O.n_operator = make_name "variable" [ `Named variable_name ] - let arith = O.name_hierarchy type_expression_name [ + let arith = O.name_hierarchy type_expression_name "T" [ [let_in ; record ] ; [pair] ; [application] ; [list] ; [arith_variable] ; - [paren "T_paren" type_expression_name] + [paren "paren" type_expression_name] ] [] let singletons = [O.rule_singleton record_element] diff --git a/src/ligo/multifix/pre_parser.mly b/src/ligo/multifix/pre_parser.mly index d555c6b79..702e8105c 100644 --- a/src/ligo/multifix/pre_parser.mly +++ b/src/ligo/multifix/pre_parser.mly @@ -1,5 +1,5 @@ %{ - + open Ast %} %start entry_point diff --git a/src/ligo/simplify_mixfix.ml b/src/ligo/simplify_mixfix.ml deleted file mode 100644 index b1d9d8e8c..000000000 --- a/src/ligo/simplify_mixfix.ml +++ /dev/null @@ -1,2 +0,0 @@ -(* open Trace - * open Multifix.User *) diff --git a/src/ligo/simplify_multifix.ml b/src/ligo/simplify_multifix.ml new file mode 100644 index 000000000..34b9d5012 --- /dev/null +++ b/src/ligo/simplify_multifix.ml @@ -0,0 +1,18 @@ +open Trace +open Function +module I = Multifix.Ast +module O = Ast_simplified + +let statement : I.statement -> O.declaration result = fun s -> + match s with + (* | Statement_variable_declaration (s, [], expr) -> simple_fail (thunk "") *) + | Statement_variable_declaration _ -> simple_fail (thunk "") + | Statement_init_declaration _ -> simple_fail (thunk "") + | Statement_entry_declaration _ -> simple_fail (thunk "") + | Statement_type_declaration _ -> simple_fail (thunk "") + +let program : I.program -> O.program result = fun (Program lst) -> + bind_map_list (apply Location.unwrap >| bind_map_location statement) lst + +let main : I.entry_point -> O.program Location.wrap result = + bind_map_location program diff --git a/src/ligo/test/multifix_tests.ml b/src/ligo/test/multifix_tests.ml index cf4a8f025..c313ec8bd 100644 --- a/src/ligo/test/multifix_tests.ml +++ b/src/ligo/test/multifix_tests.ml @@ -6,6 +6,12 @@ let basic () : unit result = let%bind _ = User.parse_file "./contracts/new-syntax.mligo" in ok () +let simplify () : unit result = + let%bind raw = User.parse_file "./contracts/new-syntax.mligo" in + let%bind _simpl = Ligo.Simplify_multifix.main raw in + ok () + let main = "Parser Multifix", [ test "basic" basic ; + test "simplify" simplify ; ]