From 8657509bd772565f038b7e09772a584458da81d3 Mon Sep 17 00:00:00 2001 From: Galfour Date: Fri, 5 Apr 2019 17:53:41 +0000 Subject: [PATCH] moving stuff around --- src/lib_utils/PP.ml | 23 +++ src/lib_utils/dictionary.ml | 53 +++++++ .../ligo_helpers => lib_utils}/environment.ml | 0 .../ligo_helpers => lib_utils}/location.ml | 0 src/lib_utils/ne_list.ml | 0 .../ligo_helpers => lib_utils}/option.ml | 0 src/lib_utils/tezos_utils.ml | 94 ++---------- src/{ligo/ligo_helpers => lib_utils}/trace.ml | 6 +- src/{ligo/ligo_helpers => lib_utils}/tree.ml | 0 src/{ligo/ligo_helpers => lib_utils}/wrap.ml | 0 src/lib_utils/x_list.ml | 32 ++++ src/{ligo/ligo_helpers => lib_utils}/x_map.ml | 12 +- src/lib_utils/x_memory_proto_alpha.ml | 77 ++++++++++ src/ligo/ast_simplified.ml | 35 +++-- src/ligo/ast_typed.ml | 32 ++-- src/ligo/bin/dune | 3 + src/ligo/dune | 13 +- src/ligo/ligo.ml | 2 +- src/ligo/ligo_helpers/PP.ml | 15 -- src/ligo/ligo_helpers/dictionary.ml | 33 ----- src/ligo/ligo_helpers/dictionary.mli | 16 -- src/ligo/ligo_helpers/dune | 9 -- src/ligo/ligo_parser/dune | 10 +- src/ligo/meta-michelson/meta-michelson.opam | 21 --- .../alpha_wrap.ml | 0 .../contract.ml | 0 .../{meta-michelson => meta_michelson}/dune | 2 +- .../json.ml | 0 .../meta_michelson.ml | 0 .../michelson_wrap.ml | 0 .../misc.ml | 0 .../streams.ml | 0 src/ligo/mini_c.ml | 13 +- src/ligo/{ligo_multifix => multifix}/ast.ml | 0 src/ligo/{ligo_multifix => multifix}/dune | 1 + src/ligo/{ligo_multifix => multifix}/foo.test | 0 .../{ligo_multifix => multifix}/generator.ml | 137 ++++++------------ src/ligo/{ligo_multifix => multifix}/lex/dune | 3 + .../{ligo_multifix => multifix}/lex/lexer.ml | 0 .../{ligo_multifix => multifix}/lex/lexer.mll | 0 .../{ligo_multifix => multifix}/lex/token.ml | 0 .../{ligo_multifix => multifix}/lex/token.mly | 0 .../lex/token_type.ml | 0 .../lex/token_type.mli | 0 .../{ligo_multifix => multifix}/lexer.mll | 0 .../{ligo_multifix => multifix}/location.ml | 0 .../{ligo_multifix => multifix}/parser.ml | 0 .../{ligo_multifix => multifix}/parser.mli | 0 .../{ligo_multifix => multifix}/parser.mly | 0 .../partial_parser.mly | 0 .../pre_parser.mly | 0 .../{ligo_multifix => multifix}/token.mly | 0 src/ligo/{ligo_multifix => multifix}/user.ml | 0 src/ligo/simplify.ml | 2 +- src/ligo/simplify_mixfix.ml | 2 + src/ligo/transpiler.ml | 6 +- src/ligo/typer.ml | 10 +- 57 files changed, 339 insertions(+), 323 deletions(-) create mode 100644 src/lib_utils/PP.ml create mode 100644 src/lib_utils/dictionary.ml rename src/{ligo/ligo_helpers => lib_utils}/environment.ml (100%) rename src/{ligo/ligo_helpers => lib_utils}/location.ml (100%) create mode 100644 src/lib_utils/ne_list.ml rename src/{ligo/ligo_helpers => lib_utils}/option.ml (100%) rename src/{ligo/ligo_helpers => lib_utils}/trace.ml (96%) rename src/{ligo/ligo_helpers => lib_utils}/tree.ml (100%) rename src/{ligo/ligo_helpers => lib_utils}/wrap.ml (100%) rename src/{ligo/ligo_helpers => lib_utils}/x_map.ml (58%) create mode 100644 src/lib_utils/x_memory_proto_alpha.ml delete mode 100644 src/ligo/ligo_helpers/PP.ml delete mode 100644 src/ligo/ligo_helpers/dictionary.ml delete mode 100644 src/ligo/ligo_helpers/dictionary.mli delete mode 100644 src/ligo/ligo_helpers/dune delete mode 100644 src/ligo/meta-michelson/meta-michelson.opam rename src/ligo/{meta-michelson => meta_michelson}/alpha_wrap.ml (100%) rename src/ligo/{meta-michelson => meta_michelson}/contract.ml (100%) rename src/ligo/{meta-michelson => meta_michelson}/dune (74%) rename src/ligo/{meta-michelson => meta_michelson}/json.ml (100%) rename src/ligo/{meta-michelson => meta_michelson}/meta_michelson.ml (100%) rename src/ligo/{meta-michelson => meta_michelson}/michelson_wrap.ml (100%) rename src/ligo/{meta-michelson => meta_michelson}/misc.ml (100%) rename src/ligo/{meta-michelson => meta_michelson}/streams.ml (100%) rename src/ligo/{ligo_multifix => multifix}/ast.ml (100%) rename src/ligo/{ligo_multifix => multifix}/dune (98%) rename src/ligo/{ligo_multifix => multifix}/foo.test (100%) rename src/ligo/{ligo_multifix => multifix}/generator.ml (69%) rename src/ligo/{ligo_multifix => multifix}/lex/dune (93%) rename src/ligo/{ligo_multifix => multifix}/lex/lexer.ml (100%) rename src/ligo/{ligo_multifix => multifix}/lex/lexer.mll (100%) rename src/ligo/{ligo_multifix => multifix}/lex/token.ml (100%) rename src/ligo/{ligo_multifix => multifix}/lex/token.mly (100%) rename src/ligo/{ligo_multifix => multifix}/lex/token_type.ml (100%) rename src/ligo/{ligo_multifix => multifix}/lex/token_type.mli (100%) rename src/ligo/{ligo_multifix => multifix}/lexer.mll (100%) rename src/ligo/{ligo_multifix => multifix}/location.ml (100%) rename src/ligo/{ligo_multifix => multifix}/parser.ml (100%) rename src/ligo/{ligo_multifix => multifix}/parser.mli (100%) rename src/ligo/{ligo_multifix => multifix}/parser.mly (100%) rename src/ligo/{ligo_multifix => multifix}/partial_parser.mly (100%) rename src/ligo/{ligo_multifix => multifix}/pre_parser.mly (100%) rename src/ligo/{ligo_multifix => multifix}/token.mly (100%) rename src/ligo/{ligo_multifix => multifix}/user.ml (100%) create mode 100644 src/ligo/simplify_mixfix.ml diff --git a/src/lib_utils/PP.ml b/src/lib_utils/PP.ml new file mode 100644 index 000000000..442d1e62e --- /dev/null +++ b/src/lib_utils/PP.ml @@ -0,0 +1,23 @@ +open Format +let string : formatter -> string -> unit = fun ppf s -> fprintf ppf "%s" s +let tag tag : formatter -> unit -> unit = fun ppf () -> fprintf ppf tag +let new_line : formatter -> unit -> unit = tag "@;" +let rec new_lines n ppf () = + match n with + | 0 -> new_line ppf () + | n -> new_line ppf () ; new_lines (n-1) ppf () +let const const : formatter -> unit -> unit = fun ppf () -> fprintf ppf "%s" const +let comment : formatter -> string -> unit = fun ppf s -> fprintf ppf "(* %s *)" s +let list_sep value separator = pp_print_list ~pp_sep:separator value +let ne_list_sep value separator ppf (hd, tl) = + value ppf hd ; + separator ppf () ; + pp_print_list ~pp_sep:separator value ppf tl + +let pair_sep value sep ppf (a, b) = fprintf ppf "%a %s %a" value a sep value b +let smap_sep value sep ppf m = + let module SMap = X_map.String in + let aux k v prev = (k, v) :: prev in + let new_pp ppf (k, v) = fprintf ppf "%s -> %a" k value v in + let lst = List.rev @@ SMap.fold aux m [] in + fprintf ppf "%a" (list_sep new_pp sep) lst diff --git a/src/lib_utils/dictionary.ml b/src/lib_utils/dictionary.ml new file mode 100644 index 000000000..76fc8cb14 --- /dev/null +++ b/src/lib_utils/dictionary.ml @@ -0,0 +1,53 @@ +open Trace + +module type DICTIONARY = sig + type ('a, 'b) t + + val get_exn : ('a, 'b) t -> 'a -> 'b + val get : ('a, 'b) t -> 'a -> 'b result + + val set : + ?equal:('a -> 'a -> bool) -> + ('a, 'b) t -> 'a -> 'b -> ('a, 'b) t + + val del : + ?equal:('a -> 'a -> bool) -> + ('a, 'b) t -> 'a -> ('a, 'b) t + + val to_list : ('a, 'b) t -> ('a * 'b) list +end + +module Assoc : DICTIONARY = struct + + type ('a, 'b) t = ('a * 'b) list + + let get_exn x y = List.assoc y x + + let get x y = generic_try (simple_error "Dictionry.get") @@ fun () -> get_exn x y + + let set ?equal lst a b = + let equal : 'a -> 'a -> bool = + Option.unopt + ~default:(=) equal + in + let rec aux acc = function + | [] -> List.rev acc + | (key, _)::tl when equal key a -> aux ((key, b) :: acc) tl + | hd::tl -> aux (hd :: acc) tl + in + aux [] lst + + let del ?equal lst a = + let equal : 'a -> 'a -> bool = + Option.unopt + ~default:(=) equal + in + let rec aux acc = function + | [] -> List.rev acc + | (key, _)::tl when equal key a -> aux acc tl + | hd::tl -> aux (hd :: acc) tl + in + aux [] lst + + let to_list x = x +end diff --git a/src/ligo/ligo_helpers/environment.ml b/src/lib_utils/environment.ml similarity index 100% rename from src/ligo/ligo_helpers/environment.ml rename to src/lib_utils/environment.ml diff --git a/src/ligo/ligo_helpers/location.ml b/src/lib_utils/location.ml similarity index 100% rename from src/ligo/ligo_helpers/location.ml rename to src/lib_utils/location.ml diff --git a/src/lib_utils/ne_list.ml b/src/lib_utils/ne_list.ml new file mode 100644 index 000000000..e69de29bb diff --git a/src/ligo/ligo_helpers/option.ml b/src/lib_utils/option.ml similarity index 100% rename from src/ligo/ligo_helpers/option.ml rename to src/lib_utils/option.ml diff --git a/src/lib_utils/tezos_utils.ml b/src/lib_utils/tezos_utils.ml index a03ee0676..317714915 100644 --- a/src/lib_utils/tezos_utils.ml +++ b/src/lib_utils/tezos_utils.ml @@ -1,90 +1,20 @@ module Stdlib_unix = Tezos_stdlib_unix -module Crypto = Tezos_crypto module Data_encoding = Tezos_data_encoding -module Error_monad = X_error_monad +module Crypto = Tezos_crypto module Signature = Tezos_base.TzPervasives.Signature module Time = Tezos_base.TzPervasives.Time +module Memory_proto_alpha = X_memory_proto_alpha +module Micheline = X_tezos_micheline + +module Error_monad = X_error_monad +module Trace = Trace +module PP = PP + module List = X_list module Option = Tezos_base.TzPervasives.Option module Cast = Cast -module Micheline = X_tezos_micheline module Tuple = Tuple - -module Memory_proto_alpha = struct - include Memory_proto_alpha - let init_environment = Init_proto_alpha.init_environment - let dummy_environment = Init_proto_alpha.dummy_environment - - open X_error_monad - open Script_typed_ir - open Script_ir_translator - open Script_interpreter - - let stack_ty_eq (type a b) - ?(tezos_context = dummy_environment.tezos_context) - (a:a stack_ty) (b:b stack_ty) = - alpha_wrap (Script_ir_translator.stack_ty_eq tezos_context 0 a b) >>? fun (Eq, _) -> - ok Eq - - let ty_eq (type a b) - ?(tezos_context = dummy_environment.tezos_context) - (a:a ty) (b:b ty) - = - alpha_wrap (Script_ir_translator.ty_eq tezos_context a b) >>? fun (Eq, _) -> - ok Eq - - let parse_michelson (type aft) - ?(tezos_context = dummy_environment.tezos_context) - ?(top_level = Lambda) (michelson:Micheline.Michelson.t) - (bef:'a Script_typed_ir.stack_ty) (aft:aft Script_typed_ir.stack_ty) - = - let michelson = Micheline.Michelson.strip_annots michelson in - let michelson = Micheline.Michelson.strip_nops michelson in - parse_instr - top_level tezos_context - michelson bef >>=?? fun (j, _) -> - match j with - | Typed descr -> ( - Lwt.return ( - alpha_wrap (Script_ir_translator.stack_ty_eq tezos_context 0 descr.aft aft) >>? fun (Eq, _) -> - let descr : (_, aft) Script_typed_ir.descr = {descr with aft} in - Ok descr - ) - ) - | _ -> Lwt.return @@ error_exn (Failure "Typing instr failed") - - let parse_michelson_data - ?(tezos_context = dummy_environment.tezos_context) - michelson ty = - let michelson = Micheline.Michelson.strip_annots michelson in - let michelson = Micheline.Michelson.strip_nops michelson in - parse_data tezos_context ty michelson >>=?? fun (data, _) -> - return data - - let parse_michelson_ty - ?(tezos_context = dummy_environment.tezos_context) - ?(allow_big_map = true) ?(allow_operation = true) - michelson = - let michelson = Micheline.Michelson.strip_annots michelson in - let michelson = Micheline.Michelson.strip_nops michelson in - Lwt.return @@ parse_ty tezos_context ~allow_big_map ~allow_operation michelson >>=?? fun (ty, _) -> - return ty - - let unparse_michelson_data - ?(tezos_context = dummy_environment.tezos_context) - ?mapper ty value : Micheline.Michelson.t tzresult Lwt.t = - Script_ir_translator.unparse_data tezos_context ?mapper - Readable ty value >>=?? fun (michelson, _) -> - return michelson - - let interpret - ?(tezos_context = dummy_environment.tezos_context) - ?(source = (List.nth dummy_environment.identities 0).implicit_contract) - ?(self = (List.nth dummy_environment.identities 0).implicit_contract) - ?(payer = (List.nth dummy_environment.identities 1).implicit_contract) - ?visitor - (instr:('a, 'b) descr) (bef:'a stack) : 'b stack tzresult Lwt.t = - Script_interpreter.step tezos_context ~source ~self ~payer ?visitor Alpha_context.Tez.one instr bef >>=?? - fun (stack, _) -> return stack - -end +module Map = X_map +module Dictionary = Dictionary +module Environment = Environment +module Tree = Tree diff --git a/src/ligo/ligo_helpers/trace.ml b/src/lib_utils/trace.ml similarity index 96% rename from src/ligo/ligo_helpers/trace.ml rename to src/lib_utils/trace.ml index 6a4733aaa..1a6d2faea 100644 --- a/src/ligo/ligo_helpers/trace.ml +++ b/src/lib_utils/trace.ml @@ -118,11 +118,11 @@ let bind_pair = bind_and let bind_map_pair f (a, b) = bind_pair (f a, f b) -module AE = Tezos_utils.Memory_proto_alpha.Alpha_environment +module AE = Memory_proto_alpha.Alpha_environment module TP = Tezos_base__TzPervasives -let of_tz_error (err:Tezos_utils.Error_monad.error) : error = - let str = Tezos_utils.Error_monad.(to_string err) in +let of_tz_error (err:X_error_monad.error) : error = + let str = X_error_monad.(to_string err) in error "alpha error" str let of_alpha_tz_error err = of_tz_error (AE.Ecoproto_error err) diff --git a/src/ligo/ligo_helpers/tree.ml b/src/lib_utils/tree.ml similarity index 100% rename from src/ligo/ligo_helpers/tree.ml rename to src/lib_utils/tree.ml diff --git a/src/ligo/ligo_helpers/wrap.ml b/src/lib_utils/wrap.ml similarity index 100% rename from src/ligo/ligo_helpers/wrap.ml rename to src/lib_utils/wrap.ml diff --git a/src/lib_utils/x_list.ml b/src/lib_utils/x_list.ml index 9988c8636..3caa79f92 100644 --- a/src/lib_utils/x_list.ml +++ b/src/lib_utils/x_list.ml @@ -1,5 +1,16 @@ include Tezos_base.TzPervasives.List +let filter_map f = + let rec aux acc lst = match lst with + | [] -> List.rev acc + | hd :: tl -> aux ( + match f hd with + | Some x -> x :: acc + | None -> acc + ) tl + in + aux [] + let range n = let rec aux acc n = if n = 0 @@ -53,3 +64,24 @@ let until n lst = else aux ((hd lst) :: acc) (n - 1) (tl lst) in rev (aux [] n lst) + +module Ne = struct + + type 'a t = 'a * 'a list + + let of_list lst = List.(hd lst, tl lst) + let to_list (hd, tl : _ t) = hd :: tl + let iter f (hd, tl : _ t) = f hd ; List.iter f tl + let map f (hd, tl : _ t) = f hd, List.map f tl + let mapi f (hd, tl : _ t) = + let lst = List.mapi f (hd::tl) in + of_list lst + let concat (hd, tl : _ t) = hd @ List.concat tl + let rev (hd, tl : _ t) = + match tl with + | [] -> (hd, []) + | lst -> + let r = List.rev lst in + (List.hd r, List.tl r @ [hd]) + +end diff --git a/src/ligo/ligo_helpers/x_map.ml b/src/lib_utils/x_map.ml similarity index 58% rename from src/ligo/ligo_helpers/x_map.ml rename to src/lib_utils/x_map.ml index b92019014..ded0b83e2 100644 --- a/src/ligo/ligo_helpers/x_map.ml +++ b/src/lib_utils/x_map.ml @@ -1,4 +1,14 @@ -module Make(Ord : Map.OrderedType) = struct +module type OrderedType = Map.OrderedType + +module type S = sig + include Map.S + + val of_list : (key * 'a) list -> 'a t + val to_list : 'a t -> 'a list + val to_kv_list : 'a t -> (key * 'a) list +end + +module Make(Ord : Map.OrderedType) : S with type key = Ord.t = struct include Map.Make(Ord) let of_list (lst: (key * 'a) list) : 'a t = diff --git a/src/lib_utils/x_memory_proto_alpha.ml b/src/lib_utils/x_memory_proto_alpha.ml new file mode 100644 index 000000000..3aeba32ac --- /dev/null +++ b/src/lib_utils/x_memory_proto_alpha.ml @@ -0,0 +1,77 @@ +module Michelson = X_tezos_micheline.Michelson + +include Memory_proto_alpha +let init_environment = Init_proto_alpha.init_environment +let dummy_environment = Init_proto_alpha.dummy_environment + +open X_error_monad +open Script_typed_ir +open Script_ir_translator +open Script_interpreter + +let stack_ty_eq (type a b) + ?(tezos_context = dummy_environment.tezos_context) + (a:a stack_ty) (b:b stack_ty) = + alpha_wrap (Script_ir_translator.stack_ty_eq tezos_context 0 a b) >>? fun (Eq, _) -> + ok Eq + +let ty_eq (type a b) + ?(tezos_context = dummy_environment.tezos_context) + (a:a ty) (b:b ty) + = + alpha_wrap (Script_ir_translator.ty_eq tezos_context a b) >>? fun (Eq, _) -> + ok Eq + +let parse_michelson (type aft) + ?(tezos_context = dummy_environment.tezos_context) + ?(top_level = Lambda) (michelson:Michelson.t) + (bef:'a Script_typed_ir.stack_ty) (aft:aft Script_typed_ir.stack_ty) + = + let michelson = Michelson.strip_annots michelson in + let michelson = Michelson.strip_nops michelson in + parse_instr + top_level tezos_context + michelson bef >>=?? fun (j, _) -> + match j with + | Typed descr -> ( + Lwt.return ( + alpha_wrap (Script_ir_translator.stack_ty_eq tezos_context 0 descr.aft aft) >>? fun (Eq, _) -> + let descr : (_, aft) Script_typed_ir.descr = {descr with aft} in + Ok descr + ) + ) + | _ -> Lwt.return @@ error_exn (Failure "Typing instr failed") + +let parse_michelson_data + ?(tezos_context = dummy_environment.tezos_context) + michelson ty = + let michelson = Michelson.strip_annots michelson in + let michelson = Michelson.strip_nops michelson in + parse_data tezos_context ty michelson >>=?? fun (data, _) -> + return data + +let parse_michelson_ty + ?(tezos_context = dummy_environment.tezos_context) + ?(allow_big_map = true) ?(allow_operation = true) + michelson = + let michelson = Michelson.strip_annots michelson in + let michelson = Michelson.strip_nops michelson in + Lwt.return @@ parse_ty tezos_context ~allow_big_map ~allow_operation michelson >>=?? fun (ty, _) -> + return ty + +let unparse_michelson_data + ?(tezos_context = dummy_environment.tezos_context) + ?mapper ty value : Michelson.t tzresult Lwt.t = + Script_ir_translator.unparse_data tezos_context ?mapper + Readable ty value >>=?? fun (michelson, _) -> + return michelson + +let interpret + ?(tezos_context = dummy_environment.tezos_context) + ?(source = (List.nth dummy_environment.identities 0).implicit_contract) + ?(self = (List.nth dummy_environment.identities 0).implicit_contract) + ?(payer = (List.nth dummy_environment.identities 1).implicit_contract) + ?visitor + (instr:('a, 'b) descr) (bef:'a stack) : 'b stack tzresult Lwt.t = + Script_interpreter.step tezos_context ~source ~self ~payer ?visitor Alpha_context.Tez.one instr bef >>=?? + fun (stack, _) -> return stack diff --git a/src/ligo/ast_simplified.ml b/src/ligo/ast_simplified.ml index 16d0971b8..255262af1 100644 --- a/src/ligo/ast_simplified.ml +++ b/src/ligo/ast_simplified.ml @@ -1,4 +1,4 @@ -module SMap = Ligo_helpers.X_map.String +module SMap = Map.String type name = string type type_name = string @@ -116,19 +116,22 @@ let ae expression = {expression ; type_annotation = None} let annotated_expression expression type_annotation = {expression ; type_annotation} -open Ligo_helpers.Trace +open Trace module PP = struct - open Ligo_helpers.PP + open PP open Format + let list_sep_d x = list_sep x (const " , ") + let smap_sep_d x = smap_sep x (const " , ") + let rec type_expression ppf (te:type_expression) = match te with - | T_tuple lst -> fprintf ppf "tuple[%a]" (list_sep type_expression) lst - | T_sum m -> fprintf ppf "sum[%a]" (smap_sep type_expression) m - | T_record m -> fprintf ppf "record[%a]" (smap_sep type_expression) m + | T_tuple lst -> fprintf ppf "tuple[%a]" (list_sep_d type_expression) lst + | T_sum m -> fprintf ppf "sum[%a]" (smap_sep_d type_expression) m + | T_record m -> fprintf ppf "record[%a]" (smap_sep_d type_expression) m | T_function (p, r) -> fprintf ppf "%a -> %a" type_expression p type_expression r | T_variable name -> fprintf ppf "%s" name - | T_constant (name, lst) -> fprintf ppf "%s(%a)" name (list_sep type_expression) lst + | T_constant (name, lst) -> fprintf ppf "%s(%a)" name (list_sep_d type_expression) lst let literal ppf (l:literal) = match l with | Literal_unit -> fprintf ppf "Unit" @@ -142,11 +145,11 @@ module PP = struct | E_variable name -> fprintf ppf "%s" name | E_application (f, arg) -> fprintf ppf "(%a)@(%a)" annotated_expression f annotated_expression arg | E_constructor (name, ae) -> fprintf ppf "%s(%a)" name annotated_expression ae - | E_constant (name, lst) -> fprintf ppf "%s(%a)" name (list_sep annotated_expression) lst - | E_tuple lst -> fprintf ppf "tuple[%a]" (list_sep annotated_expression) lst + | E_constant (name, lst) -> fprintf ppf "%s(%a)" name (list_sep_d annotated_expression) lst + | E_tuple lst -> fprintf ppf "tuple[%a]" (list_sep_d annotated_expression) lst | E_accessor (ae, p) -> fprintf ppf "%a.%a" annotated_expression ae access_path p - | E_record m -> fprintf ppf "record[%a]" (smap_sep annotated_expression) m - | E_map m -> fprintf ppf "map[%a]" (list_sep assoc_annotated_expression) m + | E_record m -> fprintf ppf "record[%a]" (smap_sep_d annotated_expression) m + | E_map m -> fprintf ppf "map[%a]" (list_sep_d assoc_annotated_expression) m | E_look_up (ds, ind) -> fprintf ppf "(%a)[%a]" annotated_expression ds annotated_expression ind | E_lambda {binder;input_type;output_type;result;body} -> fprintf ppf "lambda (%s:%a) : %a {%a} return %a" @@ -164,7 +167,7 @@ module PP = struct | Access_record s -> fprintf ppf "%s" s and access_path ppf (p:access_path) = - fprintf ppf "%a" (list_sep ~pp_sep:(const ".") access) p + fprintf ppf "%a" (list_sep access (const ".")) p and type_annotation ppf (ta:type_expression option) = match ta with | None -> fprintf ppf "" @@ -174,7 +177,7 @@ module PP = struct | None -> fprintf ppf "%a" expression ae.expression | Some t -> fprintf ppf "(%a) : %a" expression ae.expression type_expression t - and block ppf (b:block) = (list_sep instruction) ppf b + and block ppf (b:block) = (list_sep_d instruction) ppf b and single_record_patch ppf ((p, ae) : string * ae) = fprintf ppf "%s <- %a" p annotated_expression ae @@ -182,7 +185,7 @@ module PP = struct and matching : type a . (formatter -> a -> unit) -> formatter -> a matching -> unit = fun f ppf m -> match m with | Match_tuple (lst, b) -> - fprintf ppf "let (%a) = %a" (list_sep (fun ppf -> fprintf ppf "%s")) lst f b + fprintf ppf "let (%a) = %a" (list_sep_d string) lst f b | Match_bool {match_true ; match_false} -> fprintf ppf "| True -> %a @.| False -> %a" f match_true f match_false | Match_list {match_nil ; match_cons = (hd, tl, match_cons)} -> @@ -193,7 +196,7 @@ module PP = struct and instruction ppf (i:instruction) = match i with | I_skip -> fprintf ppf "skip" | I_fail ae -> fprintf ppf "fail with (%a)" annotated_expression ae - | I_record_patch (name, path, lst) -> fprintf ppf "%s.%a[%a]" name access_path path (list_sep single_record_patch) lst + | I_record_patch (name, path, lst) -> fprintf ppf "%s.%a[%a]" name access_path path (list_sep_d single_record_patch) lst | I_loop (cond, b) -> fprintf ppf "while (%a) { %a }" annotated_expression cond block b | I_assignment {name;annotated_expression = ae} -> fprintf ppf "%s := %a" name annotated_expression ae @@ -207,7 +210,7 @@ module PP = struct fprintf ppf "const %s = %a" name annotated_expression ae let program ppf (p:program) = - fprintf ppf "%a" (list_sep declaration) p + fprintf ppf "%a" (list_sep_d declaration) p end module Rename = struct diff --git a/src/ligo/ast_typed.ml b/src/ligo/ast_typed.ml index 60ba361ff..c72cc69b1 100644 --- a/src/ligo/ast_typed.ml +++ b/src/ligo/ast_typed.ml @@ -1,6 +1,6 @@ module S = Ast_simplified -module SMap = Ligo_helpers.X_map.String +module SMap = Map.String type name = string type type_name = string @@ -109,7 +109,7 @@ and matching_instr = b matching and matching_expr = ae matching -open! Ligo_helpers.Trace +open! Trace let type_value type_value simplified = { type_value ; simplified } @@ -135,16 +135,20 @@ let get_functional_entry (p:program) (entry : string) : (lambda * type_value) re module PP = struct open Format - open Ligo_helpers.PP + open PP + + let list_sep_d x = list_sep x (const " , ") + let smap_sep_d x = smap_sep x (const " , ") + let rec type_value' ppf (tv':type_value') : unit = match tv' with - | T_tuple lst -> fprintf ppf "tuple[%a]" (list_sep type_value) lst - | T_sum m -> fprintf ppf "sum[%a]" (smap_sep type_value) m - | T_record m -> fprintf ppf "record[%a]" (smap_sep type_value) m + | T_tuple lst -> fprintf ppf "tuple[%a]" (list_sep_d type_value) lst + | T_sum m -> fprintf ppf "sum[%a]" (smap_sep_d type_value) m + | T_record m -> fprintf ppf "record[%a]" (smap_sep_d type_value) m | T_function (a, b) -> fprintf ppf "%a -> %a" type_value a type_value b | T_constant (c, []) -> fprintf ppf "%s" c - | T_constant (c, n) -> fprintf ppf "%s(%a)" c (list_sep type_value) n + | T_constant (c, n) -> fprintf ppf "%s(%a)" c (list_sep_d type_value) n and type_value ppf (tv:type_value) : unit = type_value' ppf tv.type_value @@ -157,19 +161,19 @@ module PP = struct and expression ppf (e:expression) : unit = match e with | E_literal l -> literal ppf l - | E_constant (c, lst) -> fprintf ppf "%s(%a)" c (list_sep annotated_expression) lst + | E_constant (c, lst) -> fprintf ppf "%s(%a)" c (list_sep_d annotated_expression) lst | E_constructor (c, lst) -> fprintf ppf "%s(%a)" c annotated_expression lst | E_variable a -> fprintf ppf "%s" a | E_application (f, arg) -> fprintf ppf "(%a) (%a)" annotated_expression f annotated_expression arg - | E_tuple lst -> fprintf ppf "tuple[%a]" (list_sep annotated_expression) lst + | E_tuple lst -> fprintf ppf "tuple[%a]" (list_sep_d annotated_expression) lst | E_lambda {binder;input_type;output_type;result;body} -> fprintf ppf "lambda (%s:%a) : %a {%a} return %a" binder type_value input_type type_value output_type block body annotated_expression result | E_tuple_accessor (ae, i) -> fprintf ppf "%a.%d" annotated_expression ae i | E_record_accessor (ae, s) -> fprintf ppf "%a.%s" annotated_expression ae s - | E_record m -> fprintf ppf "record[%a]" (smap_sep annotated_expression) m - | E_map m -> fprintf ppf "map[%a]" (list_sep assoc_annotated_expression) m + | E_record m -> fprintf ppf "record[%a]" (smap_sep_d annotated_expression) m + | E_map m -> fprintf ppf "map[%a]" (list_sep_d assoc_annotated_expression) m | E_look_up (ds, i) -> fprintf ppf "(%a)[%a]" annotated_expression ds annotated_expression i | E_matching (ae, m) -> fprintf ppf "match %a with %a" annotated_expression ae (matching annotated_expression) m @@ -186,14 +190,14 @@ module PP = struct | Literal_string s -> fprintf ppf "%s" s | Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b - and block ppf (b:block) = (list_sep instruction) ppf b + and block ppf (b:block) = (list_sep_d instruction) ppf b and single_record_patch ppf ((s, ae) : string * ae) = fprintf ppf "%s <- %a" s annotated_expression ae and matching : type a . (formatter -> a -> unit) -> _ -> a matching -> unit = fun f ppf m -> match m with | Match_tuple (lst, b) -> - fprintf ppf "let (%a) = %a" (list_sep (fun ppf -> fprintf ppf "%s")) lst f b + fprintf ppf "let (%a) = %a" (list_sep_d (fun ppf -> fprintf ppf "%s")) lst f b | Match_bool {match_true ; match_false} -> fprintf ppf "| True -> %a @.| False -> %a" f match_true f match_false | Match_list {match_nil ; match_cons = (hd, tl, match_cons)} -> @@ -216,7 +220,7 @@ module PP = struct fprintf ppf "const %s = %a" name annotated_expression ae let program ppf (p:program) = - fprintf ppf "%a" (list_sep declaration) p + fprintf ppf "%a" (list_sep_d declaration) p end diff --git a/src/ligo/bin/dune b/src/ligo/bin/dune index 5f8246925..1bc76350d 100644 --- a/src/ligo/bin/dune +++ b/src/ligo/bin/dune @@ -1,6 +1,9 @@ (executable (name cli) (public_name ligo) + (libraries + tezos-utils + ) (package ligo) (preprocess (pps ppx_let) diff --git a/src/ligo/dune b/src/ligo/dune index 0b1ed73ac..9bca3a017 100644 --- a/src/ligo/dune +++ b/src/ligo/dune @@ -1,18 +1,25 @@ +(env + (dev + (flags (:standard -w +1..62-4-9-44-40-42-48@39@33 -open Tezos_utils )) + ) + (release + (flags (:standard -w +1..62-4-9-44-40-42-48@39@33 -open Tezos_utils )) + ) +) + (library (name ligo) (public_name ligo) (libraries tezos-utils tezos-micheline - meta-michelson - ligo_helpers + meta_michelson ligo_parser multifix ) (preprocess (pps ppx_let) ) - (flags (:standard -w +1..62-4-9-44-40-42-48@39@33 )) ) (alias diff --git a/src/ligo/ligo.ml b/src/ligo/ligo.ml index 6b1972ca1..17995dd49 100644 --- a/src/ligo/ligo.ml +++ b/src/ligo/ligo.ml @@ -9,7 +9,7 @@ module Mini_c = Mini_c module Typer = Typer module Transpiler = Transpiler -open Ligo_helpers.Trace +open Trace let parse_file (source: string) : AST_Raw.t result = let pp_input = diff --git a/src/ligo/ligo_helpers/PP.ml b/src/ligo/ligo_helpers/PP.ml deleted file mode 100644 index ac98710a0..000000000 --- a/src/ligo/ligo_helpers/PP.ml +++ /dev/null @@ -1,15 +0,0 @@ -open Format -module SMap = X_map.String - -let const s ppf () = pp_print_string ppf s - -let list_sep ?(pp_sep = const " ; ") pp = - pp_print_list ~pp_sep pp - - -let pair_sep pp ppf (a, b) = fprintf ppf "(%a, %a)" pp a pp b -let smap_sep pp ppf m = - let aux k v prev = (k, v) :: prev in - let new_pp ppf (k, v) = fprintf ppf "%s -> %a" k pp v in - let lst = List.rev @@ SMap.fold aux m [] in - fprintf ppf "%a" (list_sep new_pp) lst diff --git a/src/ligo/ligo_helpers/dictionary.ml b/src/ligo/ligo_helpers/dictionary.ml deleted file mode 100644 index a4badb866..000000000 --- a/src/ligo/ligo_helpers/dictionary.ml +++ /dev/null @@ -1,33 +0,0 @@ -open Trace - -type ('a, 'b) t = ('a * 'b) list - -let get_exn x y = List.assoc y x - -let get x y = generic_try (simple_error "Dictionry.get") @@ fun () -> get_exn x y - -let set ?equal lst a b = - let equal : 'a -> 'a -> bool = - Option.unopt - ~default:(=) equal - in - let rec aux acc = function - | [] -> List.rev acc - | (key, _)::tl when equal key a -> aux ((key, b) :: acc) tl - | hd::tl -> aux (hd :: acc) tl - in - aux [] lst - -let del ?equal lst a = - let equal : 'a -> 'a -> bool = - Option.unopt - ~default:(=) equal - in - let rec aux acc = function - | [] -> List.rev acc - | (key, _)::tl when equal key a -> aux acc tl - | hd::tl -> aux (hd :: acc) tl - in - aux [] lst - -let to_list x = x diff --git a/src/ligo/ligo_helpers/dictionary.mli b/src/ligo/ligo_helpers/dictionary.mli deleted file mode 100644 index 10204b467..000000000 --- a/src/ligo/ligo_helpers/dictionary.mli +++ /dev/null @@ -1,16 +0,0 @@ -open Trace - -type ('a, 'b) t - -val get_exn : ('a, 'b) t -> 'a -> 'b -val get : ('a, 'b) t -> 'a -> 'b result - -val set : - ?equal:('a -> 'a -> bool) -> - ('a, 'b) t -> 'a -> 'b -> ('a, 'b) t - -val del : - ?equal:('a -> 'a -> bool) -> - ('a, 'b) t -> 'a -> ('a, 'b) t - -val to_list : ('a, 'b) t -> ('a * 'b) list diff --git a/src/ligo/ligo_helpers/dune b/src/ligo/ligo_helpers/dune deleted file mode 100644 index d74f31409..000000000 --- a/src/ligo/ligo_helpers/dune +++ /dev/null @@ -1,9 +0,0 @@ -(library - (name ligo_helpers) - (public_name ligo.helpers) - (libraries - tezos-base - tezos-utils - ) -;; (modules x_map option wrap tree location environment dictionary PP trace) -) diff --git a/src/ligo/ligo_parser/dune b/src/ligo/ligo_parser/dune index 4eaa63a36..3b654987f 100644 --- a/src/ligo/ligo_parser/dune +++ b/src/ligo/ligo_parser/dune @@ -10,7 +10,15 @@ (name ligo_parser) (public_name ligo.parser) (modules_without_implementation Error) - (libraries getopt hex str uutf zarith)) + (libraries + getopt + hex + str + uutf + zarith + tezos-utils + ) +) ;; Les deux directives (rule) qui suivent sont pour le dev local. ;; Il suffit de faire "dune build Parser.exe" pour avoir un Parser.exe dans le dossier. diff --git a/src/ligo/meta-michelson/meta-michelson.opam b/src/ligo/meta-michelson/meta-michelson.opam deleted file mode 100644 index 3543c7772..000000000 --- a/src/ligo/meta-michelson/meta-michelson.opam +++ /dev/null @@ -1,21 +0,0 @@ -name: "meta-michelson" -opam-version: "2.0" -version: "1.0" -maintainer: "gabriel.alfour@gmail.com" -authors: [ "Galfour" ] -homepage: "https://gitlab.com/gabriel.alfour/tezos" -bug-reports: "https://gitlab.com/gabriel.alfour/tezos/issues" -dev-repo: "git+https://gitlab.com/gabriel.alfour/tezos.git" -license: "MIT" -depends: [ - "ocamlfind" { build } - "dune" { build & >= "1.0.1" } - "tezos-utils" - "michelson-parser" -] -build: [ - [ "dune" "build" "-p" name "-j" jobs ] -] -url { - src: "https://gitlab.com/gabriel.alfour/tezos/-/archive/master/tezos.tar.gz" -} diff --git a/src/ligo/meta-michelson/alpha_wrap.ml b/src/ligo/meta_michelson/alpha_wrap.ml similarity index 100% rename from src/ligo/meta-michelson/alpha_wrap.ml rename to src/ligo/meta_michelson/alpha_wrap.ml diff --git a/src/ligo/meta-michelson/contract.ml b/src/ligo/meta_michelson/contract.ml similarity index 100% rename from src/ligo/meta-michelson/contract.ml rename to src/ligo/meta_michelson/contract.ml diff --git a/src/ligo/meta-michelson/dune b/src/ligo/meta_michelson/dune similarity index 74% rename from src/ligo/meta-michelson/dune rename to src/ligo/meta_michelson/dune index 7187c4cc2..0187cb121 100644 --- a/src/ligo/meta-michelson/dune +++ b/src/ligo/meta_michelson/dune @@ -1,6 +1,6 @@ (library (name meta_michelson) - (public_name meta-michelson) + (public_name ligo.meta_michelson) (libraries tezos-utils michelson-parser diff --git a/src/ligo/meta-michelson/json.ml b/src/ligo/meta_michelson/json.ml similarity index 100% rename from src/ligo/meta-michelson/json.ml rename to src/ligo/meta_michelson/json.ml diff --git a/src/ligo/meta-michelson/meta_michelson.ml b/src/ligo/meta_michelson/meta_michelson.ml similarity index 100% rename from src/ligo/meta-michelson/meta_michelson.ml rename to src/ligo/meta_michelson/meta_michelson.ml diff --git a/src/ligo/meta-michelson/michelson_wrap.ml b/src/ligo/meta_michelson/michelson_wrap.ml similarity index 100% rename from src/ligo/meta-michelson/michelson_wrap.ml rename to src/ligo/meta_michelson/michelson_wrap.ml diff --git a/src/ligo/meta-michelson/misc.ml b/src/ligo/meta_michelson/misc.ml similarity index 100% rename from src/ligo/meta-michelson/misc.ml rename to src/ligo/meta_michelson/misc.ml diff --git a/src/ligo/meta-michelson/streams.ml b/src/ligo/meta_michelson/streams.ml similarity index 100% rename from src/ligo/meta-michelson/streams.ml rename to src/ligo/meta_michelson/streams.ml diff --git a/src/ligo/mini_c.ml b/src/ligo/mini_c.ml index 5fae00a74..5b5bb7774 100644 --- a/src/ligo/mini_c.ml +++ b/src/ligo/mini_c.ml @@ -1,4 +1,3 @@ -open Ligo_helpers open! Trace open Tezos_utils.Memory_proto_alpha @@ -114,7 +113,9 @@ and program = toplevel_statement list module PP = struct open Format - open Ligo_helpers.PP + open PP + + let list_sep_d x = list_sep x (const " , ") let space_sep ppf () = fprintf ppf " " @@ -144,14 +145,14 @@ module PP = struct and environment_small' ppf e' = let open Append_tree in let lst = to_list' e' in - fprintf ppf "S[%a]" (list_sep environment_element) lst + fprintf ppf "S[%a]" (list_sep_d environment_element) lst and environment_small ppf e = let open Append_tree in let lst = to_list e in - fprintf ppf "S[%a]" (list_sep environment_element) lst + fprintf ppf "S[%a]" (list_sep_d environment_element) lst let environment ppf (x:environment) = - fprintf ppf "Env[%a]" (list_sep environment_small) x + fprintf ppf "Env[%a]" (list_sep_d environment_small) x let rec value ppf : value -> unit = function | D_bool b -> fprintf ppf "%b" b @@ -166,7 +167,7 @@ module PP = struct | D_function x -> function_ ppf x.content | D_none -> fprintf ppf "None" | D_some s -> fprintf ppf "Some (%a)" value s - | D_map m -> fprintf ppf "Map[%a]" (list_sep value_assoc) m + | D_map m -> fprintf ppf "Map[%a]" (list_sep_d value_assoc) m and value_assoc ppf : (value * value) -> unit = fun (a, b) -> fprintf ppf "%a -> %a" value a value b diff --git a/src/ligo/ligo_multifix/ast.ml b/src/ligo/multifix/ast.ml similarity index 100% rename from src/ligo/ligo_multifix/ast.ml rename to src/ligo/multifix/ast.ml diff --git a/src/ligo/ligo_multifix/dune b/src/ligo/multifix/dune similarity index 98% rename from src/ligo/ligo_multifix/dune rename to src/ligo/multifix/dune index 22e47f863..d07ade9ae 100644 --- a/src/ligo/ligo_multifix/dune +++ b/src/ligo/multifix/dune @@ -43,6 +43,7 @@ (name generator) (libraries ocamlgraph + tezos-utils lex ) (modules generator) diff --git a/src/ligo/ligo_multifix/foo.test b/src/ligo/multifix/foo.test similarity index 100% rename from src/ligo/ligo_multifix/foo.test rename to src/ligo/multifix/foo.test diff --git a/src/ligo/ligo_multifix/generator.ml b/src/ligo/multifix/generator.ml similarity index 69% rename from src/ligo/ligo_multifix/generator.ml rename to src/ligo/multifix/generator.ml index 4831be254..fcc68ad72 100644 --- a/src/ligo/ligo_multifix/generator.ml +++ b/src/ligo/multifix/generator.ml @@ -1,61 +1,12 @@ -module N = struct - type 'a t = { - content : 'a ; - name : string ; - } +type 'a name = { + content : 'a ; + name : string ; +} - let name name content = { name ; content } - let destruct {name ; content} = (name, content) - let get_name x = x.name - let get_content x = x.content -end - -let list_filter_map f = - let rec aux acc lst = match lst with - | [] -> List.rev acc - | hd :: tl -> aux ( - match f hd with - | Some x -> x :: acc - | None -> acc - ) tl - in - aux [] - -module Ne_list = struct - type 'a t = 'a * 'a list - - let of_list lst = List.(hd lst, tl lst) - let iter f (hd, tl : _ t) = f hd ; List.iter f tl - let map f (hd, tl : _ t) = f hd, List.map f tl - let mapi f (hd, tl : _ t) = - let lst = List.mapi f (hd::tl) in - of_list lst - let concat (hd, tl : _ t) = hd @ List.concat tl - let rev (hd, tl : _ t) = - match tl with - | [] -> (hd, []) - | lst -> - let r = List.rev lst in - (List.hd r, List.tl r @ [hd]) -end - -module PP = struct - open Format - let string : formatter -> string -> unit = fun ppf s -> fprintf ppf "%s" s - let tag tag : formatter -> unit -> unit = fun ppf () -> fprintf ppf tag - let new_line : formatter -> unit -> unit = tag "@;" - let rec new_lines n ppf () = - match n with - | 0 -> new_line ppf () - | n -> new_line ppf () ; new_lines (n-1) ppf () - let const const : formatter -> unit -> unit = fun ppf () -> fprintf ppf "%s" const - let comment : formatter -> string -> unit = fun ppf s -> fprintf ppf "(* %s *)" s - let list_sep value separator = pp_print_list ~pp_sep:separator value - let ne_list_sep value separator ppf (hd, tl) = - value ppf hd ; - separator ppf () ; - pp_print_list ~pp_sep:separator value ppf tl -end +let make_name name content = { name ; content } +let destruct {name ; content} = (name, content) +let get_name x = x.name +let get_content x = x.content module Token = Lex.Token type token = Token.token @@ -70,13 +21,13 @@ module O = struct | Lower (* Lower precedence *) type operator = element list - type n_operator = operator N.t + type n_operator = operator name type n_operators = n_operator list - type level = n_operators N.t + type level = n_operators name - type hierarchy = level Ne_list.t - type n_hierarchy = hierarchy N.t + type hierarchy = level List.Ne.t + type n_hierarchy = hierarchy name type singleton = { type_name : string ; @@ -91,17 +42,17 @@ module O = struct hierarchies : n_hierarchy list ; } - let get_op : n_operator -> operator = N.get_content + let get_op : n_operator -> operator = get_content let singleton type_name type_expression menhir_rule menhir_code = {type_name ; type_expression ; menhir_rule ; menhir_code} let language entry_point singletons hierarchies = {entry_point ; singletons ; hierarchies} let name_hierarchy name : n_operators list -> n_hierarchy = fun nopss -> - let nopss' = Ne_list.of_list nopss in - let name_i = fun i x -> N.name (name ^ "_" ^ (string_of_int i)) x in - let levels : hierarchy = Ne_list.mapi name_i nopss' in - N.name name levels + 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 : hierarchy = List.Ne.mapi name_i nopss' in + make_name name levels end @@ -120,15 +71,15 @@ module Check = struct in (if (List.length es < 2) then raise (Failure "operator is too short")) ; aux es in - let op : n_operator -> unit = fun x -> elements @@ N.get_content x in - let level : level -> unit = fun l -> List.iter op @@ N.get_content l in - let hierarchy : n_hierarchy -> unit = fun h -> Ne_list.iter level @@ N.get_content h in + let op : n_operator -> unit = fun x -> elements @@ get_content x in + let level : level -> unit = fun l -> List.iter op @@ get_content l in + let hierarchy : n_hierarchy -> unit = fun h -> List.Ne.iter level @@ get_content h in List.iter hierarchy l.hierarchies let associativity : language -> unit = fun l -> let level : level -> unit = fun l -> let aux : ([`Left | `Right | `None] as 'a) -> n_operator -> 'a = fun ass nop -> - let op = N.get_content nop in + let op = get_content nop in match ass, List.hd op, List.nth op (List.length op - 1) with | _, Lower, Lower -> raise (Failure "double assoc") | `None, Lower, _ -> `Left @@ -137,11 +88,11 @@ module Check = struct | `Right, Lower, _ -> raise (Failure "different assocs") | m, _, _ -> m in - let _assert = List.fold_left aux `None (N.get_content l) in + let _assert = List.fold_left aux `None (get_content l) in () in let hierarchy : n_hierarchy -> unit = fun h -> - Ne_list.iter level (N.get_content h) in + List.Ne.iter level (get_content h) in List.iter hierarchy l.hierarchies end @@ -161,16 +112,16 @@ module Print_AST = struct | List _ -> Some ("(" ^ level_name ^ " Location.wrap list)") | Token _ -> None | Current | Lower -> Some (level_name ^ " Location.wrap") in - list_filter_map aux (N.get_content nop) 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)" - (N.get_name nop) + (get_name nop) PP.(list_sep type_element (const " * ")) type_elements let n_hierarchy : _ -> O.n_hierarchy -> _ = fun ppf nh -> - let levels = Ne_list.map N.get_content (N.get_content nh) in - let nops = Ne_list.concat levels in - let name = N.get_name nh in + let levels = List.Ne.map get_content (get_content nh) in + let nops = List.Ne.concat levels in + let name = get_name nh in fprintf ppf "type %s =@.@[%a@]" name PP.(list_sep (n_operator name) new_line) nops @@ -214,10 +165,10 @@ module Print_Grammar = struct ) ; i := !i + 1 in - PP.(list_sep element (const " ")) ppf (N.get_content nop) + PP.(list_sep element (const " ")) ppf (get_content nop) let n_operator_code : _ -> O.n_operator -> _ = fun ppf nop -> - let (name, elements) = N.destruct nop in + let (name, elements) = destruct nop in let elements' = let i = ref 0 in let aux : O.element -> _ = fun e -> @@ -227,39 +178,39 @@ module Print_Grammar = struct | List _ | Named _ | Current | Lower -> Some letters.(!i) in i := !i + 1 ; r in - list_filter_map aux elements in + List.filter_map aux elements in fprintf ppf "%s (%a)" name PP.(list_sep string (const " , ")) elements' let n_operator prev_lvl_name cur_lvl_name : _ -> O.n_operator -> _ = fun ppf nop -> - let name = N.get_name nop in + let name = get_name nop in fprintf ppf "%a@;| %a@; @[{@; @[let loc = Location.make $startpos $endpos in@;Location.wrap ~loc %@%@ %a@]@;}@]" PP.comment name (n_operator_rule prev_lvl_name cur_lvl_name) nop n_operator_code nop let level prev_lvl_name : _ -> O.level -> _ = fun ppf l -> - let name = N.get_name l in + let name = get_name l in match prev_lvl_name with | "" -> ( fprintf ppf "%s :@. @[%a@]" name - PP.(list_sep (n_operator prev_lvl_name name) new_line) (N.get_content l) ; + PP.(list_sep (n_operator prev_lvl_name name) new_line) (get_content l) ; ) | _ -> ( fprintf ppf "%s :@. @[%a@;| %s { $1 }@]" name - PP.(list_sep (n_operator prev_lvl_name name) new_line) (N.get_content l) + PP.(list_sep (n_operator prev_lvl_name name) new_line) (get_content l) prev_lvl_name ) let n_hierarchy : _ -> O.n_hierarchy -> _ = fun ppf nh -> - let name = N.get_name nh in + let name = get_name nh in fprintf ppf "%a@.%%inline %s : %s_0 { $1 }@.@;" PP.comment ("Top-level for " ^ name) name name; - let (hd, tl) = Ne_list.rev @@ N.get_content nh in + let (hd, tl) = List.Ne.rev @@ get_content nh in fprintf ppf "%a" (level "") hd ; let aux prev_name lvl = PP.new_lines 2 ppf () ; fprintf ppf "%a" (level prev_name) lvl ; - N.get_name lvl + get_name lvl in - let _last_name = List.fold_left aux (N.get_name hd) tl in + let _last_name = List.fold_left aux (get_name hd) tl in () let language : _ -> O.language -> _ = fun ppf l -> @@ -277,14 +228,14 @@ let variable = O.singleton "variable" "string" "NAME" "$1" let infix : string -> [`Left | `Right] -> token -> O.n_operator = fun name assoc t -> let open O in match assoc with - | `Left -> N.name name [Current ; Token t ; Lower] - | `Right -> N.name name [Current ; Token t ; Lower] + | `Left -> make_name name [Current ; Token t ; Lower] + | `Right -> make_name name [Current ; Token t ; Lower] -let list = N.name "List" [ +let list = make_name "List" [ O.Token Token.LIST ; List (`Lead, Token.LSQUARE, Token.SEMICOLON, Token.RSQUARE) ; ] -let let_in : O.n_operator = N.name "Let_in" [ +let let_in : O.n_operator = make_name "Let_in" [ O.Token Token.LET ; Named "variable" ; O.Token Token.EQUAL ; Current ; O.Token Token.IN ; Current ; @@ -296,7 +247,7 @@ let substraction = infix "Substraction" `Left Token.MINUS let multiplication = infix "Multiplication" `Left Token.TIMES let division = infix "Division" `Left Token.DIV -let arith_variable : O.n_operator = N.name "Arith_variable" [ O.Named "variable" ] +let arith_variable : O.n_operator = make_name "Arith_variable" [ O.Named "variable" ] let arith = O.name_hierarchy "arith" [ [let_in] ; diff --git a/src/ligo/ligo_multifix/lex/dune b/src/ligo/multifix/lex/dune similarity index 93% rename from src/ligo/ligo_multifix/lex/dune rename to src/ligo/multifix/lex/dune index e0f05760b..0d35e0e2b 100644 --- a/src/ligo/ligo_multifix/lex/dune +++ b/src/ligo/multifix/lex/dune @@ -1,6 +1,9 @@ (library (name lex) (public_name ligo.multifix.lex) + (libraries + tezos-utils + ) (modules token token_type lexer) ) diff --git a/src/ligo/ligo_multifix/lex/lexer.ml b/src/ligo/multifix/lex/lexer.ml similarity index 100% rename from src/ligo/ligo_multifix/lex/lexer.ml rename to src/ligo/multifix/lex/lexer.ml diff --git a/src/ligo/ligo_multifix/lex/lexer.mll b/src/ligo/multifix/lex/lexer.mll similarity index 100% rename from src/ligo/ligo_multifix/lex/lexer.mll rename to src/ligo/multifix/lex/lexer.mll diff --git a/src/ligo/ligo_multifix/lex/token.ml b/src/ligo/multifix/lex/token.ml similarity index 100% rename from src/ligo/ligo_multifix/lex/token.ml rename to src/ligo/multifix/lex/token.ml diff --git a/src/ligo/ligo_multifix/lex/token.mly b/src/ligo/multifix/lex/token.mly similarity index 100% rename from src/ligo/ligo_multifix/lex/token.mly rename to src/ligo/multifix/lex/token.mly diff --git a/src/ligo/ligo_multifix/lex/token_type.ml b/src/ligo/multifix/lex/token_type.ml similarity index 100% rename from src/ligo/ligo_multifix/lex/token_type.ml rename to src/ligo/multifix/lex/token_type.ml diff --git a/src/ligo/ligo_multifix/lex/token_type.mli b/src/ligo/multifix/lex/token_type.mli similarity index 100% rename from src/ligo/ligo_multifix/lex/token_type.mli rename to src/ligo/multifix/lex/token_type.mli diff --git a/src/ligo/ligo_multifix/lexer.mll b/src/ligo/multifix/lexer.mll similarity index 100% rename from src/ligo/ligo_multifix/lexer.mll rename to src/ligo/multifix/lexer.mll diff --git a/src/ligo/ligo_multifix/location.ml b/src/ligo/multifix/location.ml similarity index 100% rename from src/ligo/ligo_multifix/location.ml rename to src/ligo/multifix/location.ml diff --git a/src/ligo/ligo_multifix/parser.ml b/src/ligo/multifix/parser.ml similarity index 100% rename from src/ligo/ligo_multifix/parser.ml rename to src/ligo/multifix/parser.ml diff --git a/src/ligo/ligo_multifix/parser.mli b/src/ligo/multifix/parser.mli similarity index 100% rename from src/ligo/ligo_multifix/parser.mli rename to src/ligo/multifix/parser.mli diff --git a/src/ligo/ligo_multifix/parser.mly b/src/ligo/multifix/parser.mly similarity index 100% rename from src/ligo/ligo_multifix/parser.mly rename to src/ligo/multifix/parser.mly diff --git a/src/ligo/ligo_multifix/partial_parser.mly b/src/ligo/multifix/partial_parser.mly similarity index 100% rename from src/ligo/ligo_multifix/partial_parser.mly rename to src/ligo/multifix/partial_parser.mly diff --git a/src/ligo/ligo_multifix/pre_parser.mly b/src/ligo/multifix/pre_parser.mly similarity index 100% rename from src/ligo/ligo_multifix/pre_parser.mly rename to src/ligo/multifix/pre_parser.mly diff --git a/src/ligo/ligo_multifix/token.mly b/src/ligo/multifix/token.mly similarity index 100% rename from src/ligo/ligo_multifix/token.mly rename to src/ligo/multifix/token.mly diff --git a/src/ligo/ligo_multifix/user.ml b/src/ligo/multifix/user.ml similarity index 100% rename from src/ligo/ligo_multifix/user.ml rename to src/ligo/multifix/user.ml diff --git a/src/ligo/simplify.ml b/src/ligo/simplify.ml index 0e57dd2a0..4f0c9439f 100644 --- a/src/ligo/simplify.ml +++ b/src/ligo/simplify.ml @@ -1,4 +1,4 @@ -open Ligo_helpers.Trace +open Trace open Ast_simplified module Raw = Ligo_parser.AST diff --git a/src/ligo/simplify_mixfix.ml b/src/ligo/simplify_mixfix.ml new file mode 100644 index 000000000..b1d9d8e8c --- /dev/null +++ b/src/ligo/simplify_mixfix.ml @@ -0,0 +1,2 @@ +(* open Trace + * open Multifix.User *) diff --git a/src/ligo/transpiler.ml b/src/ligo/transpiler.ml index 1985b776a..692901034 100644 --- a/src/ligo/transpiler.ml +++ b/src/ligo/transpiler.ml @@ -1,12 +1,12 @@ -open! Ligo_helpers.Trace +open! Trace open Mini_c open Combinators module AST = Ast_typed open AST.Combinators -let list_of_map m = List.rev @@ Ligo_helpers.X_map.String.fold (fun _ v prev -> v :: prev) m [] -let kv_list_of_map m = List.rev @@ Ligo_helpers.X_map.String.fold (fun k v prev -> (k, v) :: prev) m [] +let list_of_map m = List.rev @@ Map.String.fold (fun _ v prev -> v :: prev) m [] +let kv_list_of_map m = List.rev @@ Map.String.fold (fun k v prev -> (k, v) :: prev) m [] let map_of_kv_list lst = let open AST.SMap in List.fold_left (fun prev (k, v) -> add k v prev) empty lst diff --git a/src/ligo/typer.ml b/src/ligo/typer.ml index 7fe650f3a..316cba95b 100644 --- a/src/ligo/typer.ml +++ b/src/ligo/typer.ml @@ -1,4 +1,4 @@ -open Ligo_helpers.Trace +open Trace module I = Ast_simplified module O = Ast_typed @@ -38,15 +38,17 @@ module Environment = struct module PP = struct open Format - open Ligo_helpers.PP + open PP + + let list_sep_d x = list_sep x (const " , ") let value ppf (e:t) = let pp ppf (s, e) = fprintf ppf "%s -> %a" s O.PP.type_value e in - fprintf ppf "ValueEnv[%a]" (list_sep pp) e.environment + fprintf ppf "ValueEnv[%a]" (list_sep_d pp) e.environment let type_ ppf e = let pp ppf (s, e) = fprintf ppf "%s -> %a" s O.PP.type_value e in - fprintf ppf "TypeEnv[%a]" (list_sep pp) e.type_environment + fprintf ppf "TypeEnv[%a]" (list_sep_d pp) e.type_environment let full ppf e = fprintf ppf "%a\n%a" value e type_ e