From 7a2bd3d73db54608797dcefffef73376ea2ebc43 Mon Sep 17 00:00:00 2001 From: Galfour Date: Sun, 21 Apr 2019 11:56:57 +0000 Subject: [PATCH 01/15] prepare lifting transpilation environments --- src/lib_utils/trace.ml | 12 ++++++++++++ src/ligo/ast_typed/combinators.ml | 2 +- src/ligo/ast_typed/environment.ml | 25 ++++++++++++++++--------- src/ligo/ast_typed/types.ml | 6 +++++- src/ligo/compiler/compiler_type.ml | 3 +-- src/ligo/transpiler.ml | 18 ++++++++++++++++-- src/ligo/typer.ml | 26 +++++++++++++------------- 7 files changed, 64 insertions(+), 28 deletions(-) diff --git a/src/lib_utils/trace.ml b/src/lib_utils/trace.ml index dfee6235f..c84e74af7 100644 --- a/src/lib_utils/trace.ml +++ b/src/lib_utils/trace.ml @@ -135,6 +135,10 @@ let rec bind_list = function bind_list tl >>? fun tl -> ok @@ hd :: tl ) +let bind_ne_list = fun (hd , tl) -> + hd >>? fun hd -> + bind_list tl >>? fun tl -> + ok @@ (hd , tl) let bind_smap (s:_ X_map.String.t) = let open X_map.String in @@ -154,6 +158,7 @@ let bind_fold_smap f init (smap : _ X_map.String.t) = 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_map_ne_list : _ -> 'a X_list.Ne.t -> 'b X_list.Ne.t result = fun f lst -> bind_ne_list (X_list.Ne.map f lst) let bind_location (x:_ Location.wrap) = x.wrap_content >>? fun wrap_content -> @@ -168,6 +173,13 @@ let bind_fold_list f init lst = in List.fold_left aux (ok init) lst +let bind_fold_right_list f init lst = + let aux x y = + x >>? fun x -> + f x y + in + X_list.fold_right' aux (ok init) lst + let bind_find_map_list error f lst = let rec aux lst = match lst with diff --git a/src/ligo/ast_typed/combinators.ml b/src/ligo/ast_typed/combinators.ml index 6dc47492a..5d049c9d1 100644 --- a/src/ligo/ast_typed/combinators.ml +++ b/src/ligo/ast_typed/combinators.ml @@ -149,6 +149,6 @@ let get_a_bool (t:annotated_expression) = open Environment let env_sum_type ?(env = full_empty) ?(name = "a_sum_type") - (lst : (string * element) list) = + (lst : (string * type_value) list) = add_type name (make_t_ez_sum lst) env diff --git a/src/ligo/ast_typed/environment.ml b/src/ligo/ast_typed/environment.ml index c5a2251f5..ead92cfc1 100644 --- a/src/ligo/ast_typed/environment.ml +++ b/src/ligo/ast_typed/environment.ml @@ -1,32 +1,36 @@ open Types -type element = type_value +type element = environment_element +let make_element : type_value -> full_environment -> element = + fun type_value source_environment -> {type_value ; source_environment} module Small = struct type t = small_environment let empty : t = ([] , []) + let get_environment : t -> environment = fst let get_type_environment : t -> type_environment = snd let map_environment : _ -> t -> t = fun f (a , b) -> (f a , b) let map_type_environment : _ -> t -> t = fun f (a , b) -> (a , f b) let add : string -> element -> t -> t = fun k v -> map_environment (fun x -> (k , v) :: x) - let add_type : string -> element -> t -> t = fun k v -> map_type_environment (fun x -> (k , v) :: x) + let add_type : string -> type_value -> t -> t = fun k v -> map_type_environment (fun x -> (k , v) :: x) let get_opt : string -> t -> element option = fun k x -> List.assoc_opt k (get_environment x) - let get_type_opt : string -> t -> element option = fun k x -> List.assoc_opt k (get_type_environment x) + let get_type_opt : string -> t -> type_value option = fun k x -> List.assoc_opt k (get_type_environment x) end type t = full_environment let empty : environment = Small.(get_environment empty) let full_empty : t = List.Ne.singleton Small.empty let add : string -> element -> t -> t = fun k v -> List.Ne.hd_map (Small.add k v) -let add_type : string -> element -> t -> t = fun k v -> List.Ne.hd_map (Small.add_type k v) +let add_ez : string -> type_value -> t -> t = fun k v e -> List.Ne.hd_map (Small.add k (make_element v e)) e +let add_type : string -> type_value -> t -> t = fun k v -> List.Ne.hd_map (Small.add_type k v) let get_opt : string -> t -> element option = fun k x -> List.Ne.find_map (Small.get_opt k) x -let get_type_opt : string -> t -> element option = fun k x -> List.Ne.find_map (Small.get_type_opt k) x +let get_type_opt : string -> t -> type_value option = fun k x -> List.Ne.find_map (Small.get_type_opt k) x -let get_constructor : string -> t -> (element * element) option = fun k x -> (* Left is the constructor, right is the sum type *) +let get_constructor : string -> t -> (type_value * type_value) option = fun k x -> (* Left is the constructor, right is the sum type *) let aux = fun x -> let aux = fun (_type_name , x) -> match x.type_value' with @@ -43,14 +47,17 @@ module PP = struct let list_sep_scope x = list_sep x (const " | ") - let assoc = fun ppf (k , tv) -> + let environment_element = fun ppf (k , (ele : environment_element)) -> + fprintf ppf "%s -> %a" k PP.type_value ele.type_value + + let type_environment_element = fun ppf (k , tv) -> fprintf ppf "%s -> %a" k PP.type_value tv let environment : _ -> environment -> unit = fun ppf lst -> - fprintf ppf "E[%a]" (list_sep assoc (const " , ")) lst + fprintf ppf "E[%a]" (list_sep environment_element (const " , ")) lst let type_environment = fun ppf lst -> - fprintf ppf "T[%a]" (list_sep assoc (const " , ")) lst + fprintf ppf "T[%a]" (list_sep type_environment_element (const " , ")) lst let small_environment : _ -> small_environment -> unit = fun ppf e -> fprintf ppf "- %a\t%a" diff --git a/src/ligo/ast_typed/types.ml b/src/ligo/ast_typed/types.ml index 0a2bc4129..d226c2c5c 100644 --- a/src/ligo/ast_typed/types.ml +++ b/src/ligo/ast_typed/types.ml @@ -16,7 +16,11 @@ and declaration = | Declaration_constant of named_expression (* | Macro_declaration of macro_declaration *) -and environment = (string * type_value) list +and environment_element = { + type_value : type_value ; + source_environment : full_environment ; +} +and environment = (string * environment_element) list and type_environment = (string * type_value) list and small_environment = (environment * type_environment) and full_environment = small_environment List.Ne.t diff --git a/src/ligo/compiler/compiler_type.ml b/src/ligo/compiler/compiler_type.ml index 7bdccadc8..cc2726a38 100644 --- a/src/ligo/compiler/compiler_type.ml +++ b/src/ligo/compiler/compiler_type.ml @@ -85,7 +85,6 @@ module Ty = struct let%bind (Ex_ty t') = type_ t in ok @@ Ex_ty Contract_types.(option t') - and environment_small' = let open Append_tree in function | Leaf (_, x) -> type_ x | Node {a;b} -> @@ -98,7 +97,7 @@ module Ty = struct | Full x -> environment_small' x and environment = function - | [] | [Empty] -> simple_fail "Schema.Big.to_ty" + | [] | [Empty] -> ok @@ Ex_ty Contract_types.unit | [a] -> environment_small a | Empty :: b -> environment b | a::b -> diff --git a/src/ligo/transpiler.ml b/src/ligo/transpiler.ml index 287c69f49..2a0c63365 100644 --- a/src/ligo/transpiler.ml +++ b/src/ligo/transpiler.ml @@ -182,9 +182,24 @@ and translate_literal : AST.literal -> value = fun l -> match l with | Literal_string s -> D_string s | Literal_unit -> D_unit +and transpile_small_environment : AST.small_environment -> Environment.Small.t result = fun x -> + let x' = AST.Environment.Small.get_environment x in + let aux prec (name , (ele : AST.environment_element)) = + let%bind tv' = translate_type ele.type_value in + ok @@ Environment.Small.append (name , tv') prec + in + trace (simple_error "transpiling small environment") @@ + bind_fold_right_list aux Append_tree.Empty x' + +and transpile_environment : AST.full_environment -> Environment.t result = fun x -> + let%bind nlst = bind_map_ne_list transpile_small_environment x in + ok @@ List.Ne.to_list nlst + and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_expression) : expression result = let%bind tv = translate_type ae.type_annotation in - let return ?(tv = tv) expr = ok @@ Combinators.Expression.make_tpl (expr, tv, env) in + let return ?(tv = tv) expr = + (* let%bind env' = transpile_environment ae.environment in *) + ok @@ Combinators.Expression.make_tpl (expr, tv, env) in let f = translate_annotated_expression env in match ae.expression with | E_literal l -> return @@ E_literal (translate_literal l) @@ -486,7 +501,6 @@ let extract_record (v : value) (tree : _ Append_tree.t') : (_ list) result = in aux (tree, v) - let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression result = let open! AST in let return e = ok (make_a_e_empty e t) in diff --git a/src/ligo/typer.ml b/src/ligo/typer.ml index c3716b008..6059aafe7 100644 --- a/src/ligo/typer.ml +++ b/src/ligo/typer.ml @@ -73,7 +73,7 @@ and type_declaration env : I.declaration -> (environment * O.declaration option) let%bind ae' = trace (constant_declaration_error name annotated_expression) @@ type_annotated_expression env annotated_expression in - let env' = Environment.add name ae'.type_annotation env in + let env' = Environment.add_ez name ae'.type_annotation env in ok (env', Some (O.Declaration_constant (make_n_e name ae'))) and type_block_full (e:environment) (b:I.block) : (O.block * environment) result = @@ -106,18 +106,18 @@ and type_instruction (e:environment) : I.instruction -> (environment * O.instruc | None, None -> simple_fail "Initial assignments need type annotation" | Some _, None -> let%bind annotated_expression = type_annotated_expression e annotated_expression in - let e' = Environment.add name annotated_expression.type_annotation e in + let e' = Environment.add_ez name annotated_expression.type_annotation e in ok (e', [O.I_declaration (make_n_e name annotated_expression)]) | None, Some prev -> let%bind annotated_expression = type_annotated_expression e annotated_expression in let%bind _ = - O.assert_type_value_eq (annotated_expression.type_annotation, prev) in + O.assert_type_value_eq (annotated_expression.type_annotation, prev.type_value) in ok (e, [O.I_assignment (make_n_e name annotated_expression)]) | Some _, Some prev -> let%bind annotated_expression = type_annotated_expression e annotated_expression in let%bind _assert = trace (simple_error "Annotation doesn't match environment") - @@ O.assert_type_value_eq (annotated_expression.type_annotation, prev) in - let e' = Environment.add name annotated_expression.type_annotation e in + @@ O.assert_type_value_eq (annotated_expression.type_annotation, prev.type_value) in + let e' = Environment.add_ez name annotated_expression.type_annotation e in ok (e', [O.I_assignment (make_n_e name annotated_expression)]) ) | I_matching (ex, m) -> @@ -130,7 +130,7 @@ and type_instruction (e:environment) : I.instruction -> (environment * O.instruc let%bind ty = trace_option (simple_error "unbound variable in record_patch") @@ Environment.get_opt r e in - let tv = O.{type_name = r ; type_value = ty} in + let tv = O.{type_name = r ; type_value = ty.type_value} in let aux ty access = match access with | I.Access_record s -> @@ -142,7 +142,7 @@ and type_instruction (e:environment) : I.instruction -> (environment * O.instruc generic_try (simple_error "unbound tuple access in record_patch") @@ (fun () -> List.nth t i) in - let%bind _assert = bind_fold_list aux ty (path @ [Access_record s]) in + let%bind _assert = bind_fold_list aux ty.type_value (path @ [Access_record s]) in ok @@ O.I_patch (tv, path @ [Access_record s], ae') in let%bind lst' = bind_map_list aux lst in @@ -165,7 +165,7 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t let%bind match_none = f e match_none in let (n, b) = match_some in let n' = n, t_opt in - let e' = Environment.add n t_opt e in + let e' = Environment.add_ez n t_opt e in let%bind b' = f e' b in ok (O.Match_option {match_none ; match_some = (n', b')}) | Match_list {match_nil ; match_cons} -> @@ -174,8 +174,8 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t @@ get_t_list t in let%bind match_nil = f e match_nil in let (hd, tl, b) = match_cons in - let e' = Environment.add hd t_list e in - let e' = Environment.add tl t e' in + let e' = Environment.add_ez hd t_list e in + let e' = Environment.add_ez tl t e' in let%bind b' = f e' b in ok (O.Match_list {match_nil ; match_cons = (hd, tl, b')}) | Match_tuple (lst, b) -> @@ -185,7 +185,7 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t let%bind lst' = generic_try (simple_error "Matching tuple of different size") @@ (fun () -> List.combine lst t_tuple) in - let aux prev (name, tv) = Environment.add name tv prev in + let aux prev (name, tv) = Environment.add_ez name tv prev in let e' = List.fold_left aux e lst' in let%bind b' = f e' b in ok (O.Match_tuple (lst, b')) @@ -239,7 +239,7 @@ and type_annotated_expression : environment -> I.annotated_expression -> O.annot let%bind tv' = trace_option (unbound_variable e name) @@ Environment.get_opt name e in - return (E_variable name) tv' + return (E_variable name) tv'.type_value | E_literal (Literal_bool b) -> return (E_literal (Literal_bool b)) (t_bool ()) | E_literal Literal_unit -> @@ -359,7 +359,7 @@ and type_annotated_expression : environment -> I.annotated_expression -> O.annot } -> let%bind input_type = evaluate_type e input_type in let%bind output_type = evaluate_type e output_type in - let e' = Environment.add binder input_type e in + let e' = Environment.add_ez binder input_type e in let%bind (body, e'') = type_block_full e' body in let%bind result = type_annotated_expression e'' result in return (E_lambda {binder;input_type;output_type;result;body}) (t_function input_type output_type ()) From 0e04a152bbbbd63b72aeee034aa3b2e87147ccdd Mon Sep 17 00:00:00 2001 From: Galfour Date: Sun, 21 Apr 2019 12:08:12 +0000 Subject: [PATCH 02/15] refactor ast_simplified --- src/ligo/ast_simplified/PP.ml | 95 +++++ src/ligo/ast_simplified/ast_simplified.ml | 434 +--------------------- src/ligo/ast_simplified/combinators.ml | 74 ++++ src/ligo/ast_simplified/misc.ml | 141 +++++++ src/ligo/ast_simplified/types.ml | 113 ++++++ src/ligo/simplify.ml | 74 ++-- src/ligo/simplify_multifix.ml | 9 +- src/ligo/test/typer_tests.ml | 6 +- src/ligo/typer.ml | 4 +- 9 files changed, 476 insertions(+), 474 deletions(-) create mode 100644 src/ligo/ast_simplified/PP.ml create mode 100644 src/ligo/ast_simplified/combinators.ml create mode 100644 src/ligo/ast_simplified/misc.ml create mode 100644 src/ligo/ast_simplified/types.ml diff --git a/src/ligo/ast_simplified/PP.ml b/src/ligo/ast_simplified/PP.ml new file mode 100644 index 000000000..f8fc9cc65 --- /dev/null +++ b/src/ligo/ast_simplified/PP.ml @@ -0,0 +1,95 @@ +open Types +open PP_helpers +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_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_d type_expression) lst + +let literal ppf (l:literal) = match l with + | Literal_unit -> fprintf ppf "Unit" + | Literal_bool b -> fprintf ppf "%b" b + | Literal_int n -> fprintf ppf "%d" n + | Literal_nat n -> fprintf ppf "%d" n + | Literal_string s -> fprintf ppf "%S" s + | Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b + +let rec expression ppf (e:expression) = match e with + | E_literal l -> literal ppf l + | 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_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_d annotated_expression) m + | E_map m -> fprintf ppf "map[%a]" (list_sep_d assoc_annotated_expression) m + | E_list lst -> fprintf ppf "list[%a]" (list_sep_d annotated_expression) lst + | 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" + binder type_expression input_type type_expression output_type + block body annotated_expression result + | E_matching (ae, m) -> + fprintf ppf "match %a with %a" annotated_expression ae (matching annotated_expression) m + +and assoc_annotated_expression ppf : (ae * ae) -> unit = fun (a, b) -> + fprintf ppf "%a -> %a" annotated_expression a annotated_expression b + +and access ppf (a:access) = + match a with + | Access_tuple n -> fprintf ppf "%d" n + | Access_record s -> fprintf ppf "%s" s + +and access_path ppf (p:access_path) = + fprintf ppf "%a" (list_sep access (const ".")) p + +and type_annotation ppf (ta:type_expression option) = match ta with + | None -> fprintf ppf "" + | Some t -> type_expression ppf t + +and annotated_expression ppf (ae:annotated_expression) = match ae.type_annotation with + | 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 (tag "@;")) ppf b + +and single_record_patch ppf ((p, ae) : string * ae) = + fprintf ppf "%s <- %a" p annotated_expression ae + +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_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)} -> + fprintf ppf "| Nil -> %a @.| %s :: %s -> %a" f match_nil hd tl f match_cons + | Match_option {match_none ; match_some = (some, match_some)} -> + fprintf ppf "| None -> %a @.| Some %s -> %a" f match_none some f match_some + +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_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 + | I_matching (ae, m) -> + fprintf ppf "match %a with %a" annotated_expression ae (matching block) m + +let declaration ppf (d:declaration) = match d with + | Declaration_type {type_name ; type_expression = te} -> + fprintf ppf "type %s = %a" type_name type_expression te + | Declaration_constant {name ; annotated_expression = ae} -> + fprintf ppf "const %s = %a" name annotated_expression ae + +let program ppf (p:program) = + fprintf ppf "@[%a@]" (list_sep declaration (tag "@;")) (List.map Location.unwrap p) diff --git a/src/ligo/ast_simplified/ast_simplified.ml b/src/ligo/ast_simplified/ast_simplified.ml index 5511255ad..a49ce9e8b 100644 --- a/src/ligo/ast_simplified/ast_simplified.ml +++ b/src/ligo/ast_simplified/ast_simplified.ml @@ -1,430 +1,4 @@ -module SMap = Map.String - -type name = string -type type_name = string - -type 'a name_map = 'a SMap.t -type 'a type_name_map = 'a SMap.t - -type program = declaration Location.wrap list - -and declaration = - | Declaration_type of named_type_expression - | Declaration_constant of named_expression - (* | Macro_declaration of macro_declaration *) - -and annotated_expression = { - expression: expression ; - type_annotation: te option ; -} - -and named_expression = { - name: name ; - annotated_expression: ae ; -} - -and named_type_expression = { - type_name: type_name ; - type_expression: type_expression ; -} - -and te = type_expression -and ae = annotated_expression -and te_map = type_expression type_name_map -and ae_map = annotated_expression name_map - -and type_expression = - | T_tuple of te list - | T_sum of te_map - | T_record of te_map - | T_function of te * te - | T_variable of type_name - | T_constant of type_name * te list - -and lambda = { - binder: name ; - input_type: type_expression ; - output_type: type_expression ; - result: ae ; - body: block ; -} - -and expression = - (* Base *) - | E_literal of literal - | E_constant of (name * ae list) (* For language constants, like (Cons hd tl) or (plus i j) *) - | E_variable of name - | E_lambda of lambda - | E_application of (ae * ae) - (* E_Tuple *) - | E_tuple of ae list - (* Sum *) - | E_constructor of (name * ae) (* For user defined constructors *) - (* E_record *) - | E_record of ae_map - | E_accessor of (ae * access_path) - (* Data Structures *) - | E_map of (ae * ae) list - | E_list of ae list - | E_look_up of (ae * ae) - (* Matching *) - | E_matching of (ae * matching_expr) - -and access = - | Access_tuple of int - | Access_record of string - -and access_path = access list - -and literal = - | Literal_unit - | Literal_bool of bool - | Literal_int of int - | Literal_nat of int - | Literal_string of string - | Literal_bytes of bytes - -and block = instruction list -and b = block - -and instruction = - | I_assignment of named_expression - | I_matching of ae * matching_instr - | I_loop of ae * b - | I_skip - | I_fail of ae - | I_record_patch of name * access_path * (string * ae) list - -and 'a matching = - | Match_bool of { - match_true : 'a ; - match_false : 'a ; - } - | Match_list of { - match_nil : 'a ; - match_cons : name * name * 'a ; - } - | Match_option of { - match_none : 'a ; - match_some : name * 'a ; - } - | Match_tuple of name list * 'a - -and matching_instr = b matching - -and matching_expr = annotated_expression matching - -let ae expression = {expression ; type_annotation = None} - -let annotated_expression expression type_annotation = {expression ; type_annotation} - -open Trace - -module PP = struct - open PP_helpers - 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_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_d type_expression) lst - - let literal ppf (l:literal) = match l with - | Literal_unit -> fprintf ppf "Unit" - | Literal_bool b -> fprintf ppf "%b" b - | Literal_int n -> fprintf ppf "%d" n - | Literal_nat n -> fprintf ppf "%d" n - | Literal_string s -> fprintf ppf "%S" s - | Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b - - let rec expression ppf (e:expression) = match e with - | E_literal l -> literal ppf l - | 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_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_d annotated_expression) m - | E_map m -> fprintf ppf "map[%a]" (list_sep_d assoc_annotated_expression) m - | E_list lst -> fprintf ppf "list[%a]" (list_sep_d annotated_expression) lst - | 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" - binder type_expression input_type type_expression output_type - block body annotated_expression result - | E_matching (ae, m) -> - fprintf ppf "match %a with %a" annotated_expression ae (matching annotated_expression) m - - and assoc_annotated_expression ppf : (ae * ae) -> unit = fun (a, b) -> - fprintf ppf "%a -> %a" annotated_expression a annotated_expression b - - and access ppf (a:access) = - match a with - | Access_tuple n -> fprintf ppf "%d" n - | Access_record s -> fprintf ppf "%s" s - - and access_path ppf (p:access_path) = - fprintf ppf "%a" (list_sep access (const ".")) p - - and type_annotation ppf (ta:type_expression option) = match ta with - | None -> fprintf ppf "" - | Some t -> type_expression ppf t - - and annotated_expression ppf (ae:annotated_expression) = match ae.type_annotation with - | 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 (tag "@;")) ppf b - - and single_record_patch ppf ((p, ae) : string * ae) = - fprintf ppf "%s <- %a" p annotated_expression ae - - 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_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)} -> - fprintf ppf "| Nil -> %a @.| %s :: %s -> %a" f match_nil hd tl f match_cons - | Match_option {match_none ; match_some = (some, match_some)} -> - fprintf ppf "| None -> %a @.| Some %s -> %a" f match_none some f match_some - - 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_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 - | I_matching (ae, m) -> - fprintf ppf "match %a with %a" annotated_expression ae (matching block) m - - let declaration ppf (d:declaration) = match d with - | Declaration_type {type_name ; type_expression = te} -> - fprintf ppf "type %s = %a" type_name type_expression te - | Declaration_constant {name ; annotated_expression = ae} -> - fprintf ppf "const %s = %a" name annotated_expression ae - - let program ppf (p:program) = - fprintf ppf "@[%a@]" (list_sep declaration (tag "@;")) (List.map Location.unwrap p) -end - -module Rename = struct - module Type = struct - (* Type renaming, not needed. Yet. *) - end - - module Value = struct - type renaming = string * (string * access_path) (* src -> dst *) - type renamings = renaming list - let filter (r:renamings) (s:string) : renamings = - List.filter (fun (x, _) -> not (x = s)) r - let filters (r:renamings) (ss:string list) : renamings = - List.filter (fun (x, _) -> not (List.mem x ss)) r - - let rec rename_instruction (r:renamings) (i:instruction) : instruction result = - match i with - | I_assignment ({name;annotated_expression = e} as a) -> ( - match List.assoc_opt name r with - | None -> - let%bind annotated_expression = rename_annotated_expression (filter r name) e in - ok (I_assignment {a with annotated_expression}) - | Some (name', lst) -> ( - let%bind annotated_expression = rename_annotated_expression r e in - match lst with - | [] -> ok (I_assignment {name = name' ; annotated_expression}) - | lst -> - let (hds, tl) = - let open List in - let r = rev lst in - rev @@ tl r, hd r - in - let%bind tl' = match tl with - | Access_record n -> ok n - | Access_tuple _ -> simple_fail "no support for renaming into tuples yet" in - ok (I_record_patch (name', hds, [tl', annotated_expression])) - ) - ) - | I_skip -> ok I_skip - | I_fail e -> - let%bind e' = rename_annotated_expression r e in - ok (I_fail e') - | I_loop (cond, body) -> - let%bind cond' = rename_annotated_expression r cond in - let%bind body' = rename_block r body in - ok (I_loop (cond', body')) - | I_matching (ae, m) -> - let%bind ae' = rename_annotated_expression r ae in - let%bind m' = rename_matching rename_block r m in - ok (I_matching (ae', m')) - | I_record_patch (v, path, lst) -> - let aux (x, y) = - let%bind y' = rename_annotated_expression (filter r v) y in - ok (x, y') in - let%bind lst' = bind_map_list aux lst in - match List.assoc_opt v r with - | None -> ( - ok (I_record_patch (v, path, lst')) - ) - | Some (v', path') -> ( - ok (I_record_patch (v', path' @ path, lst')) - ) - and rename_block (r:renamings) (bl:block) : block result = - bind_map_list (rename_instruction r) bl - - and rename_matching : type a . (renamings -> a -> a result) -> renamings -> a matching -> a matching result = - fun f r m -> - match m with - | Match_bool { match_true = mt ; match_false = mf } -> - let%bind match_true = f r mt in - let%bind match_false = f r mf in - ok (Match_bool {match_true ; match_false}) - | Match_option { match_none = mn ; match_some = (some, ms) } -> - let%bind match_none = f r mn in - let%bind ms' = f (filter r some) ms in - ok (Match_option {match_none ; match_some = (some, ms')}) - | Match_list { match_nil = mn ; match_cons = (hd, tl, mc) } -> - let%bind match_nil = f r mn in - let%bind mc' = f (filters r [hd;tl]) mc in - ok (Match_list {match_nil ; match_cons = (hd, tl, mc')}) - | Match_tuple (lst, body) -> - let%bind body' = f (filters r lst) body in - ok (Match_tuple (lst, body')) - - and rename_matching_instruction = fun x -> rename_matching rename_block x - - and rename_matching_expr = fun x -> rename_matching rename_expression x - - and rename_annotated_expression (r:renamings) (ae:annotated_expression) : annotated_expression result = - let%bind expression = rename_expression r ae.expression in - ok {ae with expression} - - and rename_expression : renamings -> expression -> expression result = fun r e -> - match e with - | E_literal _ as l -> ok l - | E_constant (name, lst) -> - let%bind lst' = bind_map_list (rename_annotated_expression r) lst in - ok (E_constant (name, lst')) - | E_constructor (name, ae) -> - let%bind ae' = rename_annotated_expression r ae in - ok (E_constructor (name, ae')) - | E_variable v -> ( - match List.assoc_opt v r with - | None -> ok (E_variable v) - | Some (name, path) -> ok (E_accessor (ae (E_variable (name)), path)) - ) - | E_lambda ({binder;body;result} as l) -> - let r' = filter r binder in - let%bind body = rename_block r' body in - let%bind result = rename_annotated_expression r' result in - ok (E_lambda {l with body ; result}) - | E_application (f, arg) -> - let%bind f' = rename_annotated_expression r f in - let%bind arg' = rename_annotated_expression r arg in - ok (E_application (f', arg')) - | E_tuple lst -> - let%bind lst' = bind_map_list (rename_annotated_expression r) lst in - ok (E_tuple lst') - | E_accessor (ae, p) -> - let%bind ae' = rename_annotated_expression r ae in - ok (E_accessor (ae', p)) - | E_record sm -> - let%bind sm' = bind_smap - @@ SMap.map (rename_annotated_expression r) sm in - ok (E_record sm') - | E_map m -> - let%bind m' = bind_map_list - (fun (x, y) -> bind_map_pair (rename_annotated_expression r) (x, y)) m in - ok (E_map m') - | E_list lst -> - let%bind lst' = bind_map_list (rename_annotated_expression r) lst in - ok (E_list lst') - | E_look_up m -> - let%bind m' = bind_map_pair (rename_annotated_expression r) m in - ok (E_look_up m') - | E_matching (ae, m) -> - let%bind ae' = rename_annotated_expression r ae in - let%bind m' = rename_matching rename_annotated_expression r m in - ok (E_matching (ae', m')) - end -end - -module Combinators = struct - let t_bool : type_expression = T_constant ("bool", []) - let t_string : type_expression = T_constant ("string", []) - let t_bytes : type_expression = T_constant ("bytes", []) - let t_int : type_expression = T_constant ("int", []) - let t_unit : type_expression = T_constant ("unit", []) - let t_option o : type_expression = T_constant ("option", [o]) - let t_list t : type_expression = T_constant ("list", [t]) - let t_tuple lst : type_expression = T_tuple lst - let t_pair a b = t_tuple [a ; b] - let t_record m : type_expression = (T_record m) - let t_ez_record (lst:(string * type_expression) list) : type_expression = - let aux prev (k, v) = SMap.add k v prev in - let map = List.fold_left aux SMap.empty lst in - T_record map - - let t_record_ez lst = - let m = SMap.of_list lst in - t_record m - - let t_sum m : type_expression = T_sum m - let ez_t_sum (lst:(string * type_expression) list) : type_expression = - let aux prev (k, v) = SMap.add k v prev in - let map = List.fold_left aux SMap.empty lst in - T_sum map - - let t_function param result : type_expression = T_function (param, result) - - let e_annotated_expression ?type_annotation expression = {expression ; type_annotation} - - let name (s : string) : name = s - - let e_var (s : string) : expression = E_variable s - - let e_unit () : expression = E_literal (Literal_unit) - let e_int n : expression = E_literal (Literal_int n) - let e_nat n : expression = E_literal (Literal_nat n) - let e_bool b : expression = E_literal (Literal_bool b) - let e_string s : expression = E_literal (Literal_string s) - let e_bytes b : expression = E_literal (Literal_bytes (Bytes.of_string b)) - - let e_lambda (binder : string) - (input_type : type_expression) - (output_type : type_expression) - (result : expression) - (body : block) - : expression = - E_lambda { - binder = (name binder) ; - input_type = input_type ; - output_type = output_type ; - result = (ae result) ; - body ; - } - - let e_tuple (lst : ae list) : expression = E_tuple lst - let ez_e_tuple (lst : expression list) : expression = - e_tuple (List.map (fun e -> ae e) lst) - - let e_constructor (s : string) (e : ae) : expression = E_constructor (name s, e) - - let e_record (lst : (string * ae) list) : expression = - let aux prev (k, v) = SMap.add k v prev in - let map = List.fold_left aux SMap.empty lst in - E_record map - - let ez_e_record (lst : (string * expression) list) : expression = - (* TODO: define a correct implementation of List.map - * (an implementation that does not fail with stack overflow) *) - e_record (List.map (fun (s,e) -> (s, ae e)) lst) -end +include Types +module Types = Types +module PP = PP +module Combinators = Combinators diff --git a/src/ligo/ast_simplified/combinators.ml b/src/ligo/ast_simplified/combinators.ml new file mode 100644 index 000000000..9e53ab31a --- /dev/null +++ b/src/ligo/ast_simplified/combinators.ml @@ -0,0 +1,74 @@ +open Types + +module SMap = Map.String + +let t_bool : type_expression = T_constant ("bool", []) +let t_string : type_expression = T_constant ("string", []) +let t_bytes : type_expression = T_constant ("bytes", []) +let t_int : type_expression = T_constant ("int", []) +let t_unit : type_expression = T_constant ("unit", []) +let t_option o : type_expression = T_constant ("option", [o]) +let t_list t : type_expression = T_constant ("list", [t]) +let t_tuple lst : type_expression = T_tuple lst +let t_pair a b = t_tuple [a ; b] +let t_record m : type_expression = (T_record m) +let t_ez_record (lst:(string * type_expression) list) : type_expression = + let aux prev (k, v) = SMap.add k v prev in + let map = List.fold_left aux SMap.empty lst in + T_record map + +let t_record_ez lst = + let m = SMap.of_list lst in + t_record m + +let t_sum m : type_expression = T_sum m +let ez_t_sum (lst:(string * type_expression) list) : type_expression = + let aux prev (k, v) = SMap.add k v prev in + let map = List.fold_left aux SMap.empty lst in + T_sum map + +let t_function param result : type_expression = T_function (param, result) + +let make_e_a ?type_annotation expression = {expression ; type_annotation} +let make_e_a_full expression type_annotation = make_e_a ~type_annotation expression + +let name (s : string) : name = s + +let e_var (s : string) : expression = E_variable s + +let e_unit () : expression = E_literal (Literal_unit) +let e_int n : expression = E_literal (Literal_int n) +let e_nat n : expression = E_literal (Literal_nat n) +let e_bool b : expression = E_literal (Literal_bool b) +let e_string s : expression = E_literal (Literal_string s) +let e_bytes b : expression = E_literal (Literal_bytes (Bytes.of_string b)) + +let e_lambda (binder : string) + (input_type : type_expression) + (output_type : type_expression) + (result : expression) + (body : block) + : expression = + E_lambda { + binder = (name binder) ; + input_type = input_type ; + output_type = output_type ; + result = (make_e_a result) ; + body ; + } + +let e_tuple (lst : ae list) : expression = E_tuple lst +let ez_e_tuple (lst : expression list) : expression = + e_tuple (List.map make_e_a lst) + +let e_constructor (s : string) (e : ae) : expression = E_constructor (name s, e) + +let e_record (lst : (string * ae) list) : expression = + let aux prev (k, v) = SMap.add k v prev in + let map = List.fold_left aux SMap.empty lst in + E_record map + +let ez_e_record (lst : (string * expression) list) : expression = + (* TODO: define a correct implementation of List.map + * (an implementation that does not fail with stack overflow) *) + e_record (List.map (fun (s,e) -> (s, make_e_a e)) lst) diff --git a/src/ligo/ast_simplified/misc.ml b/src/ligo/ast_simplified/misc.ml new file mode 100644 index 000000000..48530be56 --- /dev/null +++ b/src/ligo/ast_simplified/misc.ml @@ -0,0 +1,141 @@ +(* module Rename = struct + * open Trace + * + * module Type = struct + * (\* Type renaming, not needed. Yet. *\) + * end + * + * module Value = struct + * type renaming = string * (string * access_path) (\* src -> dst *\) + * type renamings = renaming list + * let filter (r:renamings) (s:string) : renamings = + * List.filter (fun (x, _) -> not (x = s)) r + * let filters (r:renamings) (ss:string list) : renamings = + * List.filter (fun (x, _) -> not (List.mem x ss)) r + * + * let rec rename_instruction (r:renamings) (i:instruction) : instruction result = + * match i with + * | I_assignment ({name;annotated_expression = e} as a) -> ( + * match List.assoc_opt name r with + * | None -> + * let%bind annotated_expression = rename_annotated_expression (filter r name) e in + * ok (I_assignment {a with annotated_expression}) + * | Some (name', lst) -> ( + * let%bind annotated_expression = rename_annotated_expression r e in + * match lst with + * | [] -> ok (I_assignment {name = name' ; annotated_expression}) + * | lst -> + * let (hds, tl) = + * let open List in + * let r = rev lst in + * rev @@ tl r, hd r + * in + * let%bind tl' = match tl with + * | Access_record n -> ok n + * | Access_tuple _ -> simple_fail "no support for renaming into tuples yet" in + * ok (I_record_patch (name', hds, [tl', annotated_expression])) + * ) + * ) + * | I_skip -> ok I_skip + * | I_fail e -> + * let%bind e' = rename_annotated_expression r e in + * ok (I_fail e') + * | I_loop (cond, body) -> + * let%bind cond' = rename_annotated_expression r cond in + * let%bind body' = rename_block r body in + * ok (I_loop (cond', body')) + * | I_matching (ae, m) -> + * let%bind ae' = rename_annotated_expression r ae in + * let%bind m' = rename_matching rename_block r m in + * ok (I_matching (ae', m')) + * | I_record_patch (v, path, lst) -> + * let aux (x, y) = + * let%bind y' = rename_annotated_expression (filter r v) y in + * ok (x, y') in + * let%bind lst' = bind_map_list aux lst in + * match List.assoc_opt v r with + * | None -> ( + * ok (I_record_patch (v, path, lst')) + * ) + * | Some (v', path') -> ( + * ok (I_record_patch (v', path' @ path, lst')) + * ) + * and rename_block (r:renamings) (bl:block) : block result = + * bind_map_list (rename_instruction r) bl + * + * and rename_matching : type a . (renamings -> a -> a result) -> renamings -> a matching -> a matching result = + * fun f r m -> + * match m with + * | Match_bool { match_true = mt ; match_false = mf } -> + * let%bind match_true = f r mt in + * let%bind match_false = f r mf in + * ok (Match_bool {match_true ; match_false}) + * | Match_option { match_none = mn ; match_some = (some, ms) } -> + * let%bind match_none = f r mn in + * let%bind ms' = f (filter r some) ms in + * ok (Match_option {match_none ; match_some = (some, ms')}) + * | Match_list { match_nil = mn ; match_cons = (hd, tl, mc) } -> + * let%bind match_nil = f r mn in + * let%bind mc' = f (filters r [hd;tl]) mc in + * ok (Match_list {match_nil ; match_cons = (hd, tl, mc')}) + * | Match_tuple (lst, body) -> + * let%bind body' = f (filters r lst) body in + * ok (Match_tuple (lst, body')) + * + * and rename_matching_instruction = fun x -> rename_matching rename_block x + * + * and rename_matching_expr = fun x -> rename_matching rename_expression x + * + * and rename_annotated_expression (r:renamings) (ae:annotated_expression) : annotated_expression result = + * let%bind expression = rename_expression r ae.expression in + * ok {ae with expression} + * + * and rename_expression : renamings -> expression -> expression result = fun r e -> + * match e with + * | E_literal _ as l -> ok l + * | E_constant (name, lst) -> + * let%bind lst' = bind_map_list (rename_annotated_expression r) lst in + * ok (E_constant (name, lst')) + * | E_constructor (name, ae) -> + * let%bind ae' = rename_annotated_expression r ae in + * ok (E_constructor (name, ae')) + * | E_variable v -> ( + * match List.assoc_opt v r with + * | None -> ok (E_variable v) + * | Some (name, path) -> ok (E_accessor (ae (E_variable (name)), path)) + * ) + * | E_lambda ({binder;body;result} as l) -> + * let r' = filter r binder in + * let%bind body = rename_block r' body in + * let%bind result = rename_annotated_expression r' result in + * ok (E_lambda {l with body ; result}) + * | E_application (f, arg) -> + * let%bind f' = rename_annotated_expression r f in + * let%bind arg' = rename_annotated_expression r arg in + * ok (E_application (f', arg')) + * | E_tuple lst -> + * let%bind lst' = bind_map_list (rename_annotated_expression r) lst in + * ok (E_tuple lst') + * | E_accessor (ae, p) -> + * let%bind ae' = rename_annotated_expression r ae in + * ok (E_accessor (ae', p)) + * | E_record sm -> + * let%bind sm' = bind_smap + * @@ SMap.map (rename_annotated_expression r) sm in + * ok (E_record sm') + * | E_map m -> + * let%bind m' = bind_map_list + * (fun (x, y) -> bind_map_pair (rename_annotated_expression r) (x, y)) m in + * ok (E_map m') + * | E_list lst -> + * let%bind lst' = bind_map_list (rename_annotated_expression r) lst in + * ok (E_list lst') + * | E_look_up m -> + * let%bind m' = bind_map_pair (rename_annotated_expression r) m in + * ok (E_look_up m') + * | E_matching (ae, m) -> + * let%bind ae' = rename_annotated_expression r ae in + * let%bind m' = rename_matching rename_annotated_expression r m in + * ok (E_matching (ae', m')) + * end + * end *) diff --git a/src/ligo/ast_simplified/types.ml b/src/ligo/ast_simplified/types.ml new file mode 100644 index 000000000..ce5d83b29 --- /dev/null +++ b/src/ligo/ast_simplified/types.ml @@ -0,0 +1,113 @@ +type name = string +type type_name = string + +type 'a name_map = 'a Map.String.t +type 'a type_name_map = 'a Map.String.t + +type program = declaration Location.wrap list + +and declaration = + | Declaration_type of named_type_expression + | Declaration_constant of named_expression + (* | Macro_declaration of macro_declaration *) + +and annotated_expression = { + expression: expression ; + type_annotation: te option ; +} + +and named_expression = { + name: name ; + annotated_expression: ae ; +} + +and named_type_expression = { + type_name: type_name ; + type_expression: type_expression ; +} + +and te = type_expression +and ae = annotated_expression +and te_map = type_expression type_name_map +and ae_map = annotated_expression name_map + +and type_expression = + | T_tuple of te list + | T_sum of te_map + | T_record of te_map + | T_function of te * te + | T_variable of type_name + | T_constant of type_name * te list + +and lambda = { + binder: name ; + input_type: type_expression ; + output_type: type_expression ; + result: ae ; + body: block ; +} + +and expression = + (* Base *) + | E_literal of literal + | E_constant of (name * ae list) (* For language constants, like (Cons hd tl) or (plus i j) *) + | E_variable of name + | E_lambda of lambda + | E_application of (ae * ae) + (* E_Tuple *) + | E_tuple of ae list + (* Sum *) + | E_constructor of (name * ae) (* For user defined constructors *) + (* E_record *) + | E_record of ae_map + | E_accessor of (ae * access_path) + (* Data Structures *) + | E_map of (ae * ae) list + | E_list of ae list + | E_look_up of (ae * ae) + (* Matching *) + | E_matching of (ae * matching_expr) + +and access = + | Access_tuple of int + | Access_record of string + +and access_path = access list + +and literal = + | Literal_unit + | Literal_bool of bool + | Literal_int of int + | Literal_nat of int + | Literal_string of string + | Literal_bytes of bytes + +and block = instruction list +and b = block + +and instruction = + | I_assignment of named_expression + | I_matching of ae * matching_instr + | I_loop of ae * b + | I_skip + | I_fail of ae + | I_record_patch of name * access_path * (string * ae) list + +and 'a matching = + | Match_bool of { + match_true : 'a ; + match_false : 'a ; + } + | Match_list of { + match_nil : 'a ; + match_cons : name * name * 'a ; + } + | Match_option of { + match_none : 'a ; + match_some : name * 'a ; + } + | Match_tuple of name list * 'a + +and matching_instr = b matching + +and matching_expr = annotated_expression matching diff --git a/src/ligo/simplify.ml b/src/ligo/simplify.ml index 0308c1446..a90b4a869 100644 --- a/src/ligo/simplify.ml +++ b/src/ligo/simplify.ml @@ -1,6 +1,10 @@ open Trace open Ast_simplified + module Raw = Ligo_parser.AST +module SMap = Map.String + +open Combinators let nseq_to_list (hd, tl) = hd :: tl let npseq_to_list (hd, tl) = hd :: (List.map snd tl) @@ -73,11 +77,11 @@ and simpl_list_type_expression (lst:Raw.type_expr list) : type_expression result ok @@ T_tuple lst let rec simpl_expression (t:Raw.expr) : ae result = - let return x = ok @@ ae x in + let return x = ok @@ make_e_a x in let simpl_projection = fun (p:Raw.projection) -> let var = let name = p.struct_name.value in - ae @@ E_variable name in + make_e_a @@ E_variable name in let path = p.field_path in let path' = let aux (s:Raw.selection) = @@ -86,13 +90,13 @@ let rec simpl_expression (t:Raw.expr) : ae result = | Component index -> Access_tuple (Z.to_int (snd index.value)) in List.map aux @@ npseq_to_list path in - ok @@ ae @@ E_accessor (var, path') + ok @@ make_e_a @@ E_accessor (var, path') in match t with | EVar c -> if c.value = "unit" - then ok @@ ae @@ E_literal Literal_unit - else ok @@ ae @@ E_variable c.value + then ok @@ make_e_a @@ E_literal Literal_unit + else ok @@ make_e_a @@ E_variable c.value | ECall x -> ( let (name, args) = x.value in let f = name.value in @@ -100,17 +104,17 @@ let rec simpl_expression (t:Raw.expr) : ae result = match List.assoc_opt f constants with | None -> let%bind arg = simpl_tuple_expression args' in - ok @@ ae @@ E_application (ae @@ E_variable f, arg) + ok @@ make_e_a @@ E_application (make_e_a @@ E_variable f, arg) | Some arity -> let%bind _arity = trace (simple_error "wrong arity for constants") @@ Assert.assert_equal_int arity (List.length args') in let%bind lst = bind_map_list simpl_expression args' in - ok @@ ae @@ E_constant (f, lst) + ok @@ make_e_a @@ E_constant (f, lst) ) | EPar x -> simpl_expression x.value.inside - | EUnit _ -> ok @@ ae @@ E_literal Literal_unit - | EBytes x -> ok @@ ae @@ E_literal (Literal_bytes (Bytes.of_string @@ fst x.value)) + | EUnit _ -> ok @@ make_e_a @@ E_literal Literal_unit + | EBytes x -> ok @@ make_e_a @@ E_literal (Literal_bytes (Bytes.of_string @@ fst x.value)) | ETuple tpl -> let (Raw.TupleInj tpl') = tpl in simpl_tuple_expression @@ -121,7 +125,7 @@ let rec simpl_expression (t:Raw.expr) : ae result = @@ List.map (fun (x:Raw.field_assign Raw.reg) -> (x.value.field_name, x.value.field_expr)) @@ npseq_to_list r.value.fields in let aux prev (k, v) = SMap.add k v prev in - ok @@ ae @@ E_record (List.fold_left aux SMap.empty fields) + ok @@ make_e_a @@ E_record (List.fold_left aux SMap.empty fields) | EProj p' -> ( let p = p'.value in simpl_projection p @@ -131,17 +135,17 @@ let rec simpl_expression (t:Raw.expr) : ae result = let%bind arg = simpl_tuple_expression @@ npseq_to_list args.value.inside in - ok @@ ae @@ E_constructor (c.value, arg) + ok @@ make_e_a @@ E_constructor (c.value, arg) | EConstr (SomeApp a) -> let (_, args) = a.value in let%bind arg = simpl_tuple_expression @@ npseq_to_list args.value.inside in - ok @@ ae @@ E_constant ("SOME", [arg]) + ok @@ make_e_a @@ E_constant ("SOME", [arg]) | EConstr (NoneExpr n) -> let type_expr = n.value.inside.opt_type in let%bind type_expr' = simpl_type_expression type_expr in - ok @@ annotated_expression (E_constant ("NONE", [])) (Some (Combinators.t_option type_expr')) + ok @@ make_e_a_full (E_constant ("NONE", [])) (Combinators.t_option type_expr') | EArith (Add c) -> simpl_binop "ADD" c.value | EArith (Sub c) -> @@ -150,13 +154,13 @@ let rec simpl_expression (t:Raw.expr) : ae result = simpl_binop "TIMES" c.value | EArith (Int n) -> let n = Z.to_int @@ snd @@ n.value in - ok @@ ae @@ E_literal (Literal_int n) + ok @@ make_e_a @@ E_literal (Literal_int n) | EArith (Nat n) -> let n = Z.to_int @@ snd @@ n.value in - ok @@ ae @@ E_literal (Literal_nat n) + ok @@ make_e_a @@ E_literal (Literal_nat n) | EArith _ -> simple_fail "arith: not supported yet" | EString (String s) -> - ok @@ ae @@ E_literal (Literal_string s.value) + ok @@ make_e_a @@ E_literal (Literal_string s.value) | EString _ -> simple_fail "string: not supported yet" | ELogic l -> simpl_logic_expression l | EList l -> simpl_list_expression l @@ -172,11 +176,11 @@ let rec simpl_expression (t:Raw.expr) : ae result = @@ List.map get_value @@ npseq_to_list c.value.cases.value in let%bind cases = simpl_cases lst in - ok @@ ae @@ E_matching (e, cases) + ok @@ make_e_a @@ E_matching (e, cases) | EMap (MapInj mi) -> let%bind lst = let lst = List.map get_value @@ pseq_to_list mi.value.elements in - let aux : Raw.binding -> (ae * ae) result = fun b -> + let aux : Raw.binding -> (annotated_expression * annotated_expression) result = fun b -> let%bind src = simpl_expression b.source in let%bind dst = simpl_expression b.image in ok (src, dst) in @@ -190,12 +194,12 @@ let rec simpl_expression (t:Raw.expr) : ae result = let%bind index = simpl_expression lu.value.index.value.inside in return (E_look_up (path, index)) -and simpl_logic_expression (t:Raw.logic_expr) : ae result = +and simpl_logic_expression (t:Raw.logic_expr) : annotated_expression result = match t with | BoolExpr (False _) -> - ok @@ ae @@ E_literal (Literal_bool false) + ok @@ make_e_a @@ E_literal (Literal_bool false) | BoolExpr (True _) -> - ok @@ ae @@ E_literal (Literal_bool true) + ok @@ make_e_a @@ E_literal (Literal_bool true) | BoolExpr (Or b) -> simpl_binop "OR" b.value | BoolExpr (And b) -> @@ -215,7 +219,7 @@ and simpl_logic_expression (t:Raw.logic_expr) : ae result = | CompExpr (Neq c) -> simpl_binop "NEQ" c.value -and simpl_list_expression (t:Raw.list_expr) : ae result = +and simpl_list_expression (t:Raw.list_expr) : annotated_expression result = match t with | Cons c -> simpl_binop "CONS" c.value @@ -223,29 +227,29 @@ and simpl_list_expression (t:Raw.list_expr) : ae result = let%bind lst' = bind_map_list simpl_expression @@ pseq_to_list lst.value.elements in - ok (ae (E_list lst')) + ok (make_e_a (E_list lst')) | Nil n -> let n' = n.value.inside in let%bind t' = simpl_type_expression n'.list_type in let e' = E_list [] in - ok (annotated_expression e' (Some (Combinators.t_list t'))) + ok (make_e_a_full e' (t_list t')) -and simpl_binop (name:string) (t:_ Raw.bin_op) : ae result = +and simpl_binop (name:string) (t:_ Raw.bin_op) : annotated_expression result = let%bind a = simpl_expression t.arg1 in let%bind b = simpl_expression t.arg2 in - ok @@ ae @@ E_constant (name, [a;b]) + ok @@ make_e_a @@ E_constant (name, [a;b]) -and simpl_unop (name:string) (t:_ Raw.un_op) : ae result = +and simpl_unop (name:string) (t:_ Raw.un_op) : annotated_expression result = let%bind a = simpl_expression t.arg in - ok @@ ae @@ E_constant (name, [a]) + ok @@ make_e_a @@ E_constant (name, [a]) -and simpl_tuple_expression (lst:Raw.expr list) : ae result = +and simpl_tuple_expression (lst:Raw.expr list) : annotated_expression result = match lst with - | [] -> ok @@ ae @@ E_literal Literal_unit + | [] -> ok @@ make_e_a @@ E_literal Literal_unit | [hd] -> simpl_expression hd | lst -> let%bind lst = bind_list @@ List.map simpl_expression lst in - ok @@ ae @@ E_tuple lst + ok @@ make_e_a @@ E_tuple lst and simpl_local_declaration (t:Raw.local_decl) : (instruction * named_expression) result = match t with @@ -430,8 +434,8 @@ and simpl_single_instruction : Raw.single_instr -> instruction result = fun t -> | Name name -> ok name | _ -> simple_fail "no complex map assignments yet" in let%bind key_expr = simpl_expression v'.index.value.inside in - let old_expr = ae @@ E_variable name.value in - let expr' = ae @@ E_constant ("MAP_UPDATE", [key_expr ; value_expr ; old_expr]) in + let old_expr = make_e_a @@ E_variable name.value in + let expr' = make_e_a @@ E_constant ("MAP_UPDATE", [key_expr ; value_expr ; old_expr]) in ok @@ I_assignment {name = name.value ; annotated_expression = expr'} ) ) @@ -471,8 +475,8 @@ and simpl_single_instruction : Raw.single_instr -> instruction result = fun t -> | Name v -> ok v.value | _ -> simple_fail "no complex map remove yet" in let%bind key' = simpl_expression key in - let expr = E_constant ("MAP_REMOVE", [key' ; ae (E_variable map)]) in - ok @@ I_assignment {name = map ; annotated_expression = ae expr} + let expr = E_constant ("MAP_REMOVE", [key' ; make_e_a (E_variable map)]) in + ok @@ I_assignment {name = map ; annotated_expression = make_e_a expr} | SetRemove _ -> simple_fail "no set remove yet" and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t -> diff --git a/src/ligo/simplify_multifix.ml b/src/ligo/simplify_multifix.ml index fc240a8f8..4442071a5 100644 --- a/src/ligo/simplify_multifix.ml +++ b/src/ligo/simplify_multifix.ml @@ -2,6 +2,7 @@ open Trace open Function module I = Multifix.Ast module O = Ast_simplified +open O.Combinators let unwrap : type a . a Location.wrap -> a = Location.unwrap @@ -81,10 +82,10 @@ and expression_record : _ -> O.annotated_expression result = fun r -> 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) + ok @@ O.(make_e_a @@ E_record e_map) and expression_main : I.expression_main -> O.annotated_expression result = fun em -> - let return x = ok O.(ae x) in + let return x = ok @@ make_e_a x in let simple_binop name ab = let%bind (a' , b') = bind_map_pair (bind_map_location expression_main) ab in return @@ E_constant (name, [unwrap a' ; unwrap b']) in @@ -102,7 +103,7 @@ and expression_main : I.expression_main -> O.annotated_expression result = fun e | None -> ok (unwrap e').expression | Some _ -> simple_fail "can't double annotate" in let%bind te' = bind_map_location restricted_type_expression te in - ok @@ O.annotated_expression e'' (Some (unwrap te')) + ok @@ make_e_a_full e'' (unwrap te') | Eh_lt ab -> simple_binop "LT" ab | Eh_gt ab -> @@ -173,7 +174,7 @@ let let_content : I.let_content -> _ result = fun (Let_content (n, args, ty_opt, 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 + let ae = make_e_a_full e'' (unwrap ty') in ok @@ O.Declaration_constant {name = (unwrap n) ; annotated_expression = ae} let statement : I.statement -> O.declaration result = fun s -> diff --git a/src/ligo/test/typer_tests.ml b/src/ligo/test/typer_tests.ml index 277e23c11..415e7ff6c 100644 --- a/src/ligo/test/typer_tests.ml +++ b/src/ligo/test/typer_tests.ml @@ -8,7 +8,7 @@ module Simplified = Ligo.AST_Simplified let int () : unit result = let open Combinators in - let pre = ae @@ e_int 32 in + let pre = make_e_a @@ e_int 32 in let open Typer in let e = Environment.full_empty in let%bind post = type_annotated_expression e pre in @@ -21,9 +21,9 @@ module TestExpressions = struct let test_expression ?(env = Typer.Environment.full_empty) (expr : expression) (test_expected_ty : Typed.tv) = + let pre = Combinators.make_e_a @@ expr in let open Typer in let open! Typed in - let pre = ae @@ expr in let%bind post = type_annotated_expression env pre in let%bind () = assert_type_value_eq (post.type_annotation, test_expected_ty) in ok () @@ -53,7 +53,7 @@ module TestExpressions = struct O.[("foo", t_int ()); ("bar", t_string ())] in test_expression ~env:(E.env_sum_type variant_foo_bar) - I.(e_constructor "foo" (ae @@ e_int 32)) + I.(e_constructor "foo" (make_e_a @@ e_int 32)) O.(make_t_ez_sum variant_foo_bar) let record () : unit result = diff --git a/src/ligo/typer.ml b/src/ligo/typer.ml index 6059aafe7..1206cf8c8 100644 --- a/src/ligo/typer.ml +++ b/src/ligo/typer.ml @@ -444,8 +444,8 @@ let untype_literal (l:O.literal) : I.literal result = let rec untype_annotated_expression (e:O.annotated_expression) : (I.annotated_expression) result = let open I in - let annotation = e.type_annotation.simplified in - let return e = ok @@ annotated_expression e annotation in + let type_annotation = e.type_annotation.simplified in + let return e = ok @@ I.Combinators.make_e_a ?type_annotation e in match e.expression with | E_literal l -> let%bind l = untype_literal l in From de6a3bbf6d84ef10d652038c1dedc6498eac8d9f Mon Sep 17 00:00:00 2001 From: Galfour Date: Sun, 21 Apr 2019 17:07:35 +0000 Subject: [PATCH 03/15] refactor more --- src/ligo/ast_simplified/PP.ml | 2 + src/ligo/ast_simplified/combinators.ml | 3 + src/ligo/ast_simplified/misc.ml | 108 +++++++++++++++++++ src/ligo/ast_simplified/types.ml | 2 + src/ligo/ligo.ml | 140 +++++++------------------ src/ligo/parser.ml | 99 +++++++++++++++++ src/ligo/test/integration_tests.ml | 32 ++---- 7 files changed, 261 insertions(+), 125 deletions(-) create mode 100644 src/ligo/parser.ml diff --git a/src/ligo/ast_simplified/PP.ml b/src/ligo/ast_simplified/PP.ml index f8fc9cc65..b6d7beb0a 100644 --- a/src/ligo/ast_simplified/PP.ml +++ b/src/ligo/ast_simplified/PP.ml @@ -59,6 +59,8 @@ and annotated_expression ppf (ae:annotated_expression) = match ae.type_annotatio | None -> fprintf ppf "%a" expression ae.expression | Some t -> fprintf ppf "(%a) : %a" expression ae.expression type_expression t +and value : _ -> value -> unit = fun x -> annotated_expression x + and block ppf (b:block) = (list_sep instruction (tag "@;")) ppf b and single_record_patch ppf ((p, ae) : string * ae) = diff --git a/src/ligo/ast_simplified/combinators.ml b/src/ligo/ast_simplified/combinators.ml index 9e53ab31a..b567c4afd 100644 --- a/src/ligo/ast_simplified/combinators.ml +++ b/src/ligo/ast_simplified/combinators.ml @@ -2,6 +2,7 @@ open Types module SMap = Map.String + let t_bool : type_expression = T_constant ("bool", []) let t_string : type_expression = T_constant ("string", []) let t_bytes : type_expression = T_constant ("bytes", []) @@ -43,6 +44,8 @@ let e_bool b : expression = E_literal (Literal_bool b) let e_string s : expression = E_literal (Literal_string s) let e_bytes b : expression = E_literal (Literal_bytes (Bytes.of_string b)) +let e_a_int n : annotated_expression = make_e_a_full (e_int n) t_int + let e_lambda (binder : string) (input_type : type_expression) (output_type : type_expression) diff --git a/src/ligo/ast_simplified/misc.ml b/src/ligo/ast_simplified/misc.ml index 48530be56..02788c082 100644 --- a/src/ligo/ast_simplified/misc.ml +++ b/src/ligo/ast_simplified/misc.ml @@ -1,3 +1,111 @@ +open Trace +open Types + +let assert_literal_eq (a, b : literal * literal) : unit result = + match (a, b) with + | Literal_bool a, Literal_bool b when a = b -> ok () + | Literal_bool _, Literal_bool _ -> simple_fail "different bools" + | Literal_bool _, _ -> simple_fail "bool vs non-bool" + | Literal_int a, Literal_int b when a = b -> ok () + | Literal_int _, Literal_int _ -> simple_fail "different ints" + | Literal_int _, _ -> simple_fail "int vs non-int" + | Literal_nat a, Literal_nat b when a = b -> ok () + | Literal_nat _, Literal_nat _ -> simple_fail "different nats" + | Literal_nat _, _ -> simple_fail "nat vs non-nat" + | Literal_string a, Literal_string b when a = b -> ok () + | Literal_string _, Literal_string _ -> simple_fail "different strings" + | Literal_string _, _ -> simple_fail "string vs non-string" + | Literal_bytes a, Literal_bytes b when a = b -> ok () + | Literal_bytes _, Literal_bytes _ -> simple_fail "different bytess" + | Literal_bytes _, _ -> simple_fail "bytes vs non-bytes" + | Literal_unit, Literal_unit -> ok () + | Literal_unit, _ -> simple_fail "unit vs non-unit" + +let rec assert_value_eq (a, b: (value*value)) : unit result = + let error_content () = + Format.asprintf "%a vs %a" PP.value a PP.value b + in + trace (fun () -> error (thunk "not equal") error_content ()) @@ + match (a.expression, b.expression) with + | E_literal a, E_literal b -> + assert_literal_eq (a, b) + | E_constant (ca, lsta), E_constant (cb, lstb) when ca = cb -> ( + let%bind lst = + generic_try (simple_error "constants with different number of elements") + (fun () -> List.combine lsta lstb) in + let%bind _all = bind_list @@ List.map assert_value_eq lst in + ok () + ) + | E_constant _, E_constant _ -> + simple_fail "different constants" + | E_constant _, _ -> + let error_content () = + Format.asprintf "%a vs %a" + PP.annotated_expression a + PP.annotated_expression b + in + fail @@ (fun () -> error (thunk "comparing constant with other stuff") error_content ()) + + | E_constructor (ca, a), E_constructor (cb, b) when ca = cb -> ( + let%bind _eq = assert_value_eq (a, b) in + ok () + ) + | E_constructor _, E_constructor _ -> + simple_fail "different constructors" + | E_constructor _, _ -> + simple_fail "comparing constructor with other stuff" + + | E_tuple lsta, E_tuple lstb -> ( + let%bind lst = + generic_try (simple_error "tuples with different number of elements") + (fun () -> List.combine lsta lstb) in + let%bind _all = bind_list @@ List.map assert_value_eq lst in + ok () + ) + | E_tuple _, _ -> + simple_fail "comparing tuple with other stuff" + + | E_record sma, E_record smb -> ( + let aux _ a b = + match a, b with + | Some a, Some b -> Some (assert_value_eq (a, b)) + | _ -> Some (simple_fail "different record keys") + in + let%bind _all = bind_smap @@ Map.String.merge aux sma smb in + ok () + ) + | E_record _, _ -> + simple_fail "comparing record with other stuff" + + | E_map lsta, E_map lstb -> ( + let%bind lst = generic_try (simple_error "maps of different lengths") + (fun () -> + let lsta' = List.sort compare lsta in + let lstb' = List.sort compare lstb in + List.combine lsta' lstb') in + let aux = fun ((ka, va), (kb, vb)) -> + let%bind _ = assert_value_eq (ka, kb) in + let%bind _ = assert_value_eq (va, vb) in + ok () in + let%bind _all = bind_map_list aux lst in + ok () + ) + | E_map _, _ -> + simple_fail "comparing map with other stuff" + + | E_list lsta, E_list lstb -> ( + let%bind lst = + generic_try (simple_error "list of different lengths") + (fun () -> List.combine lsta lstb) in + let%bind _all = bind_map_list assert_value_eq lst in + ok () + ) + | E_list _, _ -> + simple_fail "comparing list with other stuff" + + | _, _ -> simple_fail "comparing not a value" + + (* module Rename = struct * open Trace * diff --git a/src/ligo/ast_simplified/types.ml b/src/ligo/ast_simplified/types.ml index ce5d83b29..fc1472b06 100644 --- a/src/ligo/ast_simplified/types.ml +++ b/src/ligo/ast_simplified/types.ml @@ -11,6 +11,8 @@ and declaration = | Declaration_constant of named_expression (* | Macro_declaration of macro_declaration *) +and value = annotated_expression + and annotated_expression = { expression: expression ; type_annotation: te option ; diff --git a/src/ligo/ligo.ml b/src/ligo/ligo.ml index 5234ccc70..d2c0446b0 100644 --- a/src/ligo/ligo.ml +++ b/src/ligo/ligo.ml @@ -1,8 +1,6 @@ -open Ligo_parser - +open Trace module Parser = Parser -module Lexer = Lexer -module AST_Raw = AST +module AST_Raw = Ligo_parser.AST module AST_Simplified = Ast_simplified module AST_Typed = Ast_typed module Mini_c = Mini_c @@ -11,103 +9,6 @@ module Transpiler = Transpiler module Parser_multifix = Multifix module Simplify_multifix = Simplify_multifix -open Trace - -let parse_file (source: string) : AST_Raw.t result = - let pp_input = - let prefix = Filename.(source |> basename |> remove_extension) - and suffix = ".pp.ligo" - in prefix ^ suffix in - - let cpp_cmd = Printf.sprintf "cpp -traditional-cpp %s -o %s" - source pp_input in - let%bind () = sys_command cpp_cmd in - - let%bind channel = - generic_try (simple_error "error opening file") @@ - (fun () -> open_in pp_input) in - let lexbuf = Lexing.from_channel channel in - let module Lexer = Lexer.Make(LexToken) in - let Lexer.{read ; close} = - Lexer.open_token_stream None in - specific_try (fun () -> function - | Parser.Error -> ( - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - let str = Format.sprintf - "Parse error at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n" - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) - start.pos_fname source - in - simple_error str - ) - | _ -> - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - let str = Format.sprintf - "Unrecognized error at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n" - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) - start.pos_fname source - in - simple_error str - ) @@ (fun () -> - let raw = Parser.contract read lexbuf in - close () ; - raw - ) >>? fun raw -> - ok raw - -let parse (s:string) : AST_Raw.t result = - let lexbuf = Lexing.from_string s in - let module Lexer = Lexer.Make(LexToken) in - let Lexer.{read ; close} = - Lexer.open_token_stream None in - specific_try (fun () -> function - | Parser.Error -> ( - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - let str = Format.sprintf - "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n" - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in - simple_error str - ) - | _ -> simple_error "unrecognized parse_ error" - ) @@ (fun () -> - let raw = Parser.contract read lexbuf in - close () ; - raw - ) >>? fun raw -> - ok raw - -let parse_expression (s:string) : AST_Raw.expr result = - let lexbuf = Lexing.from_string s in - let module Lexer = Lexer.Make(LexToken) in - let Lexer.{read ; close} = - Lexer.open_token_stream None in - specific_try (fun () -> function - | Parser.Error -> ( - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - let str = Format.sprintf - "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n" - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in - simple_error str - ) - | _ -> simple_error "unrecognized parse_ error" - ) @@ (fun () -> - let raw = Parser.interactive_expr read lexbuf in - close () ; - raw - ) >>? fun raw -> - ok raw let simplify (p:AST_Raw.t) : Ast_simplified.program result = Simplify.simpl_program p let simplify_expr (e:AST_Raw.expr) : Ast_simplified.annotated_expression result = Simplify.simpl_expression e @@ -144,7 +45,7 @@ let compile : Mini_c.program -> string -> Compiler.Program.compiled_program resu let type_file ?(debug_simplify = false) ?(debug_typed = false) (path:string) : AST_Typed.program result = - let%bind raw = parse_file path in + let%bind raw = Parser.parse_file path in let%bind simpl = trace (simple_error "simplifying") @@ simplify raw in @@ -202,6 +103,37 @@ let easy_run_typed untranspile_value mini_c_result main_result_type in ok typed_result +let easy_run_typed_simplified + ?(debug_mini_c = false) (entry:string) + (program:AST_Typed.program) (input:Ast_simplified.annotated_expression) : AST_Typed.annotated_expression result = + let%bind mini_c_main = + trace (simple_error "transpile mini_c entry") @@ + transpile_entry program entry in + (if debug_mini_c then + Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main.content) + ) ; + + let%bind typed_value = type_expression input in + let%bind mini_c_value = transpile_value typed_value in + + let%bind mini_c_result = + let error = + let title () = "run Mini_c" in + let content () = + Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main.content + in + error title content in + trace error @@ + Run.Mini_c.run_entry mini_c_main mini_c_value in + let%bind typed_result = + let%bind main_result_type = + let%bind typed_main = Ast_typed.get_functional_entry program entry in + match (snd typed_main).type_value' with + | T_function (_, result) -> ok result + | _ -> simple_fail "main doesn't have fun type" in + untranspile_value mini_c_result main_result_type in + ok typed_result + let easy_run_main_typed ?(debug_mini_c = false) (program:AST_Typed.program) (input:AST_Typed.annotated_expression) : AST_Typed.annotated_expression result = @@ -210,7 +142,7 @@ let easy_run_main_typed let easy_run_main (path:string) (input:string) : AST_Typed.annotated_expression result = let%bind typed = type_file path in - let%bind raw_expr = parse_expression input in + let%bind raw_expr = Parser.parse_expression input in let%bind simpl_expr = simplify_expr raw_expr in let%bind typed_expr = type_expression simpl_expr in easy_run_main_typed typed typed_expr @@ -218,7 +150,7 @@ let easy_run_main (path:string) (input:string) : AST_Typed.annotated_expression let compile_file (source: string) (entry_point:string) : Micheline.Michelson.t result = let%bind raw = trace (simple_error "parsing") @@ - parse_file source in + Parser.parse_file source in let%bind simplified = trace (simple_error "simplifying") @@ simplify raw in diff --git a/src/ligo/parser.ml b/src/ligo/parser.ml new file mode 100644 index 000000000..05f8809c6 --- /dev/null +++ b/src/ligo/parser.ml @@ -0,0 +1,99 @@ +open Trace +open Ligo_parser +module AST_Raw = Ligo_parser.AST + +let parse_file (source: string) : AST_Raw.t result = + let pp_input = + let prefix = Filename.(source |> basename |> remove_extension) + and suffix = ".pp.ligo" + in prefix ^ suffix in + + let cpp_cmd = Printf.sprintf "cpp -traditional-cpp %s -o %s" + source pp_input in + let%bind () = sys_command cpp_cmd in + + let%bind channel = + generic_try (simple_error "error opening file") @@ + (fun () -> open_in pp_input) in + let lexbuf = Lexing.from_channel channel in + let module Lexer = Lexer.Make(LexToken) in + let Lexer.{read ; close} = + Lexer.open_token_stream None in + specific_try (fun () -> function + | Parser.Error -> ( + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + let str = Format.sprintf + "Parse error at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n" + (Lexing.lexeme lexbuf) + start.pos_lnum (start.pos_cnum - start.pos_bol) + end_.pos_lnum (end_.pos_cnum - end_.pos_bol) + start.pos_fname source + in + simple_error str + ) + | _ -> + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + let str = Format.sprintf + "Unrecognized error at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n" + (Lexing.lexeme lexbuf) + start.pos_lnum (start.pos_cnum - start.pos_bol) + end_.pos_lnum (end_.pos_cnum - end_.pos_bol) + start.pos_fname source + in + simple_error str + ) @@ (fun () -> + let raw = Parser.contract read lexbuf in + close () ; + raw + ) >>? fun raw -> + ok raw + +let parse_string (s:string) : AST_Raw.t result = + let lexbuf = Lexing.from_string s in + let module Lexer = Lexer.Make(LexToken) in + let Lexer.{read ; close} = + Lexer.open_token_stream None in + specific_try (fun () -> function + | Parser.Error -> ( + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + let str = Format.sprintf + "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n" + (Lexing.lexeme lexbuf) + start.pos_lnum (start.pos_cnum - start.pos_bol) + end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in + simple_error str + ) + | _ -> simple_error "unrecognized parse_ error" + ) @@ (fun () -> + let raw = Parser.contract read lexbuf in + close () ; + raw + ) >>? fun raw -> + ok raw + +let parse_expression (s:string) : AST_Raw.expr result = + let lexbuf = Lexing.from_string s in + let module Lexer = Lexer.Make(LexToken) in + let Lexer.{read ; close} = + Lexer.open_token_stream None in + specific_try (fun () -> function + | Parser.Error -> ( + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + let str = Format.sprintf + "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n" + (Lexing.lexeme lexbuf) + start.pos_lnum (start.pos_cnum - start.pos_bol) + end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in + simple_error str + ) + | _ -> simple_error "unrecognized parse_ error" + ) @@ (fun () -> + let raw = Parser.interactive_expr read lexbuf in + close () ; + raw + ) >>? fun raw -> + ok raw diff --git a/src/ligo/test/integration_tests.ml b/src/ligo/test/integration_tests.ml index 3916a2e9c..57f64f254 100644 --- a/src/ligo/test/integration_tests.ml +++ b/src/ligo/test/integration_tests.ml @@ -2,27 +2,18 @@ open Trace open Ligo open Test_helpers -let pass (source:string) : unit result = - let%bind raw = - trace (simple_error "parsing") @@ - parse_file source in - let%bind simplified = - trace (simple_error "simplifying") @@ - simplify raw in - let%bind typed = - trace (simple_error "typing") @@ - type_ simplified in - let%bind _mini_c = - trace (simple_error "transpiling") @@ - transpile typed in - ok () - -let basic () : unit result = - pass "./contracts/toto.ligo" - let function_ () : unit result = - let%bind _ = pass "./contracts/function.ligo" in - let%bind _ = easy_run_main "./contracts/function.ligo" "2" in + let%bind program = type_file "./contracts/function.ligo" in + let aux n = + let open Ast_simplified.Combinators in + let input = e_a_int n in + let%bind result = easy_run_typed_simplified "main" program input in + let expected = Ast_typed.Combinators.e_a_empty_int n in + Ast_typed.assert_value_eq (expected , result) + in + let%bind _ = bind_list + @@ List.map aux + @@ [0 ; 2 ; 42 ; 163 ; -1] in ok () let complex_function () : unit result = @@ -562,7 +553,6 @@ let counter_contract () : unit result = ok () let main = "Integration (End to End)", [ - test "basic" basic ; test "function" function_ ; test "complex function" complex_function ; test "closure" closure ; From 55bff7b530f0c289a4dbecd6aedd3b77f78789c7 Mon Sep 17 00:00:00 2001 From: Galfour Date: Mon, 22 Apr 2019 03:29:21 +0000 Subject: [PATCH 04/15] lift tests to ast_simplify --- src/lib_utils/function.ml | 4 + src/lib_utils/trace.ml | 2 + src/lib_utils/x_option.ml | 33 ++ src/ligo/ast_simplified/ast_simplified.ml | 3 + src/ligo/ast_simplified/combinators.ml | 62 ++- src/ligo/ligo.ml | 16 +- src/ligo/test/integration_tests.ml | 581 ++++++---------------- src/ligo/test/test_helpers.ml | 52 ++ 8 files changed, 324 insertions(+), 429 deletions(-) diff --git a/src/lib_utils/function.ml b/src/lib_utils/function.ml index d60c3b391..f567d55ee 100644 --- a/src/lib_utils/function.ml +++ b/src/lib_utils/function.ml @@ -1,2 +1,6 @@ let compose = fun f g x -> f (g x) let (>|) = compose + +let compose_2 = fun f g x y -> f (g x y) +let compose_3 = fun f g x y z -> f (g x y z) +let compose_4 = fun f g a b c d -> f (g a b c d) diff --git a/src/lib_utils/trace.ml b/src/lib_utils/trace.ml index c84e74af7..39197dead 100644 --- a/src/lib_utils/trace.ml +++ b/src/lib_utils/trace.ml @@ -159,6 +159,8 @@ 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_map_ne_list : _ -> 'a X_list.Ne.t -> 'b X_list.Ne.t result = fun f lst -> bind_ne_list (X_list.Ne.map f lst) +let bind_iter_list : (_ -> unit result) -> _ list -> unit result = fun f lst -> + bind_map_list f lst >>? fun _ -> ok () let bind_location (x:_ Location.wrap) = x.wrap_content >>? fun wrap_content -> diff --git a/src/lib_utils/x_option.ml b/src/lib_utils/x_option.ml index 2063463db..5aa636cba 100644 --- a/src/lib_utils/x_option.ml +++ b/src/lib_utils/x_option.ml @@ -4,3 +4,36 @@ let lr (a , b) = match (a , b) with | Some x , _ -> Some (`Left x) | None , Some x -> Some (`Right x) | _ -> None + +(* TODO: recursive terminal *) +let rec bind_list = fun lst -> + match lst with + | [] -> Some [] + | hd :: tl -> ( + match hd with + | None -> None + | Some hd' -> ( + match bind_list tl with + | None -> None + | Some tl' -> Some (hd' :: tl') + ) + ) + +let bind_pair = fun (a , b) -> + a >>= fun a' -> + b >>= fun b' -> + Some (a' , b') + +let bind_map_list = fun f lst -> bind_list (X_list.map f lst) + +let bind_map_pair = fun f (a , b) -> bind_pair (f a , f b) + +let bind_smap (s:_ X_map.String.t) = + let open X_map.String in + let aux k v prev = + prev >>= fun prev' -> + v >>= fun v' -> + Some (add k v' prev') in + fold aux s (Some empty) + +let bind_map_smap f smap = bind_smap (X_map.String.map f smap) diff --git a/src/ligo/ast_simplified/ast_simplified.ml b/src/ligo/ast_simplified/ast_simplified.ml index a49ce9e8b..d2d6aaef7 100644 --- a/src/ligo/ast_simplified/ast_simplified.ml +++ b/src/ligo/ast_simplified/ast_simplified.ml @@ -1,4 +1,7 @@ include Types +include Misc + module Types = Types +module Misc = Misc module PP = PP module Combinators = Combinators diff --git a/src/ligo/ast_simplified/combinators.ml b/src/ligo/ast_simplified/combinators.ml index b567c4afd..f1e5b458b 100644 --- a/src/ligo/ast_simplified/combinators.ml +++ b/src/ligo/ast_simplified/combinators.ml @@ -2,16 +2,18 @@ open Types module SMap = Map.String +let get_type_annotation (x:annotated_expression) = x.type_annotation let t_bool : type_expression = T_constant ("bool", []) let t_string : type_expression = T_constant ("string", []) let t_bytes : type_expression = T_constant ("bytes", []) let t_int : type_expression = T_constant ("int", []) +let t_nat : type_expression = T_constant ("nat", []) let t_unit : type_expression = T_constant ("unit", []) let t_option o : type_expression = T_constant ("option", [o]) let t_list t : type_expression = T_constant ("list", [t]) let t_tuple lst : type_expression = T_tuple lst -let t_pair a b = t_tuple [a ; b] +let t_pair (a , b) = t_tuple [a ; b] let t_record m : type_expression = (T_record m) let t_ez_record (lst:(string * type_expression) list) : type_expression = let aux prev (k, v) = SMap.add k v prev in @@ -29,22 +31,72 @@ let ez_t_sum (lst:(string * type_expression) list) : type_expression = T_sum map let t_function param result : type_expression = T_function (param, result) +let t_map key value = (T_constant ("map", [key ; value])) let make_e_a ?type_annotation expression = {expression ; type_annotation} let make_e_a_full expression type_annotation = make_e_a ~type_annotation expression -let name (s : string) : name = s +let make_name (s : string) : name = s let e_var (s : string) : expression = E_variable s -let e_unit () : expression = E_literal (Literal_unit) +let e_unit () : expression = E_literal (Literal_unit) let e_int n : expression = E_literal (Literal_int n) let e_nat n : expression = E_literal (Literal_nat n) let e_bool b : expression = E_literal (Literal_bool b) let e_string s : expression = E_literal (Literal_string s) let e_bytes b : expression = E_literal (Literal_bytes (Bytes.of_string b)) +let e_record map : expression = E_record map +let e_tuple lst : expression = E_tuple lst +let e_some s : expression = E_constant ("SOME", [s]) +let e_none : expression = E_constant ("NONE", []) +let e_map lst : expression = E_map lst +let e_list lst : expression = E_list lst +let e_pair a b : expression = E_tuple [a; b] let e_a_int n : annotated_expression = make_e_a_full (e_int n) t_int +let e_a_nat n : annotated_expression = make_e_a_full (e_nat n) t_nat +let e_a_bool b : annotated_expression = make_e_a_full (e_bool b) t_bool +let e_a_unit : annotated_expression = make_e_a_full (e_unit ()) t_unit + +let e_a_record r = + let type_annotation = Option.( + map ~f:t_record (bind_map_smap get_type_annotation r) + ) in + make_e_a ?type_annotation (e_record r) + +let ez_e_a_record lst = + let aux prev (k, v) = SMap.add k v prev in + let map = List.fold_left aux SMap.empty lst in + e_a_record map + +let e_a_tuple lst = + let type_annotation = Option.( + map ~f:t_tuple (bind_map_list get_type_annotation lst) + ) in + make_e_a ?type_annotation (e_tuple lst) + +let e_a_pair a b = + let type_annotation = Option.( + map ~f:t_pair + @@ bind_map_pair get_type_annotation (a , b) + ) in + make_e_a ?type_annotation (e_pair a b) + +let e_a_some opt = + let type_annotation = Option.( + map ~f:t_option (get_type_annotation opt) + ) in + make_e_a ?type_annotation (e_some opt) + +let e_a_none t_opt = + let type_annotation = t_option t_opt in + make_e_a ~type_annotation e_none + +let e_a_list lst t = + make_e_a ~type_annotation:(t_list t) (e_list lst) + +let e_a_map lst k v = make_e_a ~type_annotation:(t_map k v) (e_map lst) let e_lambda (binder : string) (input_type : type_expression) @@ -53,7 +105,7 @@ let e_lambda (binder : string) (body : block) : expression = E_lambda { - binder = (name binder) ; + binder = (make_name binder) ; input_type = input_type ; output_type = output_type ; result = (make_e_a result) ; @@ -64,7 +116,7 @@ let e_tuple (lst : ae list) : expression = E_tuple lst let ez_e_tuple (lst : expression list) : expression = e_tuple (List.map make_e_a lst) -let e_constructor (s : string) (e : ae) : expression = E_constructor (name s, e) +let e_constructor (s : string) (e : ae) : expression = E_constructor (make_name s, e) let e_record (lst : (string * ae) list) : expression = let aux prev (k, v) = SMap.add k v prev in diff --git a/src/ligo/ligo.ml b/src/ligo/ligo.ml index d2c0446b0..6ad06f831 100644 --- a/src/ligo/ligo.ml +++ b/src/ligo/ligo.ml @@ -71,6 +71,17 @@ let easy_evaluate_typed (entry:string) (program:AST_Typed.program) : AST_Typed.a untranspile_value result typed_main.type_annotation in ok typed_result +let easy_evaluate_typed_simplified (entry:string) (program:AST_Typed.program) : Ast_simplified.annotated_expression result = + let%bind result = + let%bind mini_c_main = + transpile_entry program entry in + Run.Mini_c.run_entry mini_c_main (Mini_c.Combinators.d_unit) in + let%bind typed_result = + let%bind typed_main = Ast_typed.get_entry program entry in + untranspile_value result typed_main.type_annotation in + let%bind annotated_result = untype_expression typed_result in + ok annotated_result + let easy_evaluate_typed = trace_f_2_ez easy_evaluate_typed (thunk "easy evaluate typed") let easy_run_typed @@ -105,7 +116,7 @@ let easy_run_typed let easy_run_typed_simplified ?(debug_mini_c = false) (entry:string) - (program:AST_Typed.program) (input:Ast_simplified.annotated_expression) : AST_Typed.annotated_expression result = + (program:AST_Typed.program) (input:Ast_simplified.annotated_expression) : Ast_simplified.annotated_expression result = let%bind mini_c_main = trace (simple_error "transpile mini_c entry") @@ transpile_entry program entry in @@ -132,7 +143,8 @@ let easy_run_typed_simplified | T_function (_, result) -> ok result | _ -> simple_fail "main doesn't have fun type" in untranspile_value mini_c_result main_result_type in - ok typed_result + let%bind annotated_result = untype_expression typed_result in + ok annotated_result let easy_run_main_typed ?(debug_mini_c = false) diff --git a/src/ligo/test/integration_tests.ml b/src/ligo/test/integration_tests.ml index 57f64f254..de0267db6 100644 --- a/src/ligo/test/integration_tests.ml +++ b/src/ligo/test/integration_tests.ml @@ -2,148 +2,61 @@ open Trace open Ligo open Test_helpers +open Ast_simplified.Combinators + let function_ () : unit result = let%bind program = type_file "./contracts/function.ligo" in - let aux n = - let open Ast_simplified.Combinators in - let input = e_a_int n in - let%bind result = easy_run_typed_simplified "main" program input in - let expected = Ast_typed.Combinators.e_a_empty_int n in - Ast_typed.assert_value_eq (expected , result) - in - let%bind _ = bind_list - @@ List.map aux - @@ [0 ; 2 ; 42 ; 163 ; -1] in - ok () + let make_expect = fun n -> n in + expect_n_int program "main" make_expect let complex_function () : unit result = let%bind program = type_file "./contracts/function-complex.ligo" in - let aux n = - let open AST_Typed.Combinators in - let input = e_a_empty_int n in - let%bind result = easy_run_main_typed program input in - let%bind result' = - trace (simple_error "bad result") @@ - get_a_int result in - Assert.assert_equal_int (3 * n + 2) result' - in - let%bind _ = bind_list - @@ List.map aux - @@ [0 ; 2 ; 42 ; 163 ; -1] in - ok () + let make_expect = fun n -> (3 * n + 2) in + expect_n_int program "main" make_expect let closure () : unit result = let%bind program = type_file "./contracts/closure.ligo" in - let%bind _foo = trace (simple_error "test foo") @@ - let aux n = - let open AST_Typed.Combinators in - let input = e_a_empty_int n in - let%bind result = easy_run_typed "foo" program input in - let expected = e_a_empty_int ( 2 * n ) in - AST_Typed.assert_value_eq (expected, result) - in - bind_list - @@ List.map aux - @@ [0 ; 2 ; 42 ; 163 ; -1] in - let%bind _toto = trace (simple_error "toto") @@ - let aux n = - let open AST_Typed.Combinators in - let input = e_a_empty_int n in - let%bind result = easy_run_typed "toto" program input in - let expected = e_a_empty_int ( 4 * n ) in - AST_Typed.assert_value_eq (expected, result) - in - bind_list - @@ List.map aux - @@ [0 ; 2 ; 42 ; 163 ; -1] in + let%bind () = + let make_expect = fun n -> (2 * n) in + expect_n_int program "foo" make_expect + in + let%bind _ = + let make_expect = fun n -> (4 * n) in + expect_n_int program "toto" make_expect + in ok () let shadow () : unit result = let%bind program = type_file "./contracts/shadow.ligo" in - let%bind _foo = trace (simple_error "test foo") @@ - let aux n = - let open AST_Typed.Combinators in - let input = e_a_empty_int n in - let%bind result = easy_run_typed "foo" program input in - let expected = e_a_empty_int 0 in - AST_Typed.assert_value_eq (expected, result) - in - bind_list - @@ List.map aux - @@ [3 ; 2 ; 0 ; 42 ; 163 ; -1] in - ok () + let make_expect = fun _ -> 0 in + expect_n_int program "foo" make_expect let higher_order () : unit result = let%bind program = type_file "./contracts/high-order.ligo" in - let%bind _foo = trace (simple_error "test foo") @@ - let aux n = - let open AST_Typed.Combinators in - let input = e_a_empty_int n in - let%bind result = easy_run_typed "foobar" program input in - let expected = e_a_empty_int ( n ) in - AST_Typed.assert_value_eq (expected, result) - in - bind_list - @@ List.map aux - @@ [0 ; 2 ; 42 ; 163 ; -1] in - ok () + let make_expect = fun n -> n in + expect_n_int program "foobar" make_expect let shared_function () : unit result = let%bind program = type_file "./contracts/function-shared.ligo" in - let%bind _inc = trace (simple_error "test inc") @@ - let aux n = - let open AST_Typed.Combinators in - let input = e_a_empty_int n in - let%bind result = easy_run_typed "inc" program input in - let expected = e_a_empty_int ( n + 1 ) in - AST_Typed.assert_value_eq (expected, result) - in - bind_list - @@ List.map aux - @@ [0 ; 2 ; 42 ; 163 ; -1] in - let%bind _double_inc = trace (simple_error "test double_inc") @@ - let aux n = - let open AST_Typed.Combinators in - let input = e_a_empty_int n in - let%bind result = easy_run_typed "double_inc" program input in - let expected = e_a_empty_int ( n + 2 ) in - AST_Typed.assert_value_eq (expected, result) - in - bind_list - @@ List.map aux - @@ [0 ; 2 ; 42 ; 163 ; -1] in - let%bind _foo = trace (simple_error "test foo") @@ - let aux n = - let open AST_Typed.Combinators in - let input = e_a_empty_int n in - let%bind result = easy_run_typed "foo" program input in - let expected = e_a_empty_int ( 2 * n + 3 ) in - AST_Typed.assert_value_eq (expected, result) - in - bind_list - @@ List.map aux - @@ [0 ; 2 ; 42 ; 163 ; -1] in + let%bind () = + let make_expect = fun n -> (n + 1) in + expect_n_int program "inc" make_expect + in + let%bind () = + let make_expect = fun n -> (n + 2) in + expect_n_int program "double_inc" make_expect + in + let%bind () = + let make_expect = fun n -> (2 * n + 3) in + expect_n_int program "foo" make_expect + in ok () let bool_expression () : unit result = let%bind program = type_file "./contracts/boolean_operators.ligo" in - let aux (name, f) = - let aux b = - let open AST_Typed.Combinators in - let input = e_a_empty_bool b in - let%bind result = easy_run_typed name program input in - let%bind result' = - trace (simple_error "bad result") @@ - get_a_bool result in - Assert.assert_equal_bool (f b) result' - in - let%bind _ = bind_list - @@ List.map aux [true;false] in - ok () - in - let%bind _ = bind_list - @@ List.map aux - @@ [ + let%bind _ = + let aux (name , f) = expect_b_bool program name f in + bind_map_list aux [ ("or_true", fun b -> b || true) ; ("or_false", fun b -> b || false) ; ("and_true", fun b -> b && true) ; @@ -153,64 +66,32 @@ let bool_expression () : unit result = let arithmetic () : unit result = let%bind program = type_file "./contracts/arithmetic.ligo" in - let aux (name, f) = - let aux n = - let open AST_Typed.Combinators in - let input = if name = "int_op" then e_a_empty_nat n else e_a_empty_int n in - let%bind result = easy_run_typed name program input in - AST_Typed.assert_value_eq (f n, result) - in - let%bind _ = bind_list - @@ List.map aux [0 ; 42 ; 128] in - ok () - in let%bind _ = - let open AST_Typed.Combinators in - bind_list - @@ List.map aux - @@ [ - ("plus_op", fun n -> e_a_empty_int (n + 42)) ; - ("minus_op", fun n -> e_a_empty_int (n - 42)) ; - ("times_op", fun n -> e_a_empty_int (n * 42)) ; - ("int_op", fun n -> e_a_empty_int n) ; + let aux (name , f) = expect_n_int program name f in + bind_map_list aux [ + ("plus_op", fun n -> (n + 42)) ; + ("minus_op", fun n -> (n - 42)) ; + ("times_op", fun n -> (n * 42)) ; ] in + let%bind () = expect_n_pos program "int_op" e_a_nat e_a_int in ok () let unit_expression () : unit result = let%bind program = type_file "./contracts/unit.ligo" in - let open AST_Typed.Combinators in - let%bind result = easy_evaluate_typed "u" program in - let%bind () = - trace (simple_error "result isn't unit") @@ - get_a_unit result in - ok () + expect_evaluate program "u" e_a_unit let include_ () : unit result = let%bind program = type_file "./contracts/includer.ligo" in - let%bind result = easy_evaluate_typed "bar" program in - let%bind n = - trace (simple_error "Include failed") @@ - AST_Typed.Combinators.get_a_int result in - Assert.assert_equal_int 144 n + expect_evaluate program "bar" (e_a_int 144) let record_ez_int names n = - let open AST_Typed.Combinators in - ez_e_a_empty_record @@ List.map (fun x -> x, e_a_empty_int n) names + ez_e_a_record @@ List.map (fun x -> x, e_a_int n) names let multiple_parameters () : unit result = let%bind program = type_file "./contracts/multiple-parameters.ligo" in - let inputs = [0 ; 2 ; 42 ; 163 ; -1] in - let aux (name, input_f, output_f) = - let aux n = - let input = input_f n in - let%bind result = easy_run_typed name program input in - let%bind result' = AST_Typed.Combinators.get_a_int result in - let expected = output_f n in - let%bind _ = Assert.assert_equal_int expected result' in - ok () - in - let%bind _ = bind_list @@ List.map aux inputs in - ok () + let aux ((name : string) , make_input , make_output) = + let make_output' = fun n -> e_a_int @@ make_output n in + expect_n program name make_input make_output' in let%bind _ = bind_list @@ List.map aux [ ("ab", record_ez_int ["a";"b"], fun n -> 2 * n) ; @@ -221,336 +102,192 @@ let multiple_parameters () : unit result = let record () : unit result = let%bind program = type_file "./contracts/record.ligo" in - let%bind _foobar = - let%bind result = easy_evaluate_typed "fb" program in - let expect = record_ez_int ["foo";"bar"] 0 in - AST_Typed.assert_value_eq (expect, result) + let%bind () = + let expected = record_ez_int ["foo" ; "bar"] 0 in + expect_evaluate program "fb" expected in - let%bind _projection = - let aux n = - let input = record_ez_int ["foo";"bar"] n in - let%bind result = easy_run_typed "projection" program input in - let expect = AST_Typed.Combinators.e_a_empty_int (2 * n) in - AST_Typed.assert_value_eq (expect, result) - in - bind_list @@ List.map aux [0 ; -42 ; 144] + let%bind () = + let make_input = record_ez_int ["foo" ; "bar"] in + let make_expected = fun n -> e_a_int (2 * n) in + expect_n program "projection" make_input make_expected in - let%bind _big = - let%bind result = easy_evaluate_typed "br" program in - let expect = record_ez_int ["a";"b";"c";"d";"e"] 23 in - AST_Typed.assert_value_eq (expect, result) + let%bind () = + let expected = record_ez_int ["a";"b";"c";"d";"e"] 23 in + expect_evaluate program "br" expected in ok () let tuple () : unit result = let%bind program = type_file "./contracts/tuple.ligo" in let ez n = - let open AST_Typed.Combinators in - e_a_empty_tuple (List.map e_a_empty_int n) in - let%bind _foobar = - trace (simple_error "foobar") ( - let%bind result = easy_evaluate_typed "fb" program in - let expect = ez [0 ; 0] in - AST_Typed.assert_value_eq (expect, result) - ) + e_a_tuple (List.map e_a_int n) in + let%bind () = + let expected = ez [0 ; 0] in + expect_evaluate program "fb" expected in - let%bind _projection = trace (simple_error "projection") ( - let aux n = - let input = ez [n ; n] in - let%bind result = easy_run_typed "projection" program input in - let expect = AST_Typed.Combinators.e_a_empty_int (2 * n) in - AST_Typed.assert_value_eq (expect, result) - in - bind_list @@ List.map aux [0 ; -42 ; 144] - ) + let%bind () = + let make_input = fun n -> ez [n ; n] in + let make_expected = fun n -> e_a_int (2 * n) in + expect_n program "projection" make_input make_expected in - let%bind _big = - let%bind result = easy_evaluate_typed "br" program in - let expect = ez [23 ; 23 ; 23 ; 23 ; 23] in - AST_Typed.assert_value_eq (expect, result) + let%bind () = + let expected = ez [23 ; 23 ; 23 ; 23 ; 23] in + expect_evaluate program "br" expected in ok () let option () : unit result = let%bind program = type_file "./contracts/option.ligo" in - let open AST_Typed.Combinators in - let%bind _some = trace (simple_error "some") @@ - let%bind result = easy_evaluate_typed "s" program in - let expect = e_a_empty_some (e_a_empty_int 42) in - AST_Typed.assert_value_eq (expect, result) + let%bind () = + let expected = e_a_some (e_a_int 42) in + expect_evaluate program "s" expected in - let%bind _none = trace (simple_error "none") @@ - let%bind result = easy_evaluate_typed "n" program in - let expect = e_a_empty_none (t_int ()) in - AST_Typed.assert_value_eq (expect, result) + let%bind () = + let expected = e_a_none t_int in + expect_evaluate program "n" expected in ok () let map () : unit result = let%bind program = type_file "./contracts/map.ligo" in let ez lst = - let open AST_Typed.Combinators in - let lst' = List.map (fun (x, y) -> e_a_empty_int x, e_a_empty_int y) lst in - e_a_empty_map lst' (t_int ()) (t_int ()) + let open Ast_simplified.Combinators in + let lst' = List.map (fun (x, y) -> e_a_int x, e_a_int y) lst in + e_a_map lst' t_int t_int in - let%bind _get_force = trace (simple_error "get_force") @@ - let aux n = - let input = ez [(23, n) ; (42, 4)] in - let%bind result = easy_run_typed "gf" program input in - let expect = AST_Typed.Combinators.(e_a_empty_int n) in - AST_Typed.assert_value_eq (expect, result) + let%bind () = + let make_input = fun n -> ez [(23, n) ; (42, 4)] in + let make_expected = e_a_int in + expect_n program "gf" make_input make_expected + in + let%bind () = + let make_input = fun n -> ez List.(map (fun x -> (x, x)) @@ range n) in + let make_expected = e_a_nat in + expect_n_strict_pos_small program "size_" make_input make_expected + in + let%bind () = + let expected = ez [(23, 0) ; (42, 0)] in + expect_evaluate program "fb" expected + in + let%bind () = + let make_input = fun n -> + let m = ez [(23 , 0) ; (42 , 0)] in + e_a_tuple [(e_a_int n) ; m] in - bind_map_list aux [0 ; 42 ; 51 ; 421 ; -3] + let make_expected = fun n -> ez [(23 , n) ; (42 , 0)] in + expect_n_pos_small program "set_" make_input make_expected in - let%bind _size = trace (simple_error "size") @@ - let aux n = - let input = ez List.(map (fun x -> (x, x)) @@ range n) in - let%bind result = easy_run_typed "size_" program input in - let expect = AST_Typed.Combinators.(e_a_empty_nat n) in - AST_Typed.assert_value_eq (expect, result) - in - bind_map_list aux [1 ; 10 ; 3] + let%bind () = + let make_input = fun n -> ez [(23, n) ; (42, 4)] in + let make_expected = fun _ -> e_a_some @@ e_a_int 4 in + expect_n program "get" make_input make_expected in - let%bind _foobar = trace (simple_error "foobar") @@ - let%bind result = easy_evaluate_typed "fb" program in - let expect = ez [(23, 0) ; (42, 0)] in - AST_Typed.assert_value_eq (expect, result) + let%bind () = + let expected = ez @@ List.map (fun x -> (x, 23)) [144 ; 51 ; 42 ; 120 ; 421] in + expect_evaluate program "bm" expected in - let%bind _set = trace (simple_error "set") @@ - let aux n = - let input = - let m = ez [(23, 0) ; (42, 0)] in - AST_Typed.Combinators.(e_a_empty_tuple [ e_a_empty_int n ; m ]) - in - let%bind result = easy_run_typed "set_" program input in - let expect = ez [(23, n) ; (42, 0)] in - AST_Typed.assert_value_eq (expect, result) - in - bind_map_list aux [1 ; 10 ; 3] - in - let%bind _get = trace (simple_error "get") @@ - let aux n = - let input = ez [(23, n) ; (42, 4)] in - let%bind result = easy_run_typed "get" program input in - let expect = AST_Typed.Combinators.(e_a_empty_some @@ e_a_empty_int 4) in - AST_Typed.assert_value_eq (expect, result) - in - bind_map_list aux [0 ; 42 ; 51 ; 421 ; -3] - in - let%bind _bigmap = trace (simple_error "bigmap") @@ - let%bind result = easy_evaluate_typed "bm" program in - let expect = ez @@ List.map (fun x -> (x, 23)) [144 ; 51 ; 42 ; 120 ; 421] in - AST_Typed.assert_value_eq (expect, result) - in - let%bind _remove = trace (simple_error "rm") @@ + let%bind () = let input = ez [(23, 23) ; (42, 42)] in - let%bind result = easy_run_typed "rm" program input in - let expect = ez [23, 23] in - AST_Typed.assert_value_eq (expect, result) + let expected = ez [23, 23] in + expect program "rm" input expected in ok () let list () : unit result = let%bind program = type_file "./contracts/list.ligo" in let ez lst = - let open AST_Typed.Combinators in - let lst' = List.map e_a_empty_int lst in - e_a_empty_list lst' (t_int ()) + let lst' = List.map e_a_int lst in + e_a_list lst' t_int in - let%bind _size = trace (simple_error "size") @@ - let aux n = - let input = ez (List.range n) in - let%bind result = easy_run_typed "size_" program input in - let expect = AST_Typed.Combinators.(e_a_empty_nat n) in - AST_Typed.assert_value_eq (expect, result) - in - bind_map_list aux [1 ; 10 ; 3] + let%bind () = + let make_input = fun n -> (ez @@ List.range n) in + let make_expected = e_a_nat in + expect_n_strict_pos_small program "size_" make_input make_expected in - let%bind _foobar = trace (simple_error "foobar") @@ - let%bind result = easy_evaluate_typed "fb" program in - let expect = ez [23 ; 42] in - AST_Typed.assert_value_eq (expect, result) + let%bind () = + let expected = ez [23 ; 42] in + expect_evaluate program "fb" expected in - let%bind _biglist = trace (simple_error "biglist") @@ - let%bind result = easy_evaluate_typed "bl" program in - let expect = ez [144 ; 51 ; 42 ; 120 ; 421] in - AST_Typed.assert_value_eq (expect, result) + let%bind () = + let expected = ez [144 ; 51 ; 42 ; 120 ; 421] in + expect_evaluate program "bl" expected in ok () let condition () : unit result = let%bind program = type_file "./contracts/condition.ligo" in - let aux n = - let open AST_Typed.Combinators in - let input = e_a_empty_int n in - let%bind result = easy_run_main_typed program input in - let%bind result' = - trace (simple_error "bad result") @@ - get_a_int result in - Assert.assert_equal_int (if n = 2 then 42 else 0) result' - in - let%bind _ = bind_list - @@ List.map aux - @@ [0 ; 2 ; 42 ; 163 ; -1] in - ok () + let make_input = e_a_int in + let make_expected = fun n -> e_a_int (if n = 2 then 42 else 0) in + expect_n program "main" make_input make_expected let loop () : unit result = let%bind program = type_file "./contracts/loop.ligo" in - let%bind _dummy = trace (simple_error "dummy") @@ - let aux n = - let open AST_Typed.Combinators in - let input = e_a_empty_nat n in - let%bind result = easy_run_typed "dummy" program input in - let expected = e_a_empty_nat n in - AST_Typed.assert_value_eq (expected, result) - in - let%bind _ = bind_list - @@ List.map aux - @@ [0 ; 2 ; 42 ; 163] in - ok () + let%bind () = + let make_input = e_a_nat in + let make_expected = e_a_nat in + expect_n_pos program "dummy" make_input make_expected in - let%bind _counter = trace (simple_error "counter") @@ - let aux n = - let open AST_Typed.Combinators in - let input = e_a_empty_nat n in - let%bind result = easy_run_typed "counter" program input in - let expected = e_a_empty_nat n in - AST_Typed.assert_value_eq (expected, result) - in - let%bind _ = bind_list - @@ List.map aux - @@ [0 ; 2 ; 42 ; 12] in - ok () + let%bind () = + let make_input = e_a_nat in + let make_expected = e_a_nat in + expect_n_pos_mid program "counter" make_input make_expected in - let%bind _sum = trace (simple_error "sum") @@ - let aux n = - let open AST_Typed.Combinators in - let input = e_a_empty_nat n in - let%bind result = easy_run_typed "sum" program input in - let expected = e_a_empty_nat (n * (n + 1) / 2) in - AST_Typed.assert_value_eq (expected, result) - in - let%bind _ = bind_list - @@ List.map aux - @@ [0 ; 2 ; 42 ; 12] in - ok () + let%bind () = + let make_input = e_a_nat in + let make_expected = fun n -> e_a_nat (n * (n + 1) / 2) in + expect_n_pos_mid program "sum" make_input make_expected in ok() let matching () : unit result = let%bind program = type_file "./contracts/match.ligo" in - let%bind _bool = - let aux n = - let open AST_Typed.Combinators in - let input = e_a_empty_int n in - let%bind result = easy_run_typed "match_bool" program input in - let%bind result' = - trace (simple_error "bad result") @@ - get_a_int result in - Assert.assert_equal_int (if n = 2 then 42 else 0) result' - in - let%bind _ = bind_list - @@ List.map aux - @@ [0 ; 2 ; 42 ; 163 ; -1] in - ok () + let%bind () = + let make_input = e_a_int in + let make_expected = fun n -> e_a_int (if n = 2 then 42 else 0) in + expect_n program "match_bool" make_input make_expected in - let%bind _expr_bool = - let aux n = - let open AST_Typed.Combinators in - let input = e_a_empty_int n in - let%bind result = easy_run_typed "match_expr_bool" program input in - let%bind result' = - trace (simple_error "bad result") @@ - get_a_int result in - Assert.assert_equal_int (if n = 2 then 42 else 0) result' - in - let%bind _ = bind_list - @@ List.map aux - @@ [0 ; 2 ; 42 ; 163 ; -1] in - ok () + let%bind () = + let make_input = e_a_int in + let make_expected = fun n-> e_a_int (if n = 2 then 42 else 0) in + expect_n program "match_expr_bool" make_input make_expected in - let%bind _option = + let%bind () = let aux n = - let open AST_Typed.Combinators in let input = match n with - | Some s -> e_a_empty_some (e_a_empty_int s) - | None -> e_a_empty_none (t_int ()) in - let%bind result = easy_run_typed "match_option" program input in - let%bind result' = - trace (simple_error "bad result") @@ - get_a_int result in - Assert.assert_equal_int 23 result' - (* Assert.assert_equal_int (match n with None -> 23 | Some s -> s) result' *) + | Some s -> e_a_some (e_a_int s) + | None -> e_a_none t_int in + let expected = e_a_int 23 in + expect program "match_option" input expected in - let%bind _ = bind_list - @@ List.map aux - @@ [Some 0 ; Some 2 ; Some 42 ; Some 163 ; Some (-1) ; None] in - ok () + bind_iter_list aux + [Some 0 ; Some 2 ; Some 42 ; Some 163 ; Some (-1) ; None] in ok () let declarations () : unit result = let%bind program = type_file "./contracts/declarations.ligo" in - let aux n = - let open AST_Typed.Combinators in - let input = e_a_empty_int n in - let%bind result = easy_run_main_typed program input in - let%bind result' = - trace (simple_error "bad result") @@ - get_a_int result in - Assert.assert_equal_int (42 + n) result' - in - let%bind _ = bind_list - @@ List.map aux - @@ [0 ; 2 ; 42 ; 163 ; -1] in - ok () + let make_input = e_a_int in + let make_expected = fun n -> e_a_int (42 + n) in + expect_n program "main" make_input make_expected let quote_declaration () : unit result = let%bind program = type_file "./contracts/quote-declaration.ligo" in - let aux n = - let open AST_Typed.Combinators in - let input = e_a_empty_int n in - let%bind result = easy_run_main_typed program input in - let%bind result' = - trace (simple_error "bad result") @@ - get_a_int result in - Assert.assert_equal_int result' (42 + 2 * n) - in - let%bind _ = bind_list - @@ List.map aux - @@ [0 ; 2 ; 42 ; 163 ; -1] in - ok () + let make_input = e_a_int in + let make_expected = fun n -> e_a_int (42 + 2 * n) in + expect_n program "main" make_input make_expected let quote_declarations () : unit result = let%bind program = type_file "./contracts/quote-declarations.ligo" in - let aux n = - let open AST_Typed.Combinators in - let input = e_a_empty_int n in - let%bind result = easy_run_main_typed program input in - let%bind result' = - trace (simple_error "bad result") @@ - get_a_int result in - Assert.assert_equal_int result' (74 + 2 * n) - in - let%bind _ = bind_list - @@ List.map aux - @@ [0 ; 2 ; 42 ; 163 ; -1] in - ok () + let make_input = e_a_int in + let make_expected = fun n -> e_a_int (74 + 2 * n) in + expect_n program "main" make_input make_expected let counter_contract () : unit result = let%bind program = type_file "./contracts/counter.ligo" in - let aux n = - let open AST_Typed.Combinators in - let input = e_a_empty_pair (e_a_empty_int n) (e_a_empty_int 42) in - let%bind result = easy_run_main_typed program input in - let expected = e_a_empty_pair (e_a_empty_list [] (t_int ())) (e_a_empty_int (42 + n)) in - AST_Typed.assert_value_eq (result, expected) - in - let%bind _ = bind_list - @@ List.map aux - @@ [0 ; 2 ; 42 ; 163 ; -1] in - ok () + let make_input = fun n-> e_a_pair (e_a_int n) (e_a_int 42) in + let make_expected = fun n -> e_a_pair (e_a_list [] (t_int)) (e_a_int (42 + n)) in + expect_n program "main" make_input make_expected let main = "Integration (End to End)", [ test "function" function_ ; diff --git a/src/ligo/test/test_helpers.ml b/src/ligo/test/test_helpers.ml index e2aac4135..bb266e469 100644 --- a/src/ligo/test/test_helpers.ml +++ b/src/ligo/test/test_helpers.ml @@ -10,3 +10,55 @@ let test name f = | Errors errs -> Format.printf "Errors : {\n%a}\n%!" errors_pp (List.rev (List.rev_map (fun f -> f ()) errs)) ; raise Alcotest.Test_error + +open Ast_simplified.Combinators + +let expect program entry_point input expected = + let error = + let title () = "expect run" in + let content () = Format.asprintf "Entry_point: %s" entry_point in + error title content in + trace error @@ + let%bind result = Ligo.easy_run_typed_simplified entry_point program input in + Ast_simplified.assert_value_eq (expected , result) + +let expect_evaluate program entry_point expected = + let error = + let title () = "expect evaluate" in + let content () = Format.asprintf "Entry_point: %s" entry_point in + error title content in + trace error @@ + let%bind result = Ligo.easy_evaluate_typed_simplified entry_point program in + Ast_simplified.assert_value_eq (expected , result) + +let expect_n_aux lst program entry_point make_input make_expected = + let aux n = + let input = make_input n in + let expected = make_expected n in + expect program entry_point input expected + in + let%bind _ = bind_map_list aux lst in + ok () + +let expect_n = expect_n_aux [0 ; 2 ; 42 ; 163 ; -1] +let expect_n_pos = expect_n_aux [0 ; 2 ; 42 ; 163] +let expect_n_strict_pos = expect_n_aux [2 ; 42 ; 163] +let expect_n_pos_small = expect_n_aux [0 ; 2 ; 10] +let expect_n_strict_pos_small = expect_n_aux [2 ; 10] +let expect_n_pos_mid = expect_n_aux [0 ; 2 ; 10 ; 33] + +let expect_b program entry_point make_expected = + let aux b = + let input = e_a_bool b in + let expected = make_expected b in + expect program entry_point input expected + in + let%bind _ = bind_map_list aux [false ; true] in + ok () + +let expect_n_int a b c = + expect_n a b e_a_int (fun n -> e_a_int (c n)) + +let expect_b_bool a b c = + let open Ast_simplified.Combinators in + expect_b a b (fun bool -> e_a_bool (c bool)) From 0a83ea5227ad1dc80b8cff6f61c98b76b6c57354 Mon Sep 17 00:00:00 2001 From: Galfour Date: Mon, 22 Apr 2019 07:21:59 +0000 Subject: [PATCH 05/15] dune-capsulate --- src/ligo/ast_simplified/combinators.ml | 3 + src/ligo/dune | 9 +- src/ligo/ligo.ml | 179 +---------------- src/ligo/main/contract.ml | 16 ++ src/ligo/main/dune | 20 ++ src/ligo/main/main.ml | 180 ++++++++++++++++++ .../from_mini_c.ml => main/run_mini_c.ml} | 0 .../{multifix => parser/camligo}/.gitignore | 0 src/ligo/{multifix => parser/camligo}/dune | 4 +- .../{multifix => parser/camligo}/generator.ml | 0 .../{multifix => parser/camligo}/lex/dune | 0 .../camligo}/lex/generator.ml | 0 .../{multifix => parser/camligo}/location.ml | 0 .../camligo}/pre_parser.mly | 0 src/ligo/{multifix => parser/camligo}/user.ml | 0 src/ligo/parser/dune | 12 ++ src/ligo/{ => parser}/parser.ml | 9 +- .../pascaligo}/.Lexer.ml.tag | 0 .../pascaligo}/.LexerMain.tag | 0 .../pascaligo}/.Parser.mly.tag | 0 .../pascaligo}/.ParserMain.tag | 0 .../pascaligo}/.gitignore | 0 .../pascaligo}/.gitlab-ci.yml | 0 .../{ligo_parser => parser/pascaligo}/.links | 0 .../{ligo_parser => parser/pascaligo}/AST.ml | 0 .../{ligo_parser => parser/pascaligo}/AST.mli | 0 .../pascaligo}/Error.mli | 0 .../pascaligo}/EvalOpt.ml | 0 .../pascaligo}/EvalOpt.mli | 0 .../pascaligo}/FQueue.ml | 0 .../pascaligo}/FQueue.mli | 0 .../pascaligo}/LexToken.mli | 0 .../pascaligo}/LexToken.mll | 0 .../pascaligo}/Lexer.mli | 0 .../pascaligo}/Lexer.mll | 0 .../pascaligo}/LexerLog.ml | 0 .../pascaligo}/LexerLog.mli | 0 .../pascaligo}/LexerMain.ml | 0 .../pascaligo}/Markup.ml | 0 .../pascaligo}/Markup.mli | 0 .../pascaligo}/ParToken.mly | 0 .../pascaligo}/Parser.mly | 0 .../pascaligo}/ParserLog.ml | 0 .../pascaligo}/ParserLog.mli | 0 .../pascaligo}/ParserMain.ml | 0 .../pascaligo}/Tests/a.ligo | 0 .../pascaligo}/Tests/crowdfunding.ligo | 0 .../pascaligo}/Utils.ml | 0 .../pascaligo}/Utils.mli | 0 .../pascaligo}/check_dot_git_is_dir.sh | 0 .../{ligo_parser => parser/pascaligo}/dune | 4 +- .../pascaligo/pascaligo.ml} | 0 src/ligo/run/run.ml | 1 - .../camligo.ml} | 2 +- src/ligo/simplify/dune | 14 ++ .../{simplify.ml => simplify/pascaligo.ml} | 6 +- src/ligo/simplify/simplify.ml | 2 + src/ligo/test/compiler_tests.ml | 2 +- src/ligo/test/integration_tests.ml | 2 +- src/ligo/test/multifix_tests.ml | 6 +- src/ligo/{run => transpiler}/dune | 8 +- src/ligo/{ => transpiler}/transpiler.ml | 0 src/ligo/typer/dune | 14 ++ src/ligo/{ => typer}/typer.ml | 0 64 files changed, 287 insertions(+), 206 deletions(-) create mode 100644 src/ligo/main/contract.ml create mode 100644 src/ligo/main/dune create mode 100644 src/ligo/main/main.ml rename src/ligo/{run/from_mini_c.ml => main/run_mini_c.ml} (100%) rename src/ligo/{multifix => parser/camligo}/.gitignore (100%) rename src/ligo/{multifix => parser/camligo}/dune (94%) rename src/ligo/{multifix => parser/camligo}/generator.ml (100%) rename src/ligo/{multifix => parser/camligo}/lex/dune (100%) rename src/ligo/{multifix => parser/camligo}/lex/generator.ml (100%) rename src/ligo/{multifix => parser/camligo}/location.ml (100%) rename src/ligo/{multifix => parser/camligo}/pre_parser.mly (100%) rename src/ligo/{multifix => parser/camligo}/user.ml (100%) create mode 100644 src/ligo/parser/dune rename src/ligo/{ => parser}/parser.ml (96%) rename src/ligo/{ligo_parser => parser/pascaligo}/.Lexer.ml.tag (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/.LexerMain.tag (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/.Parser.mly.tag (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/.ParserMain.tag (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/.gitignore (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/.gitlab-ci.yml (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/.links (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/AST.ml (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/AST.mli (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/Error.mli (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/EvalOpt.ml (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/EvalOpt.mli (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/FQueue.ml (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/FQueue.mli (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/LexToken.mli (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/LexToken.mll (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/Lexer.mli (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/Lexer.mll (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/LexerLog.ml (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/LexerLog.mli (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/LexerMain.ml (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/Markup.ml (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/Markup.mli (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/ParToken.mly (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/Parser.mly (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/ParserLog.ml (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/ParserLog.mli (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/ParserMain.ml (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/Tests/a.ligo (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/Tests/crowdfunding.ligo (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/Utils.ml (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/Utils.mli (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/check_dot_git_is_dir.sh (100%) rename src/ligo/{ligo_parser => parser/pascaligo}/dune (93%) rename src/ligo/{ligo_parser/ligo_parser.ml => parser/pascaligo/pascaligo.ml} (100%) delete mode 100644 src/ligo/run/run.ml rename src/ligo/{simplify_multifix.ml => simplify/camligo.ml} (99%) create mode 100644 src/ligo/simplify/dune rename src/ligo/{simplify.ml => simplify/pascaligo.ml} (99%) create mode 100644 src/ligo/simplify/simplify.ml rename src/ligo/{run => transpiler}/dune (70%) rename src/ligo/{ => transpiler}/transpiler.ml (100%) create mode 100644 src/ligo/typer/dune rename src/ligo/{ => typer}/typer.ml (100%) diff --git a/src/ligo/ast_simplified/combinators.ml b/src/ligo/ast_simplified/combinators.ml index f1e5b458b..e7b6986f9 100644 --- a/src/ligo/ast_simplified/combinators.ml +++ b/src/ligo/ast_simplified/combinators.ml @@ -2,12 +2,15 @@ open Types module SMap = Map.String +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 t_bool : type_expression = T_constant ("bool", []) let t_string : type_expression = T_constant ("string", []) let t_bytes : type_expression = T_constant ("bytes", []) let t_int : type_expression = T_constant ("int", []) +let t_operation : type_expression = T_constant ("operation", []) let t_nat : type_expression = T_constant ("nat", []) let t_unit : type_expression = T_constant ("unit", []) let t_option o : type_expression = T_constant ("option", [o]) diff --git a/src/ligo/dune b/src/ligo/dune index 5a0a250a4..f077868b2 100644 --- a/src/ligo/dune +++ b/src/ligo/dune @@ -14,14 +14,7 @@ tezos-utils tezos-micheline meta_michelson - ligo_parser - multifix - ast_typed - ast_simplified - mini_c - operators - compiler - run + main ) (preprocess (pps tezos-utils.ppx_let_generalized) diff --git a/src/ligo/ligo.ml b/src/ligo/ligo.ml index 6ad06f831..1e27a74ab 100644 --- a/src/ligo/ligo.ml +++ b/src/ligo/ligo.ml @@ -1,178 +1 @@ -open Trace -module Parser = Parser -module AST_Raw = Ligo_parser.AST -module AST_Simplified = Ast_simplified -module AST_Typed = Ast_typed -module Mini_c = Mini_c -module Typer = Typer -module Transpiler = Transpiler -module Parser_multifix = Multifix -module Simplify_multifix = Simplify_multifix - - -let simplify (p:AST_Raw.t) : Ast_simplified.program result = Simplify.simpl_program p -let simplify_expr (e:AST_Raw.expr) : Ast_simplified.annotated_expression result = Simplify.simpl_expression e -let unparse_simplified_expr (e:AST_Simplified.annotated_expression) : string result = - ok @@ Format.asprintf "%a" AST_Simplified.PP.annotated_expression e - -let type_ (p:AST_Simplified.program) : AST_Typed.program result = Typer.type_program p -let type_expression ?(env:Typer.Environment.t = Typer.Environment.full_empty) - (e:AST_Simplified.annotated_expression) : AST_Typed.annotated_expression result = - Typer.type_annotated_expression env e -let untype_expression (e:AST_Typed.annotated_expression) : AST_Simplified.annotated_expression result = Typer.untype_annotated_expression e - -let transpile (p:AST_Typed.program) : Mini_c.program result = Transpiler.translate_program p -let transpile_entry (p:AST_Typed.program) (name:string) : Mini_c.anon_function result = Transpiler.translate_entry p name -let transpile_expression ?(env:Mini_c.Environment.t = Mini_c.Environment.empty) - (e:AST_Typed.annotated_expression) : Mini_c.expression result = Transpiler.translate_annotated_expression env e -let transpile_value - (e:AST_Typed.annotated_expression) : Mini_c.value result = - let%bind f = - let open Transpiler in - let (f, t) = functionalize e in - let%bind main = translate_main f t in - ok main - in - - let input = Mini_c.Combinators.d_unit in - let%bind r = Run.Mini_c.run_entry f input in - ok r - -let untranspile_value (v : Mini_c.value) (e:AST_Typed.type_value) : AST_Typed.annotated_expression result = - Transpiler.untranspile v e - -let compile : Mini_c.program -> string -> Compiler.Program.compiled_program result = Compiler.Program.translate_program - -let type_file ?(debug_simplify = false) ?(debug_typed = false) - (path:string) : AST_Typed.program result = - let%bind raw = Parser.parse_file path in - let%bind simpl = - trace (simple_error "simplifying") @@ - simplify raw in - (if debug_simplify then - Format.(printf "Simplified : %a\n%!" AST_Simplified.PP.program simpl) - ) ; - let%bind typed = - trace (simple_error "typing") @@ - type_ simpl in - (if debug_typed then ( - Format.(printf "Typed : %a\n%!" AST_Typed.PP.program typed) - )) ; - ok typed - - -let easy_evaluate_typed (entry:string) (program:AST_Typed.program) : AST_Typed.annotated_expression result = - let%bind result = - let%bind mini_c_main = - transpile_entry program entry in - Run.Mini_c.run_entry mini_c_main (Mini_c.Combinators.d_unit) in - let%bind typed_result = - let%bind typed_main = Ast_typed.get_entry program entry in - untranspile_value result typed_main.type_annotation in - ok typed_result - -let easy_evaluate_typed_simplified (entry:string) (program:AST_Typed.program) : Ast_simplified.annotated_expression result = - let%bind result = - let%bind mini_c_main = - transpile_entry program entry in - Run.Mini_c.run_entry mini_c_main (Mini_c.Combinators.d_unit) in - let%bind typed_result = - let%bind typed_main = Ast_typed.get_entry program entry in - untranspile_value result typed_main.type_annotation in - let%bind annotated_result = untype_expression typed_result in - ok annotated_result - -let easy_evaluate_typed = trace_f_2_ez easy_evaluate_typed (thunk "easy evaluate typed") - -let easy_run_typed - ?(debug_mini_c = false) (entry:string) - (program:AST_Typed.program) (input:AST_Typed.annotated_expression) : AST_Typed.annotated_expression result = - let%bind mini_c_main = - trace (simple_error "transpile mini_c entry") @@ - transpile_entry program entry in - (if debug_mini_c then - Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main.content) - ) ; - - let%bind mini_c_value = transpile_value input in - - let%bind mini_c_result = - let error = - let title () = "run Mini_c" in - let content () = - Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main.content - in - error title content in - trace error @@ - Run.Mini_c.run_entry mini_c_main mini_c_value in - let%bind typed_result = - let%bind main_result_type = - let%bind typed_main = Ast_typed.get_functional_entry program entry in - match (snd typed_main).type_value' with - | T_function (_, result) -> ok result - | _ -> simple_fail "main doesn't have fun type" in - untranspile_value mini_c_result main_result_type in - ok typed_result - -let easy_run_typed_simplified - ?(debug_mini_c = false) (entry:string) - (program:AST_Typed.program) (input:Ast_simplified.annotated_expression) : Ast_simplified.annotated_expression result = - let%bind mini_c_main = - trace (simple_error "transpile mini_c entry") @@ - transpile_entry program entry in - (if debug_mini_c then - Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main.content) - ) ; - - let%bind typed_value = type_expression input in - let%bind mini_c_value = transpile_value typed_value in - - let%bind mini_c_result = - let error = - let title () = "run Mini_c" in - let content () = - Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main.content - in - error title content in - trace error @@ - Run.Mini_c.run_entry mini_c_main mini_c_value in - let%bind typed_result = - let%bind main_result_type = - let%bind typed_main = Ast_typed.get_functional_entry program entry in - match (snd typed_main).type_value' with - | T_function (_, result) -> ok result - | _ -> simple_fail "main doesn't have fun type" in - untranspile_value mini_c_result main_result_type in - let%bind annotated_result = untype_expression typed_result in - ok annotated_result - -let easy_run_main_typed - ?(debug_mini_c = false) - (program:AST_Typed.program) (input:AST_Typed.annotated_expression) : AST_Typed.annotated_expression result = - easy_run_typed ~debug_mini_c "main" program input - -let easy_run_main (path:string) (input:string) : AST_Typed.annotated_expression result = - let%bind typed = type_file path in - - let%bind raw_expr = Parser.parse_expression input in - let%bind simpl_expr = simplify_expr raw_expr in - let%bind typed_expr = type_expression simpl_expr in - easy_run_main_typed typed typed_expr - -let compile_file (source: string) (entry_point:string) : Micheline.Michelson.t result = - let%bind raw = - trace (simple_error "parsing") @@ - Parser.parse_file source in - let%bind simplified = - trace (simple_error "simplifying") @@ - simplify raw in - let%bind typed = - trace (simple_error "typing") @@ - type_ simplified in - let%bind mini_c = - trace (simple_error "transpiling") @@ - transpile typed in - let%bind {body = michelson} = - trace (simple_error "compiling") @@ - compile mini_c entry_point in - ok michelson +include Main diff --git a/src/ligo/main/contract.ml b/src/ligo/main/contract.ml new file mode 100644 index 000000000..57434b8df --- /dev/null +++ b/src/ligo/main/contract.ml @@ -0,0 +1,16 @@ +open Trace + +include struct + open Ast_simplified + open Combinators + + let assert_entry_point_defined : program -> string -> unit result = + fun program entry_point -> + let aux : declaration -> bool = fun declaration -> + match declaration with + | Declaration_type _ -> false + | Declaration_constant ne -> get_name ne = entry_point + in + trace_strong (simple_error "no entry-point with given name") @@ + Assert.assert_true @@ List.exists aux @@ List.map Location.unwrap program +end diff --git a/src/ligo/main/dune b/src/ligo/main/dune new file mode 100644 index 000000000..5446f4ebf --- /dev/null +++ b/src/ligo/main/dune @@ -0,0 +1,20 @@ +(library + (name main) + (public_name ligo.main) + (libraries + tezos-utils + parser + simplify + ast_simplified + typer + ast_typed + transpiler + mini_c + operators + compiler + ) + (preprocess + (pps tezos-utils.ppx_let_generalized) + ) + (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Tezos_utils )) +) diff --git a/src/ligo/main/main.ml b/src/ligo/main/main.ml new file mode 100644 index 000000000..df9cfeb67 --- /dev/null +++ b/src/ligo/main/main.ml @@ -0,0 +1,180 @@ +module Run_mini_c = Run_mini_c + +open Trace +module Parser = Parser +module AST_Raw = Parser.Pascaligo.AST +module AST_Simplified = Ast_simplified +module AST_Typed = Ast_typed +module Mini_c = Mini_c +module Typer = Typer +module Transpiler = Transpiler +(* module Parser_multifix = Multifix + * module Simplify_multifix = Simplify_multifix *) + + +let simplify (p:AST_Raw.t) : Ast_simplified.program result = Simplify.Pascaligo.simpl_program p +let simplify_expr (e:AST_Raw.expr) : Ast_simplified.annotated_expression result = Simplify.Pascaligo.simpl_expression e +let unparse_simplified_expr (e:AST_Simplified.annotated_expression) : string result = + ok @@ Format.asprintf "%a" AST_Simplified.PP.annotated_expression e + +let type_ (p:AST_Simplified.program) : AST_Typed.program result = Typer.type_program p +let type_expression ?(env:Typer.Environment.t = Typer.Environment.full_empty) + (e:AST_Simplified.annotated_expression) : AST_Typed.annotated_expression result = + Typer.type_annotated_expression env e +let untype_expression (e:AST_Typed.annotated_expression) : AST_Simplified.annotated_expression result = Typer.untype_annotated_expression e + +let transpile (p:AST_Typed.program) : Mini_c.program result = Transpiler.translate_program p +let transpile_entry (p:AST_Typed.program) (name:string) : Mini_c.anon_function result = Transpiler.translate_entry p name +let transpile_expression ?(env:Mini_c.Environment.t = Mini_c.Environment.empty) + (e:AST_Typed.annotated_expression) : Mini_c.expression result = Transpiler.translate_annotated_expression env e +let transpile_value + (e:AST_Typed.annotated_expression) : Mini_c.value result = + let%bind f = + let open Transpiler in + let (f, t) = functionalize e in + let%bind main = translate_main f t in + ok main + in + + let input = Mini_c.Combinators.d_unit in + let%bind r = Run_mini_c.run_entry f input in + ok r + +let untranspile_value (v : Mini_c.value) (e:AST_Typed.type_value) : AST_Typed.annotated_expression result = + Transpiler.untranspile v e + +let compile : Mini_c.program -> string -> Compiler.Program.compiled_program result = Compiler.Program.translate_program + +let type_file ?(debug_simplify = false) ?(debug_typed = false) + (path:string) : AST_Typed.program result = + let%bind raw = Parser.parse_file path in + let%bind simpl = + trace (simple_error "simplifying") @@ + simplify raw in + (if debug_simplify then + Format.(printf "Simplified : %a\n%!" AST_Simplified.PP.program simpl) + ) ; + let%bind typed = + trace (simple_error "typing") @@ + type_ simpl in + (if debug_typed then ( + Format.(printf "Typed : %a\n%!" AST_Typed.PP.program typed) + )) ; + ok typed + + +let easy_evaluate_typed (entry:string) (program:AST_Typed.program) : AST_Typed.annotated_expression result = + let%bind result = + let%bind mini_c_main = + transpile_entry program entry in + Run_mini_c.run_entry mini_c_main (Mini_c.Combinators.d_unit) in + let%bind typed_result = + let%bind typed_main = Ast_typed.get_entry program entry in + untranspile_value result typed_main.type_annotation in + ok typed_result + +let easy_evaluate_typed_simplified (entry:string) (program:AST_Typed.program) : Ast_simplified.annotated_expression result = + let%bind result = + let%bind mini_c_main = + transpile_entry program entry in + Run_mini_c.run_entry mini_c_main (Mini_c.Combinators.d_unit) in + let%bind typed_result = + let%bind typed_main = Ast_typed.get_entry program entry in + untranspile_value result typed_main.type_annotation in + let%bind annotated_result = untype_expression typed_result in + ok annotated_result + +let easy_evaluate_typed = trace_f_2_ez easy_evaluate_typed (thunk "easy evaluate typed") + +let easy_run_typed + ?(debug_mini_c = false) (entry:string) + (program:AST_Typed.program) (input:AST_Typed.annotated_expression) : AST_Typed.annotated_expression result = + let%bind mini_c_main = + trace (simple_error "transpile mini_c entry") @@ + transpile_entry program entry in + (if debug_mini_c then + Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main.content) + ) ; + + let%bind mini_c_value = transpile_value input in + + let%bind mini_c_result = + let error = + let title () = "run Mini_c" in + let content () = + Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main.content + in + error title content in + trace error @@ + Run_mini_c.run_entry mini_c_main mini_c_value in + let%bind typed_result = + let%bind main_result_type = + let%bind typed_main = Ast_typed.get_functional_entry program entry in + match (snd typed_main).type_value' with + | T_function (_, result) -> ok result + | _ -> simple_fail "main doesn't have fun type" in + untranspile_value mini_c_result main_result_type in + ok typed_result + +let easy_run_typed_simplified + ?(debug_mini_c = false) (entry:string) + (program:AST_Typed.program) (input:Ast_simplified.annotated_expression) : Ast_simplified.annotated_expression result = + let%bind mini_c_main = + trace (simple_error "transpile mini_c entry") @@ + transpile_entry program entry in + (if debug_mini_c then + Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main.content) + ) ; + + let%bind typed_value = type_expression input in + let%bind mini_c_value = transpile_value typed_value in + + let%bind mini_c_result = + let error = + let title () = "run Mini_c" in + let content () = + Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main.content + in + error title content in + trace error @@ + Run_mini_c.run_entry mini_c_main mini_c_value in + let%bind typed_result = + let%bind main_result_type = + let%bind typed_main = Ast_typed.get_functional_entry program entry in + match (snd typed_main).type_value' with + | T_function (_, result) -> ok result + | _ -> simple_fail "main doesn't have fun type" in + untranspile_value mini_c_result main_result_type in + let%bind annotated_result = untype_expression typed_result in + ok annotated_result + +let easy_run_main_typed + ?(debug_mini_c = false) + (program:AST_Typed.program) (input:AST_Typed.annotated_expression) : AST_Typed.annotated_expression result = + easy_run_typed ~debug_mini_c "main" program input + +let easy_run_main (path:string) (input:string) : AST_Typed.annotated_expression result = + let%bind typed = type_file path in + + let%bind raw_expr = Parser.parse_expression input in + let%bind simpl_expr = simplify_expr raw_expr in + let%bind typed_expr = type_expression simpl_expr in + easy_run_main_typed typed typed_expr + +let compile_file (source: string) (entry_point:string) : Micheline.Michelson.t result = + let%bind raw = + trace (simple_error "parsing") @@ + Parser.parse_file source in + let%bind simplified = + trace (simple_error "simplifying") @@ + simplify raw in + let%bind typed = + trace (simple_error "typing") @@ + type_ simplified in + let%bind mini_c = + trace (simple_error "transpiling") @@ + transpile typed in + let%bind {body = michelson} = + trace (simple_error "compiling") @@ + compile mini_c entry_point in + ok michelson diff --git a/src/ligo/run/from_mini_c.ml b/src/ligo/main/run_mini_c.ml similarity index 100% rename from src/ligo/run/from_mini_c.ml rename to src/ligo/main/run_mini_c.ml diff --git a/src/ligo/multifix/.gitignore b/src/ligo/parser/camligo/.gitignore similarity index 100% rename from src/ligo/multifix/.gitignore rename to src/ligo/parser/camligo/.gitignore diff --git a/src/ligo/multifix/dune b/src/ligo/parser/camligo/dune similarity index 94% rename from src/ligo/multifix/dune rename to src/ligo/parser/camligo/dune index 49bb286c4..3023c7f1c 100644 --- a/src/ligo/multifix/dune +++ b/src/ligo/parser/camligo/dune @@ -1,6 +1,6 @@ (library - (name multifix) - (public_name ligo.multifix) + (name parser_camligo) + (public_name ligo.parser.camligo) (libraries tezos-utils lex diff --git a/src/ligo/multifix/generator.ml b/src/ligo/parser/camligo/generator.ml similarity index 100% rename from src/ligo/multifix/generator.ml rename to src/ligo/parser/camligo/generator.ml diff --git a/src/ligo/multifix/lex/dune b/src/ligo/parser/camligo/lex/dune similarity index 100% rename from src/ligo/multifix/lex/dune rename to src/ligo/parser/camligo/lex/dune diff --git a/src/ligo/multifix/lex/generator.ml b/src/ligo/parser/camligo/lex/generator.ml similarity index 100% rename from src/ligo/multifix/lex/generator.ml rename to src/ligo/parser/camligo/lex/generator.ml diff --git a/src/ligo/multifix/location.ml b/src/ligo/parser/camligo/location.ml similarity index 100% rename from src/ligo/multifix/location.ml rename to src/ligo/parser/camligo/location.ml diff --git a/src/ligo/multifix/pre_parser.mly b/src/ligo/parser/camligo/pre_parser.mly similarity index 100% rename from src/ligo/multifix/pre_parser.mly rename to src/ligo/parser/camligo/pre_parser.mly diff --git a/src/ligo/multifix/user.ml b/src/ligo/parser/camligo/user.ml similarity index 100% rename from src/ligo/multifix/user.ml rename to src/ligo/parser/camligo/user.ml diff --git a/src/ligo/parser/dune b/src/ligo/parser/dune new file mode 100644 index 000000000..f1f8f646b --- /dev/null +++ b/src/ligo/parser/dune @@ -0,0 +1,12 @@ +(library + (name parser) + (public_name ligo.parser) + (libraries + tezos-utils + parser_pascaligo + parser_camligo + ) + (preprocess + (pps tezos-utils.ppx_let_generalized) + ) +) diff --git a/src/ligo/parser.ml b/src/ligo/parser/parser.ml similarity index 96% rename from src/ligo/parser.ml rename to src/ligo/parser/parser.ml index 05f8809c6..70cc7d495 100644 --- a/src/ligo/parser.ml +++ b/src/ligo/parser/parser.ml @@ -1,6 +1,11 @@ open Trace -open Ligo_parser -module AST_Raw = Ligo_parser.AST + +module Pascaligo = Parser_pascaligo +module Camligo = Parser_camligo + +open Parser_pascaligo +module AST_Raw = Parser_pascaligo.AST + let parse_file (source: string) : AST_Raw.t result = let pp_input = diff --git a/src/ligo/ligo_parser/.Lexer.ml.tag b/src/ligo/parser/pascaligo/.Lexer.ml.tag similarity index 100% rename from src/ligo/ligo_parser/.Lexer.ml.tag rename to src/ligo/parser/pascaligo/.Lexer.ml.tag diff --git a/src/ligo/ligo_parser/.LexerMain.tag b/src/ligo/parser/pascaligo/.LexerMain.tag similarity index 100% rename from src/ligo/ligo_parser/.LexerMain.tag rename to src/ligo/parser/pascaligo/.LexerMain.tag diff --git a/src/ligo/ligo_parser/.Parser.mly.tag b/src/ligo/parser/pascaligo/.Parser.mly.tag similarity index 100% rename from src/ligo/ligo_parser/.Parser.mly.tag rename to src/ligo/parser/pascaligo/.Parser.mly.tag diff --git a/src/ligo/ligo_parser/.ParserMain.tag b/src/ligo/parser/pascaligo/.ParserMain.tag similarity index 100% rename from src/ligo/ligo_parser/.ParserMain.tag rename to src/ligo/parser/pascaligo/.ParserMain.tag diff --git a/src/ligo/ligo_parser/.gitignore b/src/ligo/parser/pascaligo/.gitignore similarity index 100% rename from src/ligo/ligo_parser/.gitignore rename to src/ligo/parser/pascaligo/.gitignore diff --git a/src/ligo/ligo_parser/.gitlab-ci.yml b/src/ligo/parser/pascaligo/.gitlab-ci.yml similarity index 100% rename from src/ligo/ligo_parser/.gitlab-ci.yml rename to src/ligo/parser/pascaligo/.gitlab-ci.yml diff --git a/src/ligo/ligo_parser/.links b/src/ligo/parser/pascaligo/.links similarity index 100% rename from src/ligo/ligo_parser/.links rename to src/ligo/parser/pascaligo/.links diff --git a/src/ligo/ligo_parser/AST.ml b/src/ligo/parser/pascaligo/AST.ml similarity index 100% rename from src/ligo/ligo_parser/AST.ml rename to src/ligo/parser/pascaligo/AST.ml diff --git a/src/ligo/ligo_parser/AST.mli b/src/ligo/parser/pascaligo/AST.mli similarity index 100% rename from src/ligo/ligo_parser/AST.mli rename to src/ligo/parser/pascaligo/AST.mli diff --git a/src/ligo/ligo_parser/Error.mli b/src/ligo/parser/pascaligo/Error.mli similarity index 100% rename from src/ligo/ligo_parser/Error.mli rename to src/ligo/parser/pascaligo/Error.mli diff --git a/src/ligo/ligo_parser/EvalOpt.ml b/src/ligo/parser/pascaligo/EvalOpt.ml similarity index 100% rename from src/ligo/ligo_parser/EvalOpt.ml rename to src/ligo/parser/pascaligo/EvalOpt.ml diff --git a/src/ligo/ligo_parser/EvalOpt.mli b/src/ligo/parser/pascaligo/EvalOpt.mli similarity index 100% rename from src/ligo/ligo_parser/EvalOpt.mli rename to src/ligo/parser/pascaligo/EvalOpt.mli diff --git a/src/ligo/ligo_parser/FQueue.ml b/src/ligo/parser/pascaligo/FQueue.ml similarity index 100% rename from src/ligo/ligo_parser/FQueue.ml rename to src/ligo/parser/pascaligo/FQueue.ml diff --git a/src/ligo/ligo_parser/FQueue.mli b/src/ligo/parser/pascaligo/FQueue.mli similarity index 100% rename from src/ligo/ligo_parser/FQueue.mli rename to src/ligo/parser/pascaligo/FQueue.mli diff --git a/src/ligo/ligo_parser/LexToken.mli b/src/ligo/parser/pascaligo/LexToken.mli similarity index 100% rename from src/ligo/ligo_parser/LexToken.mli rename to src/ligo/parser/pascaligo/LexToken.mli diff --git a/src/ligo/ligo_parser/LexToken.mll b/src/ligo/parser/pascaligo/LexToken.mll similarity index 100% rename from src/ligo/ligo_parser/LexToken.mll rename to src/ligo/parser/pascaligo/LexToken.mll diff --git a/src/ligo/ligo_parser/Lexer.mli b/src/ligo/parser/pascaligo/Lexer.mli similarity index 100% rename from src/ligo/ligo_parser/Lexer.mli rename to src/ligo/parser/pascaligo/Lexer.mli diff --git a/src/ligo/ligo_parser/Lexer.mll b/src/ligo/parser/pascaligo/Lexer.mll similarity index 100% rename from src/ligo/ligo_parser/Lexer.mll rename to src/ligo/parser/pascaligo/Lexer.mll diff --git a/src/ligo/ligo_parser/LexerLog.ml b/src/ligo/parser/pascaligo/LexerLog.ml similarity index 100% rename from src/ligo/ligo_parser/LexerLog.ml rename to src/ligo/parser/pascaligo/LexerLog.ml diff --git a/src/ligo/ligo_parser/LexerLog.mli b/src/ligo/parser/pascaligo/LexerLog.mli similarity index 100% rename from src/ligo/ligo_parser/LexerLog.mli rename to src/ligo/parser/pascaligo/LexerLog.mli diff --git a/src/ligo/ligo_parser/LexerMain.ml b/src/ligo/parser/pascaligo/LexerMain.ml similarity index 100% rename from src/ligo/ligo_parser/LexerMain.ml rename to src/ligo/parser/pascaligo/LexerMain.ml diff --git a/src/ligo/ligo_parser/Markup.ml b/src/ligo/parser/pascaligo/Markup.ml similarity index 100% rename from src/ligo/ligo_parser/Markup.ml rename to src/ligo/parser/pascaligo/Markup.ml diff --git a/src/ligo/ligo_parser/Markup.mli b/src/ligo/parser/pascaligo/Markup.mli similarity index 100% rename from src/ligo/ligo_parser/Markup.mli rename to src/ligo/parser/pascaligo/Markup.mli diff --git a/src/ligo/ligo_parser/ParToken.mly b/src/ligo/parser/pascaligo/ParToken.mly similarity index 100% rename from src/ligo/ligo_parser/ParToken.mly rename to src/ligo/parser/pascaligo/ParToken.mly diff --git a/src/ligo/ligo_parser/Parser.mly b/src/ligo/parser/pascaligo/Parser.mly similarity index 100% rename from src/ligo/ligo_parser/Parser.mly rename to src/ligo/parser/pascaligo/Parser.mly diff --git a/src/ligo/ligo_parser/ParserLog.ml b/src/ligo/parser/pascaligo/ParserLog.ml similarity index 100% rename from src/ligo/ligo_parser/ParserLog.ml rename to src/ligo/parser/pascaligo/ParserLog.ml diff --git a/src/ligo/ligo_parser/ParserLog.mli b/src/ligo/parser/pascaligo/ParserLog.mli similarity index 100% rename from src/ligo/ligo_parser/ParserLog.mli rename to src/ligo/parser/pascaligo/ParserLog.mli diff --git a/src/ligo/ligo_parser/ParserMain.ml b/src/ligo/parser/pascaligo/ParserMain.ml similarity index 100% rename from src/ligo/ligo_parser/ParserMain.ml rename to src/ligo/parser/pascaligo/ParserMain.ml diff --git a/src/ligo/ligo_parser/Tests/a.ligo b/src/ligo/parser/pascaligo/Tests/a.ligo similarity index 100% rename from src/ligo/ligo_parser/Tests/a.ligo rename to src/ligo/parser/pascaligo/Tests/a.ligo diff --git a/src/ligo/ligo_parser/Tests/crowdfunding.ligo b/src/ligo/parser/pascaligo/Tests/crowdfunding.ligo similarity index 100% rename from src/ligo/ligo_parser/Tests/crowdfunding.ligo rename to src/ligo/parser/pascaligo/Tests/crowdfunding.ligo diff --git a/src/ligo/ligo_parser/Utils.ml b/src/ligo/parser/pascaligo/Utils.ml similarity index 100% rename from src/ligo/ligo_parser/Utils.ml rename to src/ligo/parser/pascaligo/Utils.ml diff --git a/src/ligo/ligo_parser/Utils.mli b/src/ligo/parser/pascaligo/Utils.mli similarity index 100% rename from src/ligo/ligo_parser/Utils.mli rename to src/ligo/parser/pascaligo/Utils.mli diff --git a/src/ligo/ligo_parser/check_dot_git_is_dir.sh b/src/ligo/parser/pascaligo/check_dot_git_is_dir.sh similarity index 100% rename from src/ligo/ligo_parser/check_dot_git_is_dir.sh rename to src/ligo/parser/pascaligo/check_dot_git_is_dir.sh diff --git a/src/ligo/ligo_parser/dune b/src/ligo/parser/pascaligo/dune similarity index 93% rename from src/ligo/ligo_parser/dune rename to src/ligo/parser/pascaligo/dune index 3b654987f..f256b66d8 100644 --- a/src/ligo/ligo_parser/dune +++ b/src/ligo/parser/pascaligo/dune @@ -7,8 +7,8 @@ (flags -la 1 --explain --external-tokens LexToken)) (library - (name ligo_parser) - (public_name ligo.parser) + (name parser_pascaligo) + (public_name ligo.parser.pascaligo) (modules_without_implementation Error) (libraries getopt diff --git a/src/ligo/ligo_parser/ligo_parser.ml b/src/ligo/parser/pascaligo/pascaligo.ml similarity index 100% rename from src/ligo/ligo_parser/ligo_parser.ml rename to src/ligo/parser/pascaligo/pascaligo.ml diff --git a/src/ligo/run/run.ml b/src/ligo/run/run.ml deleted file mode 100644 index 566d43c8a..000000000 --- a/src/ligo/run/run.ml +++ /dev/null @@ -1 +0,0 @@ -module Mini_c = From_mini_c diff --git a/src/ligo/simplify_multifix.ml b/src/ligo/simplify/camligo.ml similarity index 99% rename from src/ligo/simplify_multifix.ml rename to src/ligo/simplify/camligo.ml index 4442071a5..8acfe85c3 100644 --- a/src/ligo/simplify_multifix.ml +++ b/src/ligo/simplify/camligo.ml @@ -1,6 +1,6 @@ open Trace open Function -module I = Multifix.Ast +module I = Parser.Camligo.Ast module O = Ast_simplified open O.Combinators diff --git a/src/ligo/simplify/dune b/src/ligo/simplify/dune new file mode 100644 index 000000000..01bc53c9c --- /dev/null +++ b/src/ligo/simplify/dune @@ -0,0 +1,14 @@ +(library + (name simplify) + (public_name ligo.simplify) + (libraries + tezos-utils + parser + ast_simplified + operators + ) + (preprocess + (pps tezos-utils.ppx_let_generalized) + ) + (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Tezos_utils )) +) diff --git a/src/ligo/simplify.ml b/src/ligo/simplify/pascaligo.ml similarity index 99% rename from src/ligo/simplify.ml rename to src/ligo/simplify/pascaligo.ml index a90b4a869..517eb83ef 100644 --- a/src/ligo/simplify.ml +++ b/src/ligo/simplify/pascaligo.ml @@ -1,7 +1,7 @@ open Trace open Ast_simplified -module Raw = Ligo_parser.AST +module Raw = Parser.Pascaligo.AST module SMap = Map.String open Combinators @@ -425,7 +425,7 @@ and simpl_single_instruction : Raw.single_instr -> instruction result = fun t -> ok @@ I_assignment {name = name.value ; annotated_expression = value_expr} ) | Path path -> ( - let err_content () = Format.asprintf "%a" (PP_helpers.printer Ligo_parser.ParserLog.print_path) path in + let err_content () = Format.asprintf "%a" (PP_helpers.printer Parser.Pascaligo.ParserLog.print_path) path in fail @@ (fun () -> error (thunk "no path assignments") err_content ()) ) | MapPath v -> ( @@ -456,7 +456,7 @@ and simpl_single_instruction : Raw.single_instr -> instruction result = fun t -> let%bind record = match r.path with | Name v -> ok v.value | path -> ( - let err_content () = Format.asprintf "%a" (PP_helpers.printer Ligo_parser.ParserLog.print_path) path in + let err_content () = Format.asprintf "%a" (PP_helpers.printer Parser.Pascaligo.ParserLog.print_path) path in fail @@ (fun () -> error (thunk "no complex record patch yet") err_content ()) ) in diff --git a/src/ligo/simplify/simplify.ml b/src/ligo/simplify/simplify.ml new file mode 100644 index 000000000..60959e005 --- /dev/null +++ b/src/ligo/simplify/simplify.ml @@ -0,0 +1,2 @@ +module Pascaligo = Pascaligo +module Camligo = Camligo diff --git a/src/ligo/test/compiler_tests.ml b/src/ligo/test/compiler_tests.ml index 439b00651..c13fcb997 100644 --- a/src/ligo/test/compiler_tests.ml +++ b/src/ligo/test/compiler_tests.ml @@ -5,7 +5,7 @@ open Test_helpers let run_entry_int (e:anon_function) (n:int) : int result = let param : value = D_int n in - let%bind result = Run.Mini_c.run_entry e param in + let%bind result = Main.Run_mini_c.run_entry e param in match result with | D_int n -> ok n | _ -> simple_fail "result is not an int" diff --git a/src/ligo/test/integration_tests.ml b/src/ligo/test/integration_tests.ml index de0267db6..b5c9ab633 100644 --- a/src/ligo/test/integration_tests.ml +++ b/src/ligo/test/integration_tests.ml @@ -286,7 +286,7 @@ let quote_declarations () : unit result = let counter_contract () : unit result = let%bind program = type_file "./contracts/counter.ligo" in let make_input = fun n-> e_a_pair (e_a_int n) (e_a_int 42) in - let make_expected = fun n -> e_a_pair (e_a_list [] (t_int)) (e_a_int (42 + n)) in + let make_expected = fun n -> e_a_pair (e_a_list [] t_operation) (e_a_int (42 + n)) in expect_n program "main" make_input make_expected let main = "Integration (End to End)", [ diff --git a/src/ligo/test/multifix_tests.ml b/src/ligo/test/multifix_tests.ml index b2433880a..995a4dbc9 100644 --- a/src/ligo/test/multifix_tests.ml +++ b/src/ligo/test/multifix_tests.ml @@ -1,6 +1,6 @@ open Trace open Test_helpers -open Ligo.Parser_multifix +open Parser.Camligo let basic () : unit result = let%bind _ = User.parse_file "./contracts/new-syntax.mligo" in @@ -8,12 +8,12 @@ let basic () : unit result = let simplify () : unit result = let%bind raw = User.parse_file "./contracts/basic.mligo" in - let%bind _simpl = Ligo.Simplify_multifix.main raw in + let%bind _simpl = Simplify.Camligo.main raw in ok () 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 simpl = Simplify.Camligo.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_empty_int (42 + 127), result) diff --git a/src/ligo/run/dune b/src/ligo/transpiler/dune similarity index 70% rename from src/ligo/run/dune rename to src/ligo/transpiler/dune index 7ed345989..4c4b9b7e9 100644 --- a/src/ligo/run/dune +++ b/src/ligo/transpiler/dune @@ -1,11 +1,11 @@ (library - (name run) - (public_name ligo.run) + (name transpiler) + (public_name ligo.transpiler) (libraries tezos-utils - meta_michelson + ast_typed mini_c - compiler + operators ) (preprocess (pps tezos-utils.ppx_let_generalized) diff --git a/src/ligo/transpiler.ml b/src/ligo/transpiler/transpiler.ml similarity index 100% rename from src/ligo/transpiler.ml rename to src/ligo/transpiler/transpiler.ml diff --git a/src/ligo/typer/dune b/src/ligo/typer/dune new file mode 100644 index 000000000..6826f0510 --- /dev/null +++ b/src/ligo/typer/dune @@ -0,0 +1,14 @@ +(library + (name typer) + (public_name ligo.typer) + (libraries + tezos-utils + ast_simplified + ast_typed + operators + ) + (preprocess + (pps tezos-utils.ppx_let_generalized) + ) + (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Tezos_utils )) +) diff --git a/src/ligo/typer.ml b/src/ligo/typer/typer.ml similarity index 100% rename from src/ligo/typer.ml rename to src/ligo/typer/typer.ml From 72f5698c3ddb5e53deafcaf69f45d3d4a4e0184f Mon Sep 17 00:00:00 2001 From: Galfour Date: Mon, 22 Apr 2019 18:15:39 +0000 Subject: [PATCH 06/15] add variants --- src/lib_utils/PP.ml | 2 + src/lib_utils/tree.ml | 1 + src/lib_utils/x_tezos_micheline.ml | 7 ++ src/ligo/ast_simplified/PP.ml | 6 ++ src/ligo/ast_simplified/combinators.ml | 2 + src/ligo/ast_simplified/types.ml | 2 + src/ligo/ast_typed/PP.ml | 6 ++ src/ligo/ast_typed/combinators.ml | 30 +++++++ src/ligo/ast_typed/misc.ml | 6 +- src/ligo/ast_typed/types.ml | 6 +- src/ligo/bin/cli.ml | 43 +++++++--- src/ligo/compiler/compiler.ml | 2 + src/ligo/compiler/compiler_program.ml | 85 +++++++++++++++++- src/ligo/contracts/match.ligo | 9 +- src/ligo/contracts/super-counter.ligo | 10 +++ src/ligo/contracts/variant.ligo | 13 +++ src/ligo/main/contract.ml | 109 ++++++++++++++++++++++++ src/ligo/main/main.ml | 2 + src/ligo/mini_c/PP.ml | 11 ++- src/ligo/mini_c/combinators.ml | 14 +++ src/ligo/mini_c/mini_c.ml | 1 + src/ligo/mini_c/types.ml | 3 + src/ligo/parser/pascaligo/AST.ml | 2 + src/ligo/parser/pascaligo/AST.mli | 1 + src/ligo/parser/pascaligo/Parser.mly | 17 +++- src/ligo/parser/pascaligo/ParserLog.ml | 6 ++ src/ligo/parser/pascaligo/ParserLog.mli | 1 + src/ligo/simplify/pascaligo.ml | 73 +++++++++++----- src/ligo/test/integration_tests.ml | 34 +++++++- src/ligo/test/test_helpers.ml | 4 +- src/ligo/transpiler/transpiler.ml | 94 +++++++++++++++++--- src/ligo/typer/typer.ml | 76 +++++++++++++++-- 32 files changed, 609 insertions(+), 69 deletions(-) create mode 100644 src/ligo/contracts/super-counter.ligo create mode 100644 src/ligo/contracts/variant.ligo diff --git a/src/lib_utils/PP.ml b/src/lib_utils/PP.ml index a32854c6f..b82249812 100644 --- a/src/lib_utils/PP.ml +++ b/src/lib_utils/PP.ml @@ -23,6 +23,8 @@ let option = fun f ppf opt -> | Some x -> fprintf ppf "Some(%a)" f x | None -> fprintf ppf "None" +let int = fun ppf n -> fprintf ppf "%d" n + let map = fun f pp ppf x -> pp ppf (f x) diff --git a/src/lib_utils/tree.ml b/src/lib_utils/tree.ml index 7b4c5886a..1893e57a6 100644 --- a/src/lib_utils/tree.ml +++ b/src/lib_utils/tree.ml @@ -94,6 +94,7 @@ module Append = struct | Empty -> empty | Full x -> fold' leaf node x + let rec assoc_opt' : ('a * 'b) t' -> 'a -> 'b option = fun t k -> match t with | Leaf (k', v) when k = k' -> Some v diff --git a/src/lib_utils/x_tezos_micheline.ml b/src/lib_utils/x_tezos_micheline.ml index 2219c74c0..ff497414f 100644 --- a/src/lib_utils/x_tezos_micheline.ml +++ b/src/lib_utils/x_tezos_micheline.ml @@ -18,6 +18,13 @@ module Michelson = struct let i_comment s : michelson = prim ~annot:["\"" ^ s ^ "\""] I_NOP + let contract parameter storage code = + seq [ + prim ~children:[parameter] K_parameter ; + prim ~children:[storage] K_storage ; + prim ~children:[code] K_code ; + ] + let int n : michelson = Int (0, n) let string s : michelson = String (0, s) let bytes s : michelson = Bytes (0, s) diff --git a/src/ligo/ast_simplified/PP.ml b/src/ligo/ast_simplified/PP.ml index b6d7beb0a..a28cc0bbe 100644 --- a/src/ligo/ast_simplified/PP.ml +++ b/src/ligo/ast_simplified/PP.ml @@ -66,10 +66,16 @@ and block ppf (b:block) = (list_sep instruction (tag "@;")) ppf b and single_record_patch ppf ((p, ae) : string * ae) = fprintf ppf "%s <- %a" p annotated_expression ae +and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor_name * name) * a -> unit = + fun f ppf ((c,n),a) -> + fprintf ppf "| %s %s -> %a" c n f a + 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_d string) lst f b + | Match_variant lst -> + fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst | 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)} -> diff --git a/src/ligo/ast_simplified/combinators.ml b/src/ligo/ast_simplified/combinators.ml index e7b6986f9..833e70f71 100644 --- a/src/ligo/ast_simplified/combinators.ml +++ b/src/ligo/ast_simplified/combinators.ml @@ -56,11 +56,13 @@ let e_none : expression = E_constant ("NONE", []) let e_map lst : expression = E_map lst let e_list lst : expression = E_list lst let e_pair a b : expression = E_tuple [a; b] +let e_constructor s a : expression = E_constructor (s , a) let e_a_int n : annotated_expression = make_e_a_full (e_int n) t_int let e_a_nat n : annotated_expression = make_e_a_full (e_nat n) t_nat let e_a_bool b : annotated_expression = make_e_a_full (e_bool b) t_bool let e_a_unit : annotated_expression = make_e_a_full (e_unit ()) t_unit +let e_a_constructor s a : annotated_expression = make_e_a (e_constructor s a) let e_a_record r = let type_annotation = Option.( diff --git a/src/ligo/ast_simplified/types.ml b/src/ligo/ast_simplified/types.ml index fc1472b06..d6325ce66 100644 --- a/src/ligo/ast_simplified/types.ml +++ b/src/ligo/ast_simplified/types.ml @@ -1,5 +1,6 @@ type name = string type type_name = string +type constructor_name = string type 'a name_map = 'a Map.String.t type 'a type_name_map = 'a Map.String.t @@ -109,6 +110,7 @@ and 'a matching = match_some : name * 'a ; } | Match_tuple of name list * 'a + | Match_variant of ((constructor_name * name) * 'a) list and matching_instr = b matching diff --git a/src/ligo/ast_typed/PP.ml b/src/ligo/ast_typed/PP.ml index 00d25a98d..d319ae0ed 100644 --- a/src/ligo/ast_typed/PP.ml +++ b/src/ligo/ast_typed/PP.ml @@ -66,9 +66,15 @@ and block ppf (b:block) = (list_sep instruction (tag "@;")) ppf b and single_record_patch ppf ((s, ae) : string * ae) = fprintf ppf "%s <- %a" s annotated_expression ae +and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor_name * name) * a -> unit = + fun f ppf ((c,n),a) -> + fprintf ppf "| %s %s -> %a" c n f a + 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_d (fun ppf -> fprintf ppf "%s")) lst f b + | Match_variant (lst , _) -> + fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst | 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)} -> diff --git a/src/ligo/ast_typed/combinators.ml b/src/ligo/ast_typed/combinators.ml index 5d049c9d1..5caa7193c 100644 --- a/src/ligo/ast_typed/combinators.ml +++ b/src/ligo/ast_typed/combinators.ml @@ -55,6 +55,18 @@ let get_t_tuple (t:type_value) : type_value list result = match t.type_value' wi | T_tuple lst -> ok lst | _ -> simple_fail "not a tuple" +let get_t_pair (t:type_value) : (type_value * type_value) result = match t.type_value' with + | T_tuple lst -> + let%bind () = + trace_strong (simple_error "not a pair") @@ + Assert.assert_list_size lst 2 in + ok List.(nth lst 0 , nth lst 1) + | _ -> simple_fail "not a tuple" + +let get_t_function (t:type_value) : (type_value * type_value) result = match t.type_value' with + | T_function ar -> ok ar + | _ -> simple_fail "not a tuple" + let get_t_sum (t:type_value) : type_value SMap.t result = match t.type_value' with | T_sum m -> ok m | _ -> simple_fail "not a sum" @@ -67,6 +79,7 @@ let get_t_map (t:type_value) : (type_value * type_value) result = match t.type_value' with | T_constant ("map", [k;v]) -> ok (k, v) | _ -> simple_fail "get: not a map" + let assert_t_map (t:type_value) : unit result = match t.type_value' with | T_constant ("map", [_ ; _]) -> ok () @@ -77,6 +90,15 @@ let assert_t_list (t:type_value) : unit result = | T_constant ("list", [_]) -> ok () | _ -> simple_fail "assert: not a list" +let assert_t_operation (t:type_value) : unit result = + match t.type_value' with + | T_constant ("operation" , []) -> ok () + | _ -> simple_fail "assert: not an operation" + +let assert_t_list_operation (t : type_value) : unit result = + let%bind t' = get_t_list t in + assert_t_operation t' + let assert_t_int : type_value -> unit result = fun t -> match t.type_value' with | T_constant ("int", []) -> ok () | _ -> simple_fail "not an int" @@ -146,6 +168,14 @@ let get_a_bool (t:annotated_expression) = | E_literal (Literal_bool b) -> ok b | _ -> simple_fail "not a bool" +let get_declaration_by_name : program -> string -> declaration result = fun p name -> + let aux : declaration -> bool = fun declaration -> + match declaration with + | Declaration_constant d -> d.name = name + in + trace_option (simple_error "no declaration with given name") @@ + List.find_opt aux @@ List.map Location.unwrap p + open Environment let env_sum_type ?(env = full_empty) ?(name = "a_sum_type") diff --git a/src/ligo/ast_typed/misc.ml b/src/ligo/ast_typed/misc.ml index f4c28145a..81e6418e7 100644 --- a/src/ligo/ast_typed/misc.ml +++ b/src/ligo/ast_typed/misc.ml @@ -85,12 +85,16 @@ module Free_variables = struct let (_ , frees) = block' b bl in frees + and matching_variant_case : type a . (bindings -> a -> bindings) -> bindings -> ((constructor_name * name) * a) -> bindings = fun f b ((_,n),c) -> + f (union (singleton n) b) c + and matching : type a . (bindings -> a -> bindings) -> bindings -> a matching -> bindings = fun f b m -> match m with | Match_bool { match_true = t ; match_false = fa } -> union (f b t) (f b fa) | Match_list { match_nil = n ; match_cons = (hd, tl, c) } -> union (f b n) (f (union (of_list [hd ; tl]) b) c) | Match_option { match_none = n ; match_some = ((opt, _), s) } -> union (f b n) (f (union (singleton opt) b) s) - | Match_tuple (lst, a) -> f (union (of_list lst) b) a + | Match_tuple (lst , a) -> f (union (of_list lst) b) a + | Match_variant (lst , _) -> unions @@ List.map (matching_variant_case f b) lst and matching_expression = fun x -> matching annotated_expression x diff --git a/src/ligo/ast_typed/types.ml b/src/ligo/ast_typed/types.ml index d226c2c5c..a9b4bd1aa 100644 --- a/src/ligo/ast_typed/types.ml +++ b/src/ligo/ast_typed/types.ml @@ -6,6 +6,7 @@ module SMap = Map.String type name = string type type_name = string +type constructor_name = string type 'a name_map = 'a SMap.t type 'a type_name_map = 'a SMap.t @@ -47,7 +48,7 @@ and type_value' = | T_sum of tv_map | T_record of tv_map | T_constant of type_name * tv list - | T_function of tv * tv + | T_function of (tv * tv) and type_value = { type_value' : type_value' ; @@ -128,7 +129,8 @@ and 'a matching = match_none : 'a ; match_some : (name * type_value) * 'a ; } - | Match_tuple of name list * 'a + | Match_tuple of (name list * 'a) + | Match_variant of (((constructor_name * name) * 'a) list * type_value) and matching_instr = b matching diff --git a/src/ligo/bin/cli.ml b/src/ligo/bin/cli.ml index 2c1cd6ffa..64ca6bbe9 100644 --- a/src/ligo/bin/cli.ml +++ b/src/ligo/bin/cli.ml @@ -13,22 +13,37 @@ let main () = then simple_fail "Pass a command" else ok () in let command = Sys.argv.(1) in - (* Format.printf "Processing command %s (%d)\n" command l ; *) match command with | "compile" -> ( - let%bind () = - if l <> 4 - then simple_fail "Bad number of argument to compile" - else ok () in - let source = Sys.argv.(2) in - let entry_point = Sys.argv.(3) in - (* Format.printf "Compiling %s from %s\n%!" entry_point source ; *) - let%bind michelson = - trace (simple_error "compile michelson") @@ - Ligo.compile_file source entry_point in - Format.printf "Program : %a\n" Micheline.Michelson.pp michelson ; - ok () + let sub_command = Sys.argv.(2) in + match sub_command with + | "file" -> ( + let%bind () = + trace_strong (simple_error "bad number of args") @@ + Assert.assert_equal_int 5 l in + let source = Sys.argv.(3) in + let entry_point = Sys.argv.(4) in + let%bind contract = + trace (simple_error "compile michelson") @@ + Ligo.Contract.compile_contract_file source entry_point in + Format.printf "Contract:\n%s\n" contract ; + ok () + ) + | "expression" -> ( + let%bind () = + trace_strong (simple_error "bad number of args") @@ + Assert.assert_equal_int 6 l in + let source = Sys.argv.(3) in + let entry_point = Sys.argv.(4) in + let expression = Sys.argv.(5) in + let%bind value = + trace (simple_error "compile expression") @@ + Ligo.Contract.compile_contract_parameter source entry_point expression in + Format.printf "Input:\n%s\n" value; + ok () + ) + | _ -> simple_fail "Bad sub-command" ) - | _ -> simple_fail "Bad command" + | _ -> simple_fail "Bad command" let () = toplevel @@ main () diff --git a/src/ligo/compiler/compiler.ml b/src/ligo/compiler/compiler.ml index 1a306f0dc..fbdd8942a 100644 --- a/src/ligo/compiler/compiler.ml +++ b/src/ligo/compiler/compiler.ml @@ -2,3 +2,5 @@ module Uncompiler = Uncompiler module Program = Compiler_program module Type = Compiler_type module Environment = Compiler_environment + +include Program diff --git a/src/ligo/compiler/compiler_program.ml b/src/ligo/compiler/compiler_program.ml index 44f27a73f..ef4f661f0 100644 --- a/src/ligo/compiler/compiler_program.ml +++ b/src/ligo/compiler/compiler_program.ml @@ -10,7 +10,7 @@ open Memory_proto_alpha.Script_ir_translator open Operators.Compiler -let get_predicate : string -> expression list -> predicate result = fun s lst -> +let get_predicate : string -> type_value -> expression list -> predicate result = fun s ty lst -> match Map.String.find_opt s Operators.Compiler.predicates with | Some x -> ok x | None -> ( @@ -23,6 +23,18 @@ let get_predicate : string -> expression list -> predicate result = fun s lst -> | _ -> simple_fail "mini_c . MAP_REMOVE" in let%bind v_ty = Compiler_type.type_ v in ok @@ simple_binary @@ seq [dip (i_none v_ty) ; prim I_UPDATE ] + | "LEFT" -> + let%bind r = match lst with + | [ _ ] -> get_t_right ty + | _ -> simple_fail "mini_c . LEFT" in + let%bind r_ty = Compiler_type.type_ r in + ok @@ simple_unary @@ prim ~children:[r_ty] I_LEFT + | "RIGHT" -> + let%bind l = match lst with + | [ _ ] -> get_t_left ty + | _ -> simple_fail "mini_c . RIGHT" in + let%bind l_ty = Compiler_type.type_ l in + ok @@ simple_unary @@ prim ~children:[l_ty] I_RIGHT | x -> simple_fail ("predicate \"" ^ x ^ "\" doesn't exist") ) @@ -181,7 +193,7 @@ and translate_expression ?(first=false) (expr:expression) : michelson result = let first = first && i = 0 in translate_expression ~first e in bind_list @@ List.mapi aux lst in - let%bind predicate = get_predicate str lst in + let%bind predicate = get_predicate str ty lst in let%bind code = match (predicate, List.length lst) with | Constant c, 0 -> ok @@ virtual_push_first @@ seq @@ lst' @ [ c ; @@ -264,6 +276,58 @@ and translate_expression ?(first=false) (expr:expression) : michelson result = ]) in return code ) + | E_if_none (c, n, (_ , s)) -> ( + let%bind c' = translate_expression c in + let%bind n' = translate_expression n in + let%bind s' = translate_expression s in + let%bind restrict = Compiler_environment.to_michelson_restrict s.environment in + let%bind code = ok (seq [ + c' ; i_unpair ; + i_if_none n' (seq [ + i_pair ; + s' ; + restrict ; + ]) + ; + ]) in + return code + ) + | E_if_left (c, (_ , l), (_ , r)) -> ( + let%bind c' = translate_expression c in + let%bind l' = translate_expression l in + let%bind r' = translate_expression r in + let%bind restrict_l = Compiler_environment.to_michelson_restrict l.environment in + let%bind restrict_r = Compiler_environment.to_michelson_restrict r.environment in + let%bind code = ok (seq [ + c' ; i_unpair ; + i_if_none (seq [ + i_pair ; + l' ; + i_unpair ; + dip restrict_l ; + ]) (seq [ + i_pair ; + r' ; + i_unpair ; + dip restrict_r ; + ]) + ; + ]) in + return code + ) + | E_let_in (_, expr , body) -> ( + let%bind expr' = translate_expression expr in + let%bind body' = translate_expression body in + let%bind restrict = Compiler_environment.to_michelson_restrict body.environment in + let%bind code = ok (seq [ + expr' ; + i_unpair ; + i_swap ; dip i_pair ; + body' ; + restrict ; + ]) in + return code + ) in ok code @@ -277,7 +341,7 @@ and translate_statement ((s', w_env) as s:statement) : michelson result = | S_environment_restrict -> Compiler_environment.to_michelson_restrict w_env.pre_environment | S_environment_add _ -> - simple_fail "not ready yet" + simple_fail "add not ready yet" (* | S_environment_add (name, tv) -> * Environment.to_michelson_add (name, tv) w_env.pre_environment *) | S_declaration (s, expr) -> @@ -490,7 +554,7 @@ type compiled_program = { body : michelson ; } -let translate_program (p:program) (entry:string) : compiled_program result = +let get_main : program -> string -> anon_function_content result = fun p entry -> let is_main (((name , expr), _):toplevel_statement) = match Combinators.Expression.(get_content expr , get_type expr)with | (E_function f , T_function _) @@ -505,12 +569,25 @@ let translate_program (p:program) (entry:string) : compiled_program result = trace_option (simple_error "no functional entry") @@ Tezos_utils.List.find_map is_main p in + ok main + +let translate_program (p:program) (entry:string) : compiled_program result = + let%bind main = get_main p entry in let {input;output} : anon_function_content = main in let%bind body = translate_quote_body main in let%bind input = Compiler_type.Ty.type_ input in let%bind output = Compiler_type.Ty.type_ output in ok ({input;output;body}:compiled_program) +let translate_contract : program -> string -> michelson result = fun p e -> + let%bind main = get_main p e in + let%bind (param_ty , storage_ty) = Combinators.get_t_pair main.input in + let%bind param_michelson = Compiler_type.type_ param_ty in + let%bind storage_michelson = Compiler_type.type_ storage_ty in + let%bind { body = code } = translate_program p e in + let contract = Michelson.contract param_michelson storage_michelson code in + ok contract + let translate_entry (p:anon_function) : compiled_program result = let {input;output} : anon_function_content = p.content in let%bind body = diff --git a/src/ligo/contracts/match.ligo b/src/ligo/contracts/match.ligo index 32ea91625..57a74d7dd 100644 --- a/src/ligo/contracts/match.ligo +++ b/src/ligo/contracts/match.ligo @@ -12,7 +12,7 @@ function match_option (const o : option(int)) : int is begin case o of | None -> skip - | Some(s) -> skip // result := s + | Some(s) -> result := s end end with result @@ -22,3 +22,10 @@ function match_expr_bool (const i : int) : int is | True -> 42 | False -> 0 end + +function match_expr_option (const o : option(int)) : int is + begin skip end with + case o of + | None -> 42 + | Some(s) -> s + end diff --git a/src/ligo/contracts/super-counter.ligo b/src/ligo/contracts/super-counter.ligo new file mode 100644 index 000000000..c8f053d18 --- /dev/null +++ b/src/ligo/contracts/super-counter.ligo @@ -0,0 +1,10 @@ +type action = +| Increment of int +| Decrement of int + +function main (const p : action ; const s : int) : (list(operation) * int) is + block {skip} with ((nil : operation), + match p with + | Increment n -> s + n + | Decrement n -> s - n + end) diff --git a/src/ligo/contracts/variant.ligo b/src/ligo/contracts/variant.ligo new file mode 100644 index 000000000..4ccb21418 --- /dev/null +++ b/src/ligo/contracts/variant.ligo @@ -0,0 +1,13 @@ +type foobar is +| Foo of int +| Bar of bool + +const foo : foobar = Foo (42) + +const bar : foobar = Bar (True) + +function fb(const p : foobar) : int is + block { skip } with (case p of + | Foo (n) -> n + | Bar (t) -> 42 + end) diff --git a/src/ligo/main/contract.ml b/src/ligo/main/contract.ml index 57434b8df..795bb2a7c 100644 --- a/src/ligo/main/contract.ml +++ b/src/ligo/main/contract.ml @@ -14,3 +14,112 @@ include struct trace_strong (simple_error "no entry-point with given name") @@ Assert.assert_true @@ List.exists aux @@ List.map Location.unwrap program end + +include struct + open Ast_typed + open Combinators + + let assert_entry_point_type : type_value -> unit result = fun t -> + let%bind (arg , result) = + trace_strong (simple_error "entry-point doesn't have a function type") @@ + get_t_function t in + let%bind (_ , storage_param) = + trace_strong (simple_error "entry-point doesn't have 2 parameters") @@ + get_t_pair arg in + let%bind (ops , storage_result) = + trace_strong (simple_error "entry-point doesn't have 2 results") @@ + get_t_pair result in + let%bind () = + trace_strong (simple_error "entry-point doesn't have a list of operation as first result") @@ + assert_t_list_operation ops in + let%bind () = + trace_strong (simple_error "entry-point doesn't identitcal type (storage) for second parameter and second result") @@ + assert_type_value_eq (storage_param , storage_result) in + ok () + + let assert_valid_entry_point : program -> string -> unit result = fun p e -> + let%bind declaration = get_declaration_by_name p e in + match declaration with + | Declaration_constant d -> assert_entry_point_type d.annotated_expression.type_annotation +end + +let transpile_value + (e:Ast_typed.annotated_expression) : Mini_c.value result = + let%bind f = + let open Transpiler in + let (f, t) = functionalize e in + let%bind main = translate_main f t in + ok main + in + + let input = Mini_c.Combinators.d_unit in + let%bind r = Run_mini_c.run_entry f input in + ok r + +let compile_contract_file : string -> string -> string result = fun source entry_point -> + let%bind raw = + trace (simple_error "parsing") @@ + Parser.parse_file source in + let%bind simplified = + trace (simple_error "simplifying") @@ + Simplify.Pascaligo.simpl_program raw in + let%bind () = + assert_entry_point_defined simplified entry_point in + let%bind typed = + trace (simple_error "typing") @@ + Typer.type_program simplified in + let%bind () = + assert_valid_entry_point typed entry_point in + let%bind mini_c = + trace (simple_error "transpiling") @@ + Transpiler.translate_program typed in + let%bind michelson = + trace (simple_error "compiling") @@ + Compiler.translate_contract mini_c entry_point in + let str = + Format.asprintf "%a" Micheline.Michelson.pp michelson in + ok str + +let compile_contract_parameter : string -> string -> string -> string result = fun source entry_point expression -> + let%bind parameter_tv = + let%bind raw = + trace (simple_error "parsing file") @@ + Parser.parse_file source in + let%bind simplified = + trace (simple_error "simplifying file") @@ + Simplify.Pascaligo.simpl_program raw in + let%bind () = + assert_entry_point_defined simplified entry_point in + let%bind typed = + trace (simple_error "typing file") @@ + Typer.type_program simplified in + let%bind () = + assert_valid_entry_point typed entry_point in + let%bind declaration = Ast_typed.Combinators.get_declaration_by_name typed entry_point in + match declaration with + | Declaration_constant d -> ok d.annotated_expression.type_annotation + in + let%bind expr = + let%bind raw = + trace (simple_error "parsing expression") @@ + Parser.parse_expression expression in + let%bind simplified = + trace (simple_error "simplifying expression") @@ + Simplify.Pascaligo.simpl_expression raw in + let%bind typed = + trace (simple_error "typing expression") @@ + Typer.type_annotated_expression Ast_typed.Environment.full_empty simplified in + let%bind () = + trace (simple_error "expression type doesn't match type parameter") @@ + Ast_typed.assert_type_value_eq (parameter_tv , typed.type_annotation) in + let%bind mini_c = + trace (simple_error "transpiling expression") @@ + transpile_value typed in + let%bind michelson = + trace (simple_error "compiling expression") @@ + Compiler.translate_value mini_c in + let str = + Format.asprintf "%a" Micheline.Michelson.pp michelson in + ok str + in + ok expr diff --git a/src/ligo/main/main.ml b/src/ligo/main/main.ml index df9cfeb67..bc45dd51f 100644 --- a/src/ligo/main/main.ml +++ b/src/ligo/main/main.ml @@ -178,3 +178,5 @@ let compile_file (source: string) (entry_point:string) : Micheline.Michelson.t r trace (simple_error "compiling") @@ compile mini_c entry_point in ok michelson + +module Contract = Contract diff --git a/src/ligo/mini_c/PP.ml b/src/ligo/mini_c/PP.ml index fdcf39524..df09d281e 100644 --- a/src/ligo/mini_c/PP.ml +++ b/src/ligo/mini_c/PP.ml @@ -72,14 +72,19 @@ and expression' ppf (e:expression') = match e with | E_empty_list _ -> fprintf ppf "list[]" | E_make_none _ -> fprintf ppf "none" | E_Cond (c, a, b) -> fprintf ppf "%a ? %a : %a" expression c expression a expression b + | E_if_none (c, n, ((name, _) , s)) -> fprintf ppf "%a ?? %a : %s -> %a" expression c expression n name expression s + | E_if_left (c, ((name_l, _) , l), ((name_r, _) , r)) -> + fprintf ppf "%a ?? %s -> %a : %s -> %a" expression c name_l expression l name_r expression r + | E_let_in ((name , _) , expr , body) -> + fprintf ppf "let %s = %a in %a" name expression expr expression body and expression : _ -> expression -> _ = fun ppf e -> - expression' ppf (Combinators.Expression.get_content e) + expression' ppf e.content and expression_with_type : _ -> expression -> _ = fun ppf e -> fprintf ppf "%a : %a" - expression' (Combinators.Expression.get_content e) - type_ (Combinators.Expression.get_type e) + expression' e.content + type_ e.type_value and function_ ppf ({binder ; input ; output ; body ; result ; capture_type}:anon_function_content) = fprintf ppf "fun[%s] (%s:%a) : %a %a return %a" diff --git a/src/ligo/mini_c/combinators.ml b/src/ligo/mini_c/combinators.ml index 53ceaf8de..e40c27efb 100644 --- a/src/ligo/mini_c/combinators.ml +++ b/src/ligo/mini_c/combinators.ml @@ -95,6 +95,19 @@ let get_or (v:value) = match v with | D_right b -> ok (true, b) | _ -> simple_fail "not a left/right" +let wrong_type name t = + let title () = "not a " ^ name in + let content () = Format.asprintf "%a" PP.type_ t in + error title content + +let get_t_left t = match t with + | T_or (a , _) -> ok a + | _ -> fail @@ wrong_type "union" t + +let get_t_right t = match t with + | T_or (_ , b) -> ok b + | _ -> fail @@ wrong_type "union" t + let get_last_statement ((b', _):block) : statement result = let aux lst = match lst with | [] -> simple_fail "get_last: empty list" @@ -107,6 +120,7 @@ let t_nat : type_value = T_base Base_nat let t_function x y : type_value = T_function ( x , y ) let t_shallow_closure x y z : type_value = T_shallow_closure ( x , y , z ) let t_pair x y : type_value = T_pair ( x , y ) +let t_union x y : type_value = T_or ( x , y ) let quote binder input output body result : anon_function = let content : anon_function_content = { diff --git a/src/ligo/mini_c/mini_c.ml b/src/ligo/mini_c/mini_c.ml index c919abaae..5f4e9f5a2 100644 --- a/src/ligo/mini_c/mini_c.ml +++ b/src/ligo/mini_c/mini_c.ml @@ -6,4 +6,5 @@ module Combinators = struct include Combinators include Combinators_smart end +include Combinators module Environment = Environment diff --git a/src/ligo/mini_c/types.ml b/src/ligo/mini_c/types.ml index 5be6bb02a..3ba6a7571 100644 --- a/src/ligo/mini_c/types.ml +++ b/src/ligo/mini_c/types.ml @@ -64,6 +64,9 @@ and expression' = | E_empty_list of type_value | E_make_none of type_value | E_Cond of expression * expression * expression + | E_if_none of expression * expression * ((var_name * type_value) * expression) + | E_if_left of expression * ((var_name * type_value) * expression) * ((var_name * type_value) * expression) + | E_let_in of ((var_name * type_value) * expression * expression) and expression = { content : expression' ; diff --git a/src/ligo/parser/pascaligo/AST.ml b/src/ligo/parser/pascaligo/AST.ml index 6b89d2434..0a7b05375 100644 --- a/src/ligo/parser/pascaligo/AST.ml +++ b/src/ligo/parser/pascaligo/AST.ml @@ -646,6 +646,7 @@ and arguments = tuple_injection and pattern = PCons of (pattern, cons) nsepseq reg +| PConstr of (constr * pattern reg) reg | PVar of Lexer.lexeme reg | PWild of wild | PInt of (Lexer.lexeme * Z.t) reg @@ -792,6 +793,7 @@ let pattern_to_region = function | PList Sugar {region; _} | PList PNil region | PList Raw {region; _} +| PConstr {region; _} | PTuple {region; _} -> region let local_decl_to_region = function diff --git a/src/ligo/parser/pascaligo/AST.mli b/src/ligo/parser/pascaligo/AST.mli index 6901c2607..92ad6829d 100644 --- a/src/ligo/parser/pascaligo/AST.mli +++ b/src/ligo/parser/pascaligo/AST.mli @@ -630,6 +630,7 @@ and arguments = tuple_injection and pattern = PCons of (pattern, cons) nsepseq reg +| PConstr of (constr * pattern reg) reg | PVar of Lexer.lexeme reg | PWild of wild | PInt of (Lexer.lexeme * Z.t) reg diff --git a/src/ligo/parser/pascaligo/Parser.mly b/src/ligo/parser/pascaligo/Parser.mly index e22e6e2a7..43209aa8f 100644 --- a/src/ligo/parser/pascaligo/Parser.mly +++ b/src/ligo/parser/pascaligo/Parser.mly @@ -197,9 +197,9 @@ type_tuple: par(nsepseq(type_expr,COMMA)) { $1 } sum_type: - nsepseq(variant,VBAR) { - let region = nsepseq_to_region (fun x -> x.region) $1 - in {region; value = $1}} + option(VBAR) nsepseq(variant,VBAR) { + let region = nsepseq_to_region (fun x -> x.region) $2 + in {region; value = $2}} variant: Constr Of cartesian { @@ -1092,6 +1092,7 @@ core_pattern: | C_None { PNone $1 } | list_patt { PList $1 } | tuple_patt { PTuple $1 } +| constr_patt { PConstr $1 } | C_Some par(core_pattern) { let region = cover $1 $2.region in PSome {region; value = $1,$2}} @@ -1106,3 +1107,13 @@ cons_pattern: tuple_patt: par(nsepseq(core_pattern,COMMA)) { $1 } + +constr_patt: + Constr core_pattern { + let second = + let region = pattern_to_region $2 in + {region; value=$2} + in + let region = cover $1.region second.region in + let value = ($1 , second) in + {region; value}} diff --git a/src/ligo/parser/pascaligo/ParserLog.ml b/src/ligo/parser/pascaligo/ParserLog.ml index f78edc7a2..08ea20431 100644 --- a/src/ligo/parser/pascaligo/ParserLog.ml +++ b/src/ligo/parser/pascaligo/ParserLog.ml @@ -682,6 +682,12 @@ and print_pattern = function | PSome psome -> print_psome psome | PList pattern -> print_list_pattern pattern | PTuple ptuple -> print_ptuple ptuple +| PConstr pattern -> print_constr_pattern pattern + +and print_constr_pattern {value; _} = + let (constr, args) = value in + print_constr constr ; + print_pattern args.value ; and print_psome {value; _} = let c_Some, patterns = value in diff --git a/src/ligo/parser/pascaligo/ParserLog.mli b/src/ligo/parser/pascaligo/ParserLog.mli index 9211b081a..637a15438 100644 --- a/src/ligo/parser/pascaligo/ParserLog.mli +++ b/src/ligo/parser/pascaligo/ParserLog.mli @@ -6,3 +6,4 @@ val mode : [`Byte | `Point] ref val print_tokens : AST.t -> unit val print_path : AST.path -> unit +val print_pattern : AST.pattern -> unit diff --git a/src/ligo/simplify/pascaligo.ml b/src/ligo/simplify/pascaligo.ml index 517eb83ef..7657d39f9 100644 --- a/src/ligo/simplify/pascaligo.ml +++ b/src/ligo/simplify/pascaligo.ml @@ -483,29 +483,52 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t - let open Raw in let get_var (t:Raw.pattern) = match t with | PVar v -> ok v.value - | _ -> simple_fail "not a var" + | _ -> + let error = + let title () = "not a var" in + let content () = Format.asprintf "%a" (PP_helpers.printer Parser.Pascaligo.ParserLog.print_pattern) t in + error title content + in + fail error in - let%bind _assert = - trace_strong (simple_error "only pattern with two cases supported now") @@ - Assert.assert_equal_int 2 (List.length t) in - let ((pa, ba), (pb, bb)) = List.(hd t, hd @@ tl t) in - let uncons p = match p with - | PCons {value = (hd, _)} -> ok hd - | _ -> simple_fail "uncons fail" in - let%bind (pa, pb) = bind_map_pair uncons (pa, pb) in - match (pa, ba), (pb, bb) with - | (PFalse _, f), (PTrue _, t) - | (PTrue _, t), (PFalse _, f) -> ok @@ Match_bool {match_true = t ; match_false = f} - | (PSome v, some), (PNone _, none) - | (PNone _, none), (PSome v, some) -> ( + let get_tuple (t:Raw.pattern) = match t with + | PCons v -> npseq_to_list v.value + | PTuple v -> npseq_to_list v.value.inside + | x -> [ x ] + in + let get_single (t:Raw.pattern) = + let t' = get_tuple t in + let%bind () = + trace_strong (simple_error "not single") @@ + Assert.assert_list_size t' 1 in + ok (List.hd t') in + let get_constr (t:Raw.pattern) = match t with + | PConstr v -> + let%bind var = get_single (snd v.value).value >>? get_var in + ok ((fst v.value).value , var) + | _ -> simple_fail "not a constr" + in + let%bind patterns = + let aux (x , y) = + let xs = get_tuple x in + trace_strong (simple_error "no tuple in patterns yet") @@ + Assert.assert_list_size xs 1 >>? fun () -> + ok (List.hd xs , y) + in + bind_map_list aux t in + match patterns with + | [(PFalse _ , f) ; (PTrue _ , t)] + | [(PTrue _ , t) ; (PFalse _ , f)] -> ok @@ Match_bool {match_true = t ; match_false = f} + | [(PSome v , some) ; (PNone _ , none)] + | [(PNone _ , none) ; (PSome v , some)] -> ( let (_, v) = v.value in let%bind v = match v.value.inside with | PVar v -> ok v.value | _ -> simple_fail "complex none patterns not supported yet" in ok @@ Match_option {match_none = none ; match_some = (v, some) } ) - | (PCons c, cons), (PList (PNil _), nil) - | (PList (PNil _), nil), (PCons c, cons) -> + | [(PCons c , cons) ; (PList (PNil _) , nil)] + | [(PList (PNil _) , nil) ; (PCons c, cons)] -> let%bind (a, b) = match c.value with | a, [(_, b)] -> @@ -515,9 +538,21 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t - | _ -> simple_fail "complex list patterns not supported yet" in ok @@ Match_list {match_cons = (a, b, cons) ; match_nil = nil} - | _ -> - let error () = simple_error "multi-level patterns not supported yet" () in - fail error + | lst -> + trace (simple_error "weird patterns not supported yet") @@ + let%bind constrs = + let aux (x , y) = + let error = + let title () = "Pattern" in + let content () = + Format.asprintf "Pattern : %a" (PP_helpers.printer Parser.Pascaligo.ParserLog.print_pattern) x in + error title content in + let%bind x' = + trace error @@ + get_constr x in + ok (x' , y) in + bind_map_list aux lst in + ok @@ Match_variant constrs and simpl_instruction_block : Raw.instruction -> block result = fun t -> match t with diff --git a/src/ligo/test/integration_tests.ml b/src/ligo/test/integration_tests.ml index b5c9ab633..70b0ee14a 100644 --- a/src/ligo/test/integration_tests.ml +++ b/src/ligo/test/integration_tests.ml @@ -14,6 +14,20 @@ let complex_function () : unit result = let make_expect = fun n -> (3 * n + 2) in expect_n_int program "main" make_expect +let variant () : unit result = + let%bind program = type_file "./contracts/variant.ligo" in + let%bind () = + let expected = e_a_constructor "Foo" (e_a_int 42) in + expect_evaluate program "foo" expected in + let%bind () = + let expected = e_a_constructor "Bar" (e_a_bool true) in + expect_evaluate program "bar" expected in + (* let%bind () = + * let make_expect = fun n -> (3 * n + 2) in + * expect_n_int program "fb" make_expect + * in *) + ok () + let closure () : unit result = let%bind program = type_file "./contracts/closure.ligo" in let%bind () = @@ -257,12 +271,29 @@ let matching () : unit result = let input = match n with | Some s -> e_a_some (e_a_int s) | None -> e_a_none t_int in - let expected = e_a_int 23 in + let expected = e_a_int (match n with + | Some s -> s + | None -> 23) in + trace (simple_error (Format.asprintf "on input %a" PP_helpers.(option int) n)) @@ expect program "match_option" input expected in bind_iter_list aux [Some 0 ; Some 2 ; Some 42 ; Some 163 ; Some (-1) ; None] in + let%bind () = + let aux n = + let input = match n with + | Some s -> e_a_some (e_a_int s) + | None -> e_a_none t_int in + let expected = e_a_int (match n with + | Some s -> s + | None -> 42) in + trace (simple_error (Format.asprintf "on input %a" PP_helpers.(option int) n)) @@ + expect program "match_expr_option" input expected + in + bind_iter_list aux + [Some 0 ; Some 2 ; Some 42 ; Some 163 ; Some (-1) ; None] + in ok () let declarations () : unit result = @@ -292,6 +323,7 @@ let counter_contract () : unit result = let main = "Integration (End to End)", [ test "function" function_ ; test "complex function" complex_function ; + test "variant" variant ; test "closure" closure ; test "shared function" shared_function ; test "shadow" shadow ; diff --git a/src/ligo/test/test_helpers.ml b/src/ligo/test/test_helpers.ml index bb266e469..3012790b3 100644 --- a/src/ligo/test/test_helpers.ml +++ b/src/ligo/test/test_helpers.ml @@ -32,10 +32,12 @@ let expect_evaluate program entry_point expected = Ast_simplified.assert_value_eq (expected , result) let expect_n_aux lst program entry_point make_input make_expected = + Format.printf "expect_n aux\n%!" ; let aux n = let input = make_input n in let expected = make_expected n in - expect program entry_point input expected + let result = expect program entry_point input expected in + result in let%bind _ = bind_map_list aux lst in ok () diff --git a/src/ligo/transpiler/transpiler.ml b/src/ligo/transpiler/transpiler.ml index 2a0c63365..f95cd48b9 100644 --- a/src/ligo/transpiler/transpiler.ml +++ b/src/ligo/transpiler/transpiler.ml @@ -70,7 +70,7 @@ let tuple_access_to_lr : type_value -> type_value list -> int -> (type_value * [ let lr_path = List.map (fun b -> if b then `Right else `Left) path in let%bind (_ , lst) = let aux = fun (ty , acc) cur -> - let%bind (a , b) = get_t_pair ty in + let%bind (a , b) = Mini_c.get_t_pair ty in match cur with | `Left -> ok (a , (a , `Left) :: acc) | `Right -> ok (b , (b , `Right) :: acc) in @@ -89,10 +89,10 @@ let record_access_to_lr : type_value -> type_value AST.type_name_map -> string - let node a b : (type_value * (type_value * [`Left | `Right]) list) result = match%bind bind_lr (a, b) with | `Left (t, acc) -> - let%bind (a, _) = get_t_pair t in + let%bind (a, _) = Mini_c.get_t_pair t in ok @@ (t, (a, `Left) :: acc) | `Right (t, acc) -> ( - let%bind (_, b) = get_t_pair t in + let%bind (_, b) = Mini_c.get_t_pair t in ok @@ (t, (b, `Right) :: acc) ) in let error_content () = @@ -195,6 +195,10 @@ and transpile_environment : AST.full_environment -> Environment.t result = fun x let%bind nlst = bind_map_ne_list transpile_small_environment x in ok @@ List.Ne.to_list nlst +and tree_of_sum : AST.type_value -> (type_name * AST.type_value) Append_tree.t result = fun t -> + let%bind map_tv = get_t_sum t in + ok @@ Append_tree.of_list @@ kv_list_of_map map_tv + and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_expression) : expression result = let%bind tv = translate_type ae.type_annotation in let return ?(tv = tv) expr = @@ -213,10 +217,9 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express let%bind b = translate_annotated_expression env b in return @@ E_application (a, b) | E_constructor (m, param) -> - let%bind param' = translate_annotated_expression env ae in + let%bind param' = translate_annotated_expression env param in let (param'_expr , param'_tv) = Combinators.Expression.(get_content param' , get_type param') in - let%bind map_tv = get_t_sum ae.type_annotation in - let node_tv = Append_tree.of_list @@ kv_list_of_map map_tv in + let%bind node_tv = tree_of_sum ae.type_annotation in let leaf (k, tv) : (expression' option * type_value) result = if k = m then ( let%bind _ = @@ -297,11 +300,11 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express let node (a:expression result) b : expression result = match%bind bind_lr (a, b) with | `Left expr -> ( - let%bind (tv, _) = get_t_pair @@ Combinators.Expression.get_type expr in + let%bind (tv, _) = Mini_c.get_t_pair @@ Expression.get_type expr in return ~tv @@ E_constant ("CAR", [expr]) ) | `Right expr -> ( - let%bind (_, tv) = get_t_pair @@ Combinators.Expression.get_type expr in + let%bind (_, tv) = Mini_c.get_t_pair @@ Expression.get_type expr in return ~tv @@ E_constant ("CDR", [expr]) ) in let%bind expr = @@ -341,13 +344,74 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express | E_matching (expr, m) -> ( let%bind expr' = translate_annotated_expression env expr in match m with - | AST.Match_bool {match_true ; match_false} -> - let%bind (t, f) = bind_map_pair (translate_annotated_expression env) (match_true, match_false) in + | Match_bool {match_true ; match_false} -> + let%bind (t , f) = bind_map_pair (translate_annotated_expression env) (match_true, match_false) in return @@ E_Cond (expr', t, f) - | AST.Match_list _ | AST.Match_option _ | AST.Match_tuple (_, _) -> - simple_fail "only match bool exprs are translated yet" + | Match_option { match_none; match_some = ((name, tv), s) } -> + let%bind n = translate_annotated_expression env match_none in + let%bind (tv' , s') = + let%bind tv' = translate_type tv in + let env' = Environment.(add (name , tv') @@ extend env) in + let%bind s' = translate_annotated_expression env' s in + ok (tv' , s') in + return @@ E_if_none (expr' , n , ((name , tv') , s')) + | Match_variant (lst , variant) -> ( + let%bind tree = tree_of_sum variant in + let%bind tree' = match tree with + | Empty -> simple_fail "match empty variant" + | Full x -> ok x in + let%bind tree'' = + let rec aux t = + match (t : _ Append_tree.t') with + | Leaf (name , tv) -> + let%bind tv' = translate_type tv in + ok (`Leaf name , tv') + | Node {a ; b} -> + let%bind a' = aux a in + let%bind b' = aux b in + let tv' = Mini_c.t_union (snd a') (snd b') in + ok (`Node (a' , b') , tv') + in aux tree' + in + + let rec aux acc t = + let top = + match acc with + | None -> expr' + | Some x -> x in + match t with + | ((`Leaf constructor_name) , tv) -> ( + let%bind ((_ , name) , body) = + trace_option (simple_error "not supposed to happen here: missing match clause") @@ + List.find_opt (fun ((constructor_name' , _) , _) -> constructor_name' = constructor_name) lst in + let env' = Environment.(add (name , tv) @@ extend env) in + let%bind body' = translate_annotated_expression env' body in + return @@ E_let_in ((name , tv) , top , body') + ) + | ((`Node (a , b)) , tv) -> + let%bind a' = + let%bind a_ty = get_t_left tv in + let a_var = "left" , a_ty in + let env' = Environment.(add a_var @@ extend env) in + let%bind e = aux (Some (Expression.make (E_variable "left") a_ty env')) a in + ok (a_var , e) + in + let%bind b' = + let%bind b_ty = get_t_right tv in + let b_var = "right" , b_ty in + let env' = Environment.(add b_var @@ extend env) in + let%bind e = aux (Some (Expression.make (E_variable "right") b_ty env')) b in + ok (b_var , e) + in + return @@ E_if_left (top , a' , b') + in + aux None tree'' + ) + | AST.Match_list _ | AST.Match_tuple (_, _) -> + simple_fail "only match bool and option exprs are translated yet" ) + and translate_lambda_shallow : Mini_c.Environment.t -> AST.lambda -> Mini_c.expression result = fun env l -> let { binder ; input_type ; output_type ; body ; result } : AST.lambda = l in (* Shallow capture. Capture the whole environment. Extend it with a new scope. Append it the input. *) @@ -448,8 +512,10 @@ let translate_entry (lst:AST.program) (name:string) : anon_function result = @@ aux [] lst in ok (lst', l, tv) in let l' = {l with body = lst' @ l.body} in - trace (simple_error "translating entry") - @@ translate_main l' tv + let r = + trace (simple_error "translating entry") @@ + translate_main l' tv in + r open Combinators diff --git a/src/ligo/typer/typer.ml b/src/ligo/typer/typer.ml index 1206cf8c8..290c421e1 100644 --- a/src/ligo/typer/typer.ml +++ b/src/ligo/typer/typer.ml @@ -189,6 +189,50 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t let e' = List.fold_left aux e lst' in let%bind b' = f e' b in ok (O.Match_tuple (lst, b')) + | Match_variant lst -> + let%bind variant_opt = + let aux acc ((constructor_name , _) , _) = + let%bind (_ , variant) = + trace_option (simple_error "bad constructor") @@ + Environment.get_constructor constructor_name e in + let%bind acc = match acc with + | None -> ok (Some variant) + | Some variant' -> ( + Ast_typed.assert_type_value_eq (variant , variant') >>? fun () -> + ok (Some variant) + ) in + ok acc in + trace (simple_error "in match variant") @@ + bind_fold_list aux None lst in + let%bind variant = + trace_option (simple_error "empty variant") @@ + variant_opt in + let%bind () = + let%bind variant_cases' = Ast_typed.Combinators.get_t_sum variant in + let variant_cases = List.map fst @@ Map.String.to_kv_list variant_cases' in + let match_cases = List.map (Function.compose fst fst) lst in + let test_case = fun c -> + Assert.assert_true (List.mem c match_cases) + in + let%bind () = + trace (simple_error "missing case match") @@ + bind_iter_list test_case variant_cases in + let%bind () = + trace_strong (simple_error "redundant case match") @@ + Assert.assert_true List.(length variant_cases = length match_cases) in + ok () + in + let%bind lst' = + let aux ((constructor_name , name) , b) = + let%bind (constructor , _) = + trace_option (simple_error "bad constructor??") @@ + Environment.get_constructor constructor_name e in + let e' = Environment.add_ez name constructor e in + let%bind b' = f e' b in + ok ((constructor_name , name) , b') + in + bind_map_list aux lst in + ok (O.Match_variant (lst' , variant)) and evaluate_type (e:environment) (t:I.type_expression) : O.type_value result = let return tv' = ok (make_t tv' (Some t)) in @@ -387,12 +431,26 @@ and type_annotated_expression : environment -> I.annotated_expression -> O.annot | E_matching (ex, m) -> ( let%bind ex' = type_annotated_expression e ex in let%bind m' = type_match type_annotated_expression e ex'.type_annotation m in - let%bind tv = match m' with - | Match_bool {match_true ; match_false} -> - let%bind _ = O.assert_type_value_eq (match_true.type_annotation, match_false.type_annotation) in - ok match_true.type_annotation - | _ -> simple_fail "can only type match_bool expressions yet" in - return (E_matching (ex' , m')) tv + let tvs = + let aux (cur:O.value O.matching) = + match cur with + | Match_bool { match_true ; match_false } -> [ match_true ; match_false ] + | Match_list { match_nil ; match_cons = (_ , _ , match_cons) } -> [ match_nil ; match_cons ] + | Match_option { match_none ; match_some = (_ , match_some) } -> [ match_none ; match_some ] + | Match_tuple (_ , match_tuple) -> [ match_tuple ] + | Match_variant (lst , _) -> List.map snd lst in + List.map get_type_annotation @@ aux m' in + let aux prec cur = + let%bind () = + match prec with + | None -> ok () + | Some cur' -> Ast_typed.assert_type_value_eq (cur , cur') in + ok (Some cur) in + let%bind tv_opt = bind_fold_list aux None tvs in + let%bind tv = + trace_option (simple_error "empty matching") @@ + tv_opt in + return (O.E_matching (ex', m')) tv ) and type_constant (name:string) (lst:O.type_value list) (tv_opt:O.type_value option) : (string * O.type_value) result = @@ -551,3 +609,9 @@ and untype_matching : type o i . (o -> i result) -> o O.matching -> (i I.matchin let%bind cons = f cons in let match_cons = hd, tl, cons in ok @@ Match_list {match_nil ; match_cons} + | Match_variant (lst , _) -> + let aux ((a,b),c) = + let%bind c' = f c in + ok ((a,b),c') in + let%bind lst' = bind_map_list aux lst in + ok @@ Match_variant lst' From 0aa01ddcd8122c608da74208bcb43dbf95cb84c5 Mon Sep 17 00:00:00 2001 From: Galfour Date: Mon, 22 Apr 2019 18:56:13 +0000 Subject: [PATCH 07/15] add variant expression pattern-matching --- src/ligo/ast_typed/PP.ml | 2 +- src/ligo/ast_typed/combinators.ml | 2 +- src/ligo/ast_typed/types.ml | 4 ++-- src/ligo/compiler/compiler_program.ml | 13 +++++++------ src/ligo/contracts/variant-matching.ligo | 9 +++++++++ src/ligo/contracts/variant.ligo | 5 ----- src/ligo/main/contract.ml | 4 ++-- src/ligo/main/main.ml | 8 +++++++- src/ligo/test/integration_tests.ml | 14 ++++++++++---- src/ligo/transpiler/transpiler.ml | 18 +++++++++--------- src/ligo/typer/typer.ml | 2 +- 11 files changed, 49 insertions(+), 32 deletions(-) create mode 100644 src/ligo/contracts/variant-matching.ligo diff --git a/src/ligo/ast_typed/PP.ml b/src/ligo/ast_typed/PP.ml index d319ae0ed..60ddf7b3c 100644 --- a/src/ligo/ast_typed/PP.ml +++ b/src/ligo/ast_typed/PP.ml @@ -103,7 +103,7 @@ and instruction ppf (i:instruction) = match i with let declaration ppf (d:declaration) = match d with - | Declaration_constant {name ; annotated_expression = ae} -> + | Declaration_constant ({name ; annotated_expression = ae} , _) -> fprintf ppf "const %s = %a" name annotated_expression ae let program ppf (p:program) = diff --git a/src/ligo/ast_typed/combinators.ml b/src/ligo/ast_typed/combinators.ml index 5caa7193c..1391fa29b 100644 --- a/src/ligo/ast_typed/combinators.ml +++ b/src/ligo/ast_typed/combinators.ml @@ -171,7 +171,7 @@ let get_a_bool (t:annotated_expression) = let get_declaration_by_name : program -> string -> declaration result = fun p name -> let aux : declaration -> bool = fun declaration -> match declaration with - | Declaration_constant d -> d.name = name + | Declaration_constant (d , _) -> d.name = name in trace_option (simple_error "no declaration with given name") @@ List.find_opt aux @@ List.map Location.unwrap p diff --git a/src/ligo/ast_typed/types.ml b/src/ligo/ast_typed/types.ml index a9b4bd1aa..37ca73937 100644 --- a/src/ligo/ast_typed/types.ml +++ b/src/ligo/ast_typed/types.ml @@ -14,7 +14,7 @@ type 'a type_name_map = 'a SMap.t type program = declaration Location.wrap list and declaration = - | Declaration_constant of named_expression + | Declaration_constant of (named_expression * full_environment) (* | Macro_declaration of macro_declaration *) and environment_element = { @@ -141,7 +141,7 @@ open Trace let get_entry (p:program) (entry : string) : annotated_expression result = let aux (d:declaration) = match d with - | Declaration_constant {name ; annotated_expression} when entry = name -> Some annotated_expression + | Declaration_constant ({name ; annotated_expression} , _) when entry = name -> Some annotated_expression | Declaration_constant _ -> None in let%bind result = diff --git a/src/ligo/compiler/compiler_program.ml b/src/ligo/compiler/compiler_program.ml index ef4f661f0..3e77c6f95 100644 --- a/src/ligo/compiler/compiler_program.ml +++ b/src/ligo/compiler/compiler_program.ml @@ -300,15 +300,15 @@ and translate_expression ?(first=false) (expr:expression) : michelson result = let%bind restrict_r = Compiler_environment.to_michelson_restrict r.environment in let%bind code = ok (seq [ c' ; i_unpair ; - i_if_none (seq [ - i_pair ; + i_if_left (seq [ + i_swap ; dip i_pair ; l' ; - i_unpair ; + i_comment "restrict left" ; dip restrict_l ; ]) (seq [ - i_pair ; + i_swap ; dip i_pair ; r' ; - i_unpair ; + i_comment "restrict right" ; dip restrict_r ; ]) ; @@ -324,7 +324,8 @@ and translate_expression ?(first=false) (expr:expression) : michelson result = i_unpair ; i_swap ; dip i_pair ; body' ; - restrict ; + i_comment "restrict let" ; + dip restrict ; ]) in return code ) diff --git a/src/ligo/contracts/variant-matching.ligo b/src/ligo/contracts/variant-matching.ligo new file mode 100644 index 000000000..92e5588d4 --- /dev/null +++ b/src/ligo/contracts/variant-matching.ligo @@ -0,0 +1,9 @@ +type foobar is +| Foo of int +| Bar of bool + +function fb(const p : foobar) : int is + block { skip } with (case p of + | Foo (n) -> n + | Bar (t) -> 42 + end) diff --git a/src/ligo/contracts/variant.ligo b/src/ligo/contracts/variant.ligo index 4ccb21418..b2a306bc8 100644 --- a/src/ligo/contracts/variant.ligo +++ b/src/ligo/contracts/variant.ligo @@ -6,8 +6,3 @@ const foo : foobar = Foo (42) const bar : foobar = Bar (True) -function fb(const p : foobar) : int is - block { skip } with (case p of - | Foo (n) -> n - | Bar (t) -> 42 - end) diff --git a/src/ligo/main/contract.ml b/src/ligo/main/contract.ml index 795bb2a7c..662b828f5 100644 --- a/src/ligo/main/contract.ml +++ b/src/ligo/main/contract.ml @@ -40,7 +40,7 @@ include struct let assert_valid_entry_point : program -> string -> unit result = fun p e -> let%bind declaration = get_declaration_by_name p e in match declaration with - | Declaration_constant d -> assert_entry_point_type d.annotated_expression.type_annotation + | Declaration_constant (d , _) -> assert_entry_point_type d.annotated_expression.type_annotation end let transpile_value @@ -97,7 +97,7 @@ let compile_contract_parameter : string -> string -> string -> string result = f assert_valid_entry_point typed entry_point in let%bind declaration = Ast_typed.Combinators.get_declaration_by_name typed entry_point in match declaration with - | Declaration_constant d -> ok d.annotated_expression.type_annotation + | Declaration_constant (d , _) -> ok d.annotated_expression.type_annotation in let%bind expr = let%bind raw = diff --git a/src/ligo/main/main.ml b/src/ligo/main/main.ml index bc45dd51f..ec6f4bf3a 100644 --- a/src/ligo/main/main.ml +++ b/src/ligo/main/main.ml @@ -126,7 +126,13 @@ let easy_run_typed_simplified Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main.content) ) ; - let%bind typed_value = type_expression input in + let%bind typed_value = + let env = + let last_declaration = Location.unwrap List.(hd @@ rev program) in + match last_declaration with + | Declaration_constant (_ , env) -> env + in + type_expression ~env input in let%bind mini_c_value = transpile_value typed_value in let%bind mini_c_result = diff --git a/src/ligo/test/integration_tests.ml b/src/ligo/test/integration_tests.ml index 70b0ee14a..d29b2fc7f 100644 --- a/src/ligo/test/integration_tests.ml +++ b/src/ligo/test/integration_tests.ml @@ -22,10 +22,15 @@ let variant () : unit result = let%bind () = let expected = e_a_constructor "Bar" (e_a_bool true) in expect_evaluate program "bar" expected in - (* let%bind () = - * let make_expect = fun n -> (3 * n + 2) in - * expect_n_int program "fb" make_expect - * in *) + ok () + +let variant_matching () : unit result = + let%bind program = type_file "./contracts/variant-matching.ligo" in + let%bind () = + let make_input = fun n -> e_a_constructor "Foo" (e_a_int n) in + let make_expected = e_a_int in + expect_n program "fb" make_input make_expected + in ok () let closure () : unit result = @@ -324,6 +329,7 @@ let main = "Integration (End to End)", [ test "function" function_ ; test "complex function" complex_function ; test "variant" variant ; + test "variant matching" variant_matching ; test "closure" closure ; test "shared function" shared_function ; test "shadow" shadow ; diff --git a/src/ligo/transpiler/transpiler.ml b/src/ligo/transpiler/transpiler.ml index f95cd48b9..008e467c5 100644 --- a/src/ligo/transpiler/transpiler.ml +++ b/src/ligo/transpiler/transpiler.ml @@ -201,7 +201,7 @@ and tree_of_sum : AST.type_value -> (type_name * AST.type_value) Append_tree.t r and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_expression) : expression result = let%bind tv = translate_type ae.type_annotation in - let return ?(tv = tv) expr = + let return ?(tv = tv) ?(env = env) expr = (* let%bind env' = transpile_environment ae.environment in *) ok @@ Combinators.Expression.make_tpl (expr, tv, env) in let f = translate_annotated_expression env in @@ -374,7 +374,7 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express in aux tree' in - let rec aux acc t = + let rec aux (acc , env) t = let top = match acc with | None -> expr' @@ -386,26 +386,26 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express List.find_opt (fun ((constructor_name' , _) , _) -> constructor_name' = constructor_name) lst in let env' = Environment.(add (name , tv) @@ extend env) in let%bind body' = translate_annotated_expression env' body in - return @@ E_let_in ((name , tv) , top , body') + return ~env:env' @@ E_let_in ((name , tv) , top , body') ) | ((`Node (a , b)) , tv) -> let%bind a' = let%bind a_ty = get_t_left tv in let a_var = "left" , a_ty in let env' = Environment.(add a_var @@ extend env) in - let%bind e = aux (Some (Expression.make (E_variable "left") a_ty env')) a in + let%bind e = aux ((Some (Expression.make (E_variable "left") a_ty env')) , env') a in ok (a_var , e) in let%bind b' = let%bind b_ty = get_t_right tv in let b_var = "right" , b_ty in let env' = Environment.(add b_var @@ extend env) in - let%bind e = aux (Some (Expression.make (E_variable "right") b_ty env')) b in + let%bind e = aux ((Some (Expression.make (E_variable "right") b_ty env')) , env') b in ok (b_var , e) in - return @@ E_if_left (top , a' , b') + return ~env @@ E_if_left (top , a' , b') in - aux None tree'' + aux (None , env) tree'' ) | AST.Match_list _ | AST.Match_tuple (_, _) -> simple_fail "only match bool and option exprs are translated yet" @@ -456,7 +456,7 @@ and translate_lambda env l = let translate_declaration env (d:AST.declaration) : toplevel_statement result = match d with - | Declaration_constant {name;annotated_expression} -> + | Declaration_constant ({name;annotated_expression} , _) -> let%bind expression = translate_annotated_expression env annotated_expression in let tv = Combinators.Expression.get_type expression in let env' = Environment.add (name, tv) env in @@ -495,7 +495,7 @@ let translate_entry (lst:AST.program) (name:string) : anon_function result = match lst with | [] -> None | hd :: tl -> ( - let (AST.Declaration_constant an) = temp_unwrap_loc hd in + let (AST.Declaration_constant (an , _)) = temp_unwrap_loc hd in match an.name = name with | true -> ( match an.annotated_expression.expression with diff --git a/src/ligo/typer/typer.ml b/src/ligo/typer/typer.ml index 290c421e1..5ff000b37 100644 --- a/src/ligo/typer/typer.ml +++ b/src/ligo/typer/typer.ml @@ -74,7 +74,7 @@ and type_declaration env : I.declaration -> (environment * O.declaration option) trace (constant_declaration_error name annotated_expression) @@ type_annotated_expression env annotated_expression in let env' = Environment.add_ez name ae'.type_annotation env in - ok (env', Some (O.Declaration_constant (make_n_e name ae'))) + ok (env', Some (O.Declaration_constant ((make_n_e name ae') , env'))) and type_block_full (e:environment) (b:I.block) : (O.block * environment) result = let aux (e, acc:(environment * O.instruction list)) (i:I.instruction) = From 1814d8cbfafe928bf9d7234ece4a144c8636219b Mon Sep 17 00:00:00 2001 From: Galfour Date: Tue, 23 Apr 2019 07:12:11 +0000 Subject: [PATCH 08/15] add super-counter --- src/ligo/contracts/super-counter.ligo | 4 ++-- src/ligo/main/contract.ml | 31 ++++++++++++++++----------- src/ligo/test/integration_tests.ml | 11 ++++++++++ src/ligo/transpiler/transpiler.ml | 2 +- 4 files changed, 33 insertions(+), 15 deletions(-) diff --git a/src/ligo/contracts/super-counter.ligo b/src/ligo/contracts/super-counter.ligo index c8f053d18..beb73a5a9 100644 --- a/src/ligo/contracts/super-counter.ligo +++ b/src/ligo/contracts/super-counter.ligo @@ -1,10 +1,10 @@ -type action = +type action is | Increment of int | Decrement of int function main (const p : action ; const s : int) : (list(operation) * int) is block {skip} with ((nil : operation), - match p with + case p of | Increment n -> s + n | Decrement n -> s - n end) diff --git a/src/ligo/main/contract.ml b/src/ligo/main/contract.ml index 662b828f5..ac35890d1 100644 --- a/src/ligo/main/contract.ml +++ b/src/ligo/main/contract.ml @@ -19,11 +19,11 @@ include struct open Ast_typed open Combinators - let assert_entry_point_type : type_value -> unit result = fun t -> + let get_entry_point_type : type_value -> (type_value * type_value) result = fun t -> let%bind (arg , result) = trace_strong (simple_error "entry-point doesn't have a function type") @@ get_t_function t in - let%bind (_ , storage_param) = + let%bind (arg' , storage_param) = trace_strong (simple_error "entry-point doesn't have 2 parameters") @@ get_t_pair arg in let%bind (ops , storage_result) = @@ -35,12 +35,16 @@ include struct let%bind () = trace_strong (simple_error "entry-point doesn't identitcal type (storage) for second parameter and second result") @@ assert_type_value_eq (storage_param , storage_result) in - ok () + ok (arg' , storage_param) - let assert_valid_entry_point : program -> string -> unit result = fun p e -> + let get_entry_point : program -> string -> (type_value * type_value) result = fun p e -> let%bind declaration = get_declaration_by_name p e in match declaration with - | Declaration_constant (d , _) -> assert_entry_point_type d.annotated_expression.type_annotation + | Declaration_constant (d , _) -> get_entry_point_type d.annotated_expression.type_annotation + + let assert_valid_entry_point = fun p e -> + let%bind _ = get_entry_point p e in + ok () end let transpile_value @@ -81,7 +85,7 @@ let compile_contract_file : string -> string -> string result = fun source entry ok str let compile_contract_parameter : string -> string -> string -> string result = fun source entry_point expression -> - let%bind parameter_tv = + let%bind (program , parameter_tv) = let%bind raw = trace (simple_error "parsing file") @@ Parser.parse_file source in @@ -93,11 +97,9 @@ let compile_contract_parameter : string -> string -> string -> string result = f let%bind typed = trace (simple_error "typing file") @@ Typer.type_program simplified in - let%bind () = - assert_valid_entry_point typed entry_point in - let%bind declaration = Ast_typed.Combinators.get_declaration_by_name typed entry_point in - match declaration with - | Declaration_constant (d , _) -> ok d.annotated_expression.type_annotation + let%bind (param_ty , _) = + get_entry_point typed entry_point in + ok (typed , param_ty) in let%bind expr = let%bind raw = @@ -107,8 +109,13 @@ let compile_contract_parameter : string -> string -> string -> string result = f trace (simple_error "simplifying expression") @@ Simplify.Pascaligo.simpl_expression raw in let%bind typed = + let env = + let last_declaration = Location.unwrap List.(hd @@ rev program) in + match last_declaration with + | Declaration_constant (_ , env) -> env + in trace (simple_error "typing expression") @@ - Typer.type_annotated_expression Ast_typed.Environment.full_empty simplified in + Typer.type_annotated_expression env simplified in let%bind () = trace (simple_error "expression type doesn't match type parameter") @@ Ast_typed.assert_type_value_eq (parameter_tv , typed.type_annotation) in diff --git a/src/ligo/test/integration_tests.ml b/src/ligo/test/integration_tests.ml index d29b2fc7f..a393e4510 100644 --- a/src/ligo/test/integration_tests.ml +++ b/src/ligo/test/integration_tests.ml @@ -325,6 +325,16 @@ let counter_contract () : unit result = let make_expected = fun n -> e_a_pair (e_a_list [] t_operation) (e_a_int (42 + n)) in expect_n program "main" make_input make_expected +let super_counter_contract () : unit result = + let%bind program = type_file "./contracts/super-counter.ligo" in + let make_input = fun n -> + let action = if n mod 2 = 0 then "Increment" else "Decrement" in + e_a_pair (e_a_constructor action (e_a_int n)) (e_a_int 42) in + let make_expected = fun n -> + let op = if n mod 2 = 0 then (+) else (-) in + e_a_pair (e_a_list [] t_operation) (e_a_int (op 42 n)) in + expect_n program "main" make_input make_expected + let main = "Integration (End to End)", [ test "function" function_ ; test "complex function" complex_function ; @@ -350,5 +360,6 @@ let main = "Integration (End to End)", [ test "quote declarations" quote_declarations ; test "#include directives" include_ ; test "counter contract" counter_contract ; + test "super counter contract" super_counter_contract ; test "higher order" higher_order ; ] diff --git a/src/ligo/transpiler/transpiler.ml b/src/ligo/transpiler/transpiler.ml index 008e467c5..89467701c 100644 --- a/src/ligo/transpiler/transpiler.ml +++ b/src/ligo/transpiler/transpiler.ml @@ -386,7 +386,7 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express List.find_opt (fun ((constructor_name' , _) , _) -> constructor_name' = constructor_name) lst in let env' = Environment.(add (name , tv) @@ extend env) in let%bind body' = translate_annotated_expression env' body in - return ~env:env' @@ E_let_in ((name , tv) , top , body') + return ~env @@ E_let_in ((name , tv) , top , body') ) | ((`Node (a , b)) , tv) -> let%bind a' = From 097c5ca0fb17a3d0d93629487837b90c83c51974 Mon Sep 17 00:00:00 2001 From: Galfour Date: Tue, 23 Apr 2019 07:30:43 +0000 Subject: [PATCH 09/15] change bin display --- src/lib_utils/x_tezos_micheline.ml | 8 ++++++++ src/ligo/main/contract.ml | 4 ++-- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/src/lib_utils/x_tezos_micheline.ml b/src/lib_utils/x_tezos_micheline.ml index ff497414f..1f2656c03 100644 --- a/src/lib_utils/x_tezos_micheline.ml +++ b/src/lib_utils/x_tezos_micheline.ml @@ -54,6 +54,7 @@ module Michelson = struct let i_if a b = prim ~children:[a;b] I_IF let i_if_none a b = prim ~children:[a;b] I_IF_NONE + let i_if_left a b = prim ~children:[a;b] I_IF_LEFT let i_failwith = prim I_FAILWITH let i_assert_some = i_if_none (seq [i_failwith]) (seq []) @@ -78,6 +79,13 @@ module Michelson = struct let node = printable string_of_prim canonical in print_expr ppf node + let pp_stripped ppf (michelson:michelson) = + let open Micheline_printer in + let michelson' = strip_nops @@ strip_annots michelson in + let canonical = strip_locations michelson' in + let node = printable string_of_prim canonical in + print_expr ppf node + let pp_naked ppf m = let naked = strip_annots m in pp ppf naked diff --git a/src/ligo/main/contract.ml b/src/ligo/main/contract.ml index ac35890d1..98d673483 100644 --- a/src/ligo/main/contract.ml +++ b/src/ligo/main/contract.ml @@ -81,7 +81,7 @@ let compile_contract_file : string -> string -> string result = fun source entry trace (simple_error "compiling") @@ Compiler.translate_contract mini_c entry_point in let str = - Format.asprintf "%a" Micheline.Michelson.pp michelson in + Format.asprintf "%a" Micheline.Michelson.pp_stripped michelson in ok str let compile_contract_parameter : string -> string -> string -> string result = fun source entry_point expression -> @@ -126,7 +126,7 @@ let compile_contract_parameter : string -> string -> string -> string result = f trace (simple_error "compiling expression") @@ Compiler.translate_value mini_c in let str = - Format.asprintf "%a" Micheline.Michelson.pp michelson in + Format.asprintf "%a" Micheline.Michelson.pp_stripped michelson in ok str in ok expr From 4dc231956f1bc29fe700223cb8801e753b98b722 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Tue, 23 Apr 2019 13:59:10 +0200 Subject: [PATCH 10/15] Missing build-time dependency: rsync --- .gitlab-ci.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index bb790d8bc..fe984eaa2 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -1,6 +1,7 @@ before_script: - apt-get update -qq - - apt-get -y -qq install libhidapi-dev libcap-dev libev-dev bubblewrap + # rsync is needed by opam to sync a package installed from a local directory with the copy in ~/.opam + - apt-get -y -qq install rsync libhidapi-dev libcap-dev libev-dev bubblewrap - wget https://github.com/ocaml/opam/releases/download/2.0.1/opam-2.0.1-x86_64-linux -O opam-2.0.1-x86_64-linux - cp opam-2.0.1-x86_64-linux /usr/local/bin/opam - chmod +x /usr/local/bin/opam From ff4804269f2b30b033f1f8007b14d04be7a6c1ce Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Tue, 23 Apr 2019 14:28:06 +0200 Subject: [PATCH 11/15] Missing dependency: alcotest --- src/ligo/ligo.opam | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/ligo/ligo.opam b/src/ligo/ligo.opam index b57c739bf..963bc0338 100644 --- a/src/ligo/ligo.opam +++ b/src/ligo/ligo.opam @@ -1,3 +1,4 @@ +name: "ligo" opam-version: "2.0" version: "1.0" maintainer: "gabriel.alfour@gmail.com" @@ -15,9 +16,11 @@ depends: [ "tezos-utils" "getopt" "yojson" + "alcotest" { test } ] build: [ [ "dune" "build" "-p" name "-j" jobs ] + # needed in the repository, but must not be present in the local ligo.opam [ "mv" "src/ligo/ligo.install" "." ] ] url { From b57a06de8ad6e05177c7dfbd68ff337abd78bddf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Tue, 23 Apr 2019 14:43:36 +0200 Subject: [PATCH 12/15] Removed dependency on getopt. Explicitly list modules in pascaligo, excluded the Mains and LexerLog --- src/ligo/ligo.opam | 1 - src/ligo/parser/pascaligo/dune | 22 +++++++++++----------- 2 files changed, 11 insertions(+), 12 deletions(-) diff --git a/src/ligo/ligo.opam b/src/ligo/ligo.opam index 963bc0338..b9ba9a104 100644 --- a/src/ligo/ligo.opam +++ b/src/ligo/ligo.opam @@ -14,7 +14,6 @@ depends: [ "menhir" "ppx_let" "tezos-utils" - "getopt" "yojson" "alcotest" { test } ] diff --git a/src/ligo/parser/pascaligo/dune b/src/ligo/parser/pascaligo/dune index f256b66d8..0e8044728 100644 --- a/src/ligo/parser/pascaligo/dune +++ b/src/ligo/parser/pascaligo/dune @@ -9,9 +9,9 @@ (library (name parser_pascaligo) (public_name ligo.parser.pascaligo) + (modules AST FQueue Markup pascaligo Utils Version Lexer Error Parser ParserLog LexToken) (modules_without_implementation Error) (libraries - getopt hex str uutf @@ -23,17 +23,17 @@ ;; 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. ;; Pour le purger, il faut faire "dune clean". -(rule - (targets Parser.exe) - (deps ParserMain.exe) - (action (copy ParserMain.exe Parser.exe)) - (mode promote-until-clean)) +;(rule +; (targets Parser.exe) +; (deps ParserMain.exe) +; (action (copy ParserMain.exe Parser.exe)) +; (mode promote-until-clean)) -(rule - (targets Lexer.exe) - (deps LexerMain.exe) - (action (copy LexerMain.exe Lexer.exe)) - (mode promote-until-clean)) +;(rule +; (targets Lexer.exe) +; (deps LexerMain.exe) +; (action (copy LexerMain.exe Lexer.exe)) +; (mode promote-until-clean)) (rule (targets Version.ml) From 6d9334a60dcd3c338f34a485470d77ab2b3e9380 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Tue, 23 Apr 2019 15:28:02 +0200 Subject: [PATCH 13/15] opam install --build-test to install the test-only dependencies --- .gitlab-ci.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index fe984eaa2..de00490bb 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -20,8 +20,8 @@ before_script: default-job: script: - - (cd src/lib_utils && ls -a && opam install -y --working-dir .) - - (cd src/ligo && ls -a && opam install -y --working-dir .) + - (cd src/lib_utils && ls -a && opam install -y --build-test --working-dir .) + - (cd src/ligo && ls -a && opam install -y --build-test --working-dir .) - (cd src/ligo && ls -a && dune build && dune build -p ligo && dune build @ligo-test) artifacts: paths: From eb20191704839720417309217ade92d566385ef6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Tue, 23 Apr 2019 16:26:09 +0200 Subject: [PATCH 14/15] Conditional for tests is 'with-test', not 'test'. --- .gitlab-ci.yml | 11 ++++++++--- src/ligo/ligo.opam | 2 +- 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index de00490bb..e005feae6 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -20,9 +20,9 @@ before_script: default-job: script: - - (cd src/lib_utils && ls -a && opam install -y --build-test --working-dir .) - - (cd src/ligo && ls -a && opam install -y --build-test --working-dir .) - - (cd src/ligo && ls -a && dune build && dune build -p ligo && dune build @ligo-test) + - (cd src/lib_utils && opam install -y --build-test --working-dir .) + - (cd src/ligo && opam install -y --build-test --working-dir .) + - (cd src/ligo && dune build && dune build -p ligo && dune build @ligo-test) artifacts: paths: - src/ligo/bin/cli.ml @@ -31,3 +31,8 @@ default-job: install-from-repo-job: script: - opam install -y ligo + # Used in the IDE + #- opam install -y user-setup + #- opam install -y merlin + #- opam install -y ocp-indent + #- opam user-setup install diff --git a/src/ligo/ligo.opam b/src/ligo/ligo.opam index b9ba9a104..1797dad77 100644 --- a/src/ligo/ligo.opam +++ b/src/ligo/ligo.opam @@ -15,7 +15,7 @@ depends: [ "ppx_let" "tezos-utils" "yojson" - "alcotest" { test } + "alcotest" { with-test } ] build: [ [ "dune" "build" "-p" name "-j" jobs ] From ba9b8c4a68a1c0bf98b0d50b18fab686790e784b Mon Sep 17 00:00:00 2001 From: Galfour Date: Tue, 23 Apr 2019 15:17:28 +0000 Subject: [PATCH 15/15] make better cli --- src/ligo/bin/cli.ml | 105 +++++++++++++++++++++++++++----------------- src/ligo/bin/dune | 1 + 2 files changed, 66 insertions(+), 40 deletions(-) diff --git a/src/ligo/bin/cli.ml b/src/ligo/bin/cli.ml index 64ca6bbe9..fffef2bb7 100644 --- a/src/ligo/bin/cli.ml +++ b/src/ligo/bin/cli.ml @@ -1,3 +1,4 @@ +open Cmdliner open Trace let toplevel x = @@ -6,44 +7,68 @@ let toplevel x = | Errors ss -> Format.printf "Errors: %a\n%!" errors_pp @@ List.map (fun f -> f()) ss -let main () = - let l = Array.length Sys.argv in - let%bind () = - if l < 2 - then simple_fail "Pass a command" - else ok () in - let command = Sys.argv.(1) in - match command with - | "compile" -> ( - let sub_command = Sys.argv.(2) in - match sub_command with - | "file" -> ( - let%bind () = - trace_strong (simple_error "bad number of args") @@ - Assert.assert_equal_int 5 l in - let source = Sys.argv.(3) in - let entry_point = Sys.argv.(4) in - let%bind contract = - trace (simple_error "compile michelson") @@ - Ligo.Contract.compile_contract_file source entry_point in - Format.printf "Contract:\n%s\n" contract ; - ok () - ) - | "expression" -> ( - let%bind () = - trace_strong (simple_error "bad number of args") @@ - Assert.assert_equal_int 6 l in - let source = Sys.argv.(3) in - let entry_point = Sys.argv.(4) in - let expression = Sys.argv.(5) in - let%bind value = - trace (simple_error "compile expression") @@ - Ligo.Contract.compile_contract_parameter source entry_point expression in - Format.printf "Input:\n%s\n" value; - ok () - ) - | _ -> simple_fail "Bad sub-command" - ) - | _ -> simple_fail "Bad command" +let main = + let term = Term.(const print_endline $ const "Ligo needs a command. Do ligo --help") in + (term , Term.info "ligo") -let () = toplevel @@ main () +let compile_file = + let f source entry_point = + toplevel @@ + let%bind contract = + trace (simple_error "compile michelson") @@ + Ligo.Contract.compile_contract_file source entry_point in + Format.printf "Contract:\n%s\n" contract ; + ok () + in + let term = + let source = + let open Arg in + let info = + let docv = "SOURCE_FILE" in + let doc = "$(docv) is the path to the .ligo file of the contract." in + info ~docv ~doc [] in + required @@ pos 0 (some string) None info in + let entry_point = + let open Arg in + let info = + let docv = "ENTRY_POINT" in + let doc = "$(docv) is entry-point that will be compiled." in + info ~docv ~doc [] in + value @@ pos 1 string "main" info in + Term.(const f $ source $ entry_point) in + let docs = "Compile contracts." in + (term , Term.info ~docs "compile-contract") + +let compile_expression = + let f source entry_point expression = + toplevel @@ + let%bind value = + trace (simple_error "compile-input") @@ + Ligo.Contract.compile_contract_parameter source entry_point expression in + Format.printf "Input:\n%s\n" value; + ok () + in + let term = + let source = + let open Arg in + let docv = "SOURCE_FILE" in + let doc = "$(docv) is the path to the .ligo file of the contract." in + let info = info ~docv ~doc [] in + required @@ pos 0 (some string) None info in + let entry_point = + let open Arg in + let docv = "ENTRY_POINT" in + let doc = "$(docv) is the entry-point of the contract." in + let info = info ~docv ~doc [] in + required @@ pos 1 (some string) None info in + let expression = + let open Arg in + let docv = "EXPRESSION" in + let doc = "$(docv) is the expression that will be compiled." in + let info = info ~docv ~doc [] in + required @@ pos 2 (some string) None info in + Term.(const f $ source $ entry_point $ expression) in + let docs = "Compile contracts parameters." in + (term , Term.info ~docs "compile-parameter") + +let () = Term.exit @@ Term.eval_choice main [compile_file ; compile_expression] diff --git a/src/ligo/bin/dune b/src/ligo/bin/dune index 0b50fee28..66ec132b7 100644 --- a/src/ligo/bin/dune +++ b/src/ligo/bin/dune @@ -3,6 +3,7 @@ (public_name ligo) (libraries tezos-utils + cmdliner ligo ) (package ligo)