commit 1edfd8ea061b584a5ae8d45e21edc643ef1e81c8 Author: Galfour Date: Sun May 12 20:56:22 2019 +0000 initial commit diff --git a/.gitignore b/.gitignore new file mode 100644 index 000000000..b49caf123 --- /dev/null +++ b/.gitignore @@ -0,0 +1,6 @@ +_build/* +*/_build +.merlin +*/.merlin +*.install +*/*.install diff --git a/README_INSTALL b/README_INSTALL new file mode 100644 index 000000000..e5dbde280 --- /dev/null +++ b/README_INSTALL @@ -0,0 +1,20 @@ +switch=titi +cd src/ligo +sudo apt -y install libev-dev libhidapi-dev +opam init +eval $(opam env) +opam switch create $switch ocaml-base-compiler.4.06.1 +eval $(opam env --switch=$switch --set-switch) +opam repository add new-tezos https://gitlab.com/gabriel.alfour/new-tezos-opam-repository.git + +# si une build a déjà été tentée, il vaut mieux git add tout ce qui est utile et git clean -dfx pour supprimer tout le reste (dune 1.7 crée des fichiers non compatibles avec dune 1.6) +opam install -y ocplib-endian alcotest + +(cd ligo-parser && opam install -y .) +eval $(opam env) +(cd ligo-helpers && opam install -y .) +eval $(opam env) +(opam install -y .) +eval $(opam env) +opam install merlin ocp-indent ledit +opam user-setup install diff --git a/TODO.txt b/TODO.txt new file mode 100644 index 000000000..210cb0637 --- /dev/null +++ b/TODO.txt @@ -0,0 +1,21 @@ +# Main + +## Back-end + +- Replace Mini_c environments with stacks + + Compiler_environment : bad pack make first element deepest + + Add types to pack and unpack +- Think about Coq + +## Amendments + +- Bubble_n +- Partial application +- Type size limit (1.000 -> 10.000) + +# PPX + +## Deriving + +- Generate ADT helpers (this removes 90% of Combinators and a lot of maintenance when modifying ASTs) +- Generate option helpers (this makes writing main much easier, much like one would in an untyped language) diff --git a/ast_simplified/PP.ml b/ast_simplified/PP.ml new file mode 100644 index 000000000..6eed2f798 --- /dev/null +++ b/ast_simplified/PP.ml @@ -0,0 +1,119 @@ +open Types +open PP_helpers +open Format + +let list_sep_d x ppf lst = match lst with + | [] -> () + | _ -> fprintf ppf "@; @[%a@]@;" (list_sep x (tag "@;")) lst + +let smap_sep_d x ppf m = + if Map.String.is_empty m + then () + else fprintf ppf "@; @[%a@]@;" (smap_sep x (tag "@;")) m + +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_tez n -> fprintf ppf "%dtz" n + | Literal_string s -> fprintf ppf "%S" s + | Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b + | Literal_address s -> fprintf ppf "@%S" s + | Literal_operation _ -> fprintf ppf "Operation(...bytes)" + +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 + | E_failwith ae -> + fprintf ppf "failwith %a" annotated_expression ae + +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 + | Access_map s -> fprintf ppf "(%a)" annotated_expression 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 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) = + fprintf ppf "%s <- %a" p annotated_expression ae + +and single_tuple_patch ppf ((p, ae) : int * ae) = + fprintf ppf "%d <- %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)} -> + 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_do ae -> fprintf ppf "do %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_tuple_patch (name, path, lst) -> fprintf ppf "%s.%a[%a]" name access_path path (list_sep_d single_tuple_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/ast_simplified/ast_simplified.ml b/ast_simplified/ast_simplified.ml new file mode 100644 index 000000000..566e95155 --- /dev/null +++ b/ast_simplified/ast_simplified.ml @@ -0,0 +1,8 @@ +include Types +include Misc +include Combinators + +module Types = Types +module Misc = Misc +module PP = PP +module Combinators = Combinators diff --git a/ast_simplified/combinators.ml b/ast_simplified/combinators.ml new file mode 100644 index 000000000..6744722a6 --- /dev/null +++ b/ast_simplified/combinators.ml @@ -0,0 +1,186 @@ +open Types +open Simple_utils.Trace +module Option = Simple_utils.Option + +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 get_expression (x:annotated_expression) = x.expression + +let i_assignment : _ -> instruction = fun x -> I_assignment x +let named_expression name annotated_expression = { name ; annotated_expression } +let named_typed_expression name expression ty = { name ; annotated_expression = { expression ; type_annotation = Some ty } } +let typed_expression expression ty = { expression ; type_annotation = Some ty } +let untyped_expression expression = { expression ; type_annotation = None } + +let get_untyped_expression : annotated_expression -> expression result = fun ae -> + let%bind () = + trace_strong (simple_error "expression is typed") @@ + Assert.assert_none ae.type_annotation in + ok ae.expression + +let t_bool : type_expression = T_constant ("bool", []) +let t_string : type_expression = T_constant ("string", []) +let t_bytes : type_expression = T_constant ("bytes", []) +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_tez : type_expression = T_constant ("tez", []) +let t_unit : type_expression = T_constant ("unit", []) +let t_address : type_expression = T_constant ("address", []) +let t_option o : type_expression = T_constant ("option", [o]) +let t_list t : type_expression = T_constant ("list", [t]) +let t_variable n : type_expression = T_variable n +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_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 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 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_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_address s : expression = E_literal (Literal_address s) +let e_tez s : expression = E_literal (Literal_tez 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_constructor s a : expression = E_constructor (s , a) +let e_match a b : expression = E_matching (a , b) +let e_match_bool a b c : expression = e_match a (Match_bool {match_true = b ; match_false = c}) +let e_accessor a b = E_accessor (a , b) +let e_accessor_props a b = e_accessor a (List.map (fun x -> Access_record x) b) +let e_variable v = E_variable v +let e_failwith v = E_failwith v + +let e_a_unit : annotated_expression = make_e_a_full (e_unit ()) t_unit +let e_a_string s : annotated_expression = make_e_a_full (e_string s) t_string +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_list lst : annotated_expression = make_e_a (e_list lst) +let e_a_constructor s a : annotated_expression = make_e_a (e_constructor s a) +let e_a_address x = make_e_a_full (e_address x) t_address +let e_a_tez x = make_e_a_full (e_tez x) t_tez + +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_typed_none t_opt = + let type_annotation = t_option t_opt in + make_e_a ~type_annotation e_none + +let e_a_typed_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) + (output_type : type_expression) + (result : expression) + (body : block) + : expression = + E_lambda { + binder = (make_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 (make_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) + + +let get_a_accessor = fun t -> + match t.expression with + | E_accessor (a , b) -> ok (a , b) + | _ -> simple_fail "not an accessor" + +let assert_a_accessor = fun t -> + let%bind _ = get_a_accessor t in + ok () + +let get_access_record : access -> string result = fun a -> + match a with + | Access_tuple _ + | Access_map _ -> simple_fail "not an access record" + | Access_record s -> ok s + +let get_a_pair = fun t -> + match t.expression with + | E_tuple [a ; b] -> ok (a , b) + | _ -> simple_fail "not a pair" + +let get_a_list = fun t -> + match t.expression with + | E_list lst -> ok lst + | _ -> simple_fail "not a pair" diff --git a/ast_simplified/dune b/ast_simplified/dune new file mode 100644 index 000000000..b3a3f0f44 --- /dev/null +++ b/ast_simplified/dune @@ -0,0 +1,12 @@ +(library + (name ast_simplified) + (public_name ligo.ast_simplified) + (libraries + simple-utils + tezos-utils + ) + (preprocess + (pps simple-utils.ppx_let_generalized) + ) + (flags (:standard -open Simple_utils )) +) diff --git a/ast_simplified/misc.ml b/ast_simplified/misc.ml new file mode 100644 index 000000000..843307eed --- /dev/null +++ b/ast_simplified/misc.ml @@ -0,0 +1,258 @@ +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_tez a, Literal_tez b when a = b -> ok () + | Literal_tez _, Literal_tez _ -> simple_fail "different tezs" + | Literal_tez _, _ -> simple_fail "tez vs non-tez" + | 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" + | Literal_address a, Literal_address b when a = b -> ok () + | Literal_address _, Literal_address _ -> simple_fail "different addresss" + | Literal_address _, _ -> simple_fail "address vs non-address" + | Literal_operation _, Literal_operation _ -> simple_fail "can't compare operations" + | Literal_operation _, _ -> simple_fail "operation vs non-operation" + + +let rec assert_value_eq (a, b: (value*value)) : unit result = + let error_content () = + Format.asprintf "\n@[- %a@;- %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 + * + * 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/ast_simplified/types.ml b/ast_simplified/types.ml new file mode 100644 index 000000000..583a13100 --- /dev/null +++ b/ast_simplified/types.ml @@ -0,0 +1,126 @@ +module Map = Simple_utils.Map +module Location = Simple_utils.Location + +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 + +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 value = annotated_expression + +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) + | E_failwith of ae + +and access = + | Access_tuple of int + | Access_record of string + | Access_map of ae + +and access_path = access list + +and literal = + | Literal_unit + | Literal_bool of bool + | Literal_int of int + | Literal_nat of int + | Literal_tez of int + | Literal_string of string + | Literal_bytes of bytes + | Literal_address of string + | Literal_operation of Memory_proto_alpha.Alpha_context.packed_internal_operation + +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_do of ae + | I_record_patch of (name * access_path * (string * ae) list) + | I_tuple_patch of (name * access_path * (int * 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 + | Match_variant of ((constructor_name * name) * 'a) list + +and matching_instr = b matching + +and matching_expr = annotated_expression matching diff --git a/ast_typed/PP.ml b/ast_typed/PP.ml new file mode 100644 index 000000000..35bc1101e --- /dev/null +++ b/ast_typed/PP.ml @@ -0,0 +1,115 @@ +open Types +open Format +open PP_helpers + +let list_sep_d x = list_sep x (const " , ") +let smap_sep_d x = smap_sep x (const " , ") + + +let rec type_value' ppf (tv':type_value') : unit = + match tv' with + | T_tuple lst -> fprintf ppf "tuple[%a]" (list_sep_d type_value) lst + | T_sum m -> fprintf ppf "sum[%a]" (smap_sep_d type_value) m + | T_record m -> fprintf ppf "record[%a]" (smap_sep_d type_value) m + | T_function (a, b) -> fprintf ppf "%a -> %a" type_value a type_value b + | T_constant (c, []) -> fprintf ppf "%s" c + | T_constant (c, n) -> fprintf ppf "%s(%a)" c (list_sep_d type_value) n + +and type_value ppf (tv:type_value) : unit = + type_value' ppf tv.type_value' + +let rec annotated_expression ppf (ae:annotated_expression) : unit = + match ae.type_annotation.simplified with + | Some _ -> fprintf ppf "@[%a:%a@]" expression ae.expression type_value ae.type_annotation + | _ -> fprintf ppf "@[%a@]" expression ae.expression + +and lambda ppf l = + let {binder;input_type;output_type;result;body} = l in + fprintf ppf "lambda (%s:%a) : %a {@; @[%a@]@;} return %a" + binder type_value input_type type_value output_type + block body annotated_expression result + +and expression ppf (e:expression) : unit = + match e with + | E_literal l -> literal ppf l + | E_constant (c, lst) -> fprintf ppf "%s(%a)" c (list_sep_d annotated_expression) lst + | E_constructor (c, lst) -> fprintf ppf "%s(%a)" c annotated_expression lst + | E_variable a -> fprintf ppf "%s" a + | E_application (f, arg) -> fprintf ppf "(%a) (%a)" annotated_expression f annotated_expression arg + | E_lambda l -> fprintf ppf "%a" lambda l + | E_tuple_accessor (ae, i) -> fprintf ppf "%a.%d" annotated_expression ae i + | E_record_accessor (ae, s) -> fprintf ppf "%a.%s" annotated_expression ae s + | E_tuple lst -> fprintf ppf "tuple[@; @[%a@]@;]" (list_sep annotated_expression (tag ",@;")) lst + | E_record m -> fprintf ppf "record[%a]" (smap_sep_d annotated_expression) m + | E_map m -> fprintf ppf "map[@; @[%a@]@;]" (list_sep assoc_annotated_expression (tag ",@;")) m + | E_list m -> fprintf ppf "list[@; @[%a@]@;]" (list_sep annotated_expression (tag ",@;")) m + | E_look_up (ds, i) -> fprintf ppf "(%a)[%a]" annotated_expression ds annotated_expression i + | E_matching (ae, m) -> + fprintf ppf "match %a with %a" annotated_expression ae (matching annotated_expression) m + | E_failwith ae -> fprintf ppf "failwith %a" annotated_expression ae + +and value ppf v = annotated_expression ppf v + +and assoc_annotated_expression ppf : (ae * ae) -> unit = fun (a, b) -> + fprintf ppf "%a -> %a" annotated_expression a annotated_expression b + +and literal ppf (l:literal) : unit = + 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_tez n -> fprintf ppf "%dtz" n + | Literal_string s -> fprintf ppf "%s" s + | Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b + | Literal_address s -> fprintf ppf "@%s" s + | Literal_operation _ -> fprintf ppf "Operation(...bytes)" + +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)} -> + 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 (fst some) f match_some + +and pre_access ppf (a:access) = match a with + | Access_record n -> fprintf ppf ".%s" n + | Access_tuple i -> fprintf ppf ".%d" i + | Access_map n -> fprintf ppf ".%a" annotated_expression n + +and instruction ppf (i:instruction) = match i with + | I_skip -> fprintf ppf "skip" + | I_do ae -> fprintf ppf "do %a" annotated_expression ae + | I_loop (cond, b) -> fprintf ppf "while (%a) {@; @[%a@]@;}" annotated_expression cond block b + | I_declaration {name;annotated_expression = ae} -> + fprintf ppf "let %s = %a" name annotated_expression ae + | 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 + | I_patch (s, p, e) -> + fprintf ppf "%s%a := %a" + s.type_name (fun ppf -> List.iter (pre_access ppf)) p + annotated_expression e + +let declaration ppf (d:declaration) = + match d with + | 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/ast_typed/ast_typed.ml b/ast_typed/ast_typed.ml new file mode 100644 index 000000000..f01780254 --- /dev/null +++ b/ast_typed/ast_typed.ml @@ -0,0 +1,12 @@ +module Types = Types +module Environment = Environment +module PP = PP +module Combinators = struct + include Combinators + include Combinators_environment +end +module Misc = Misc + +include Types +include Misc +include Combinators diff --git a/ast_typed/combinators.ml b/ast_typed/combinators.ml new file mode 100644 index 000000000..0aa3cfcd8 --- /dev/null +++ b/ast_typed/combinators.ml @@ -0,0 +1,213 @@ +open Trace +open Types + +let make_t type_value' simplified = { type_value' ; simplified } +let make_a_e expression type_annotation environment = { expression ; type_annotation ; dummy_field = () ; environment } +let make_n_e name a_e = { name ; annotated_expression = a_e } + +let t_bool ?s () : type_value = make_t (T_constant ("bool", [])) s +let t_string ?s () : type_value = make_t (T_constant ("string", [])) s +let t_bytes ?s () : type_value = make_t (T_constant ("bytes", [])) s +let t_int ?s () : type_value = make_t (T_constant ("int", [])) s +let t_address ?s () : type_value = make_t (T_constant ("address", [])) s +let t_operation ?s () : type_value = make_t (T_constant ("operation", [])) s +let t_nat ?s () : type_value = make_t (T_constant ("nat", [])) s +let t_tez ?s () : type_value = make_t (T_constant ("tez", [])) s +let t_unit ?s () : type_value = make_t (T_constant ("unit", [])) s +let t_option o ?s () : type_value = make_t (T_constant ("option", [o])) s +let t_tuple lst ?s () : type_value = make_t (T_tuple lst) s +let t_list t ?s () : type_value = make_t (T_constant ("list", [t])) s +let t_contract t ?s () : type_value = make_t (T_constant ("contract", [t])) s +let t_pair a b ?s () = t_tuple [a ; b] ?s () + + +let t_record m ?s () : type_value = make_t (T_record m) s +let make_t_ez_record (lst:(string * type_value) list) : type_value = + let aux prev (k, v) = SMap.add k v prev in + let map = List.fold_left aux SMap.empty lst in + make_t (T_record map) None +let ez_t_record lst ?s () : type_value = + let m = SMap.of_list lst in + t_record m ?s () + +let t_map key value ?s () = make_t (T_constant ("map", [key ; value])) s + +let t_sum m ?s () : type_value = make_t (T_sum m) s +let make_t_ez_sum (lst:(string * type_value) list) : type_value = + let aux prev (k, v) = SMap.add k v prev in + let map = List.fold_left aux SMap.empty lst in + make_t (T_sum map) None + +let t_function param result ?s () : type_value = make_t (T_function (param, result)) s +let t_shallow_closure param result ?s () : type_value = make_t (T_function (param, result)) s + +let get_type_annotation (x:annotated_expression) = x.type_annotation +let get_type' (x:type_value) = x.type_value' +let get_environment (x:annotated_expression) = x.environment +let get_expression (x:annotated_expression) = x.expression + +let get_t_bool (t:type_value) : unit result = match t.type_value' with + | T_constant ("bool", []) -> ok () + | _ -> simple_fail "not a bool" + +let get_t_unit (t:type_value) : unit result = match t.type_value' with + | T_constant ("unit", []) -> ok () + | _ -> simple_fail "not a unit" + +let get_t_tez (t:type_value) : unit result = match t.type_value' with + | T_constant ("tez", []) -> ok () + | _ -> simple_fail "not a tez" + +let get_t_contract (t:type_value) : type_value result = match t.type_value' with + | T_constant ("contract", [x]) -> ok x + | _ -> simple_fail "not a contract" + +let get_t_option (t:type_value) : type_value result = match t.type_value' with + | T_constant ("option", [o]) -> ok o + | _ -> simple_fail "not a option" + +let get_t_list (t:type_value) : type_value result = match t.type_value' with + | T_constant ("list", [o]) -> ok o + | _ -> simple_fail "not a list" + +let get_t_tuple (t:type_value) : type_value list result = match t.type_value' with + | 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" + +let get_t_record (t:type_value) : type_value SMap.t result = match t.type_value' with + | T_record m -> ok m + | _ -> simple_fail "not a record type" + +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 get_t_map_key : type_value -> type_value result = fun t -> + let%bind (key , _) = get_t_map t in + ok key + +let get_t_map_value : type_value -> type_value result = fun t -> + let%bind (_ , value) = get_t_map t in + ok value + +let assert_t_tez :type_value -> unit result = get_t_tez + +let assert_t_map (t:type_value) : unit result = + match t.type_value' with + | T_constant ("map", [_ ; _]) -> ok () + | _ -> simple_fail "not a map" + +let assert_t_list (t:type_value) : unit result = + match t.type_value' with + | 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" + +let assert_t_nat : type_value -> unit result = fun t -> match t.type_value' with + | T_constant ("nat", []) -> ok () + | _ -> simple_fail "not an nat" + +let assert_t_bool : type_value -> unit result = fun v -> get_t_bool v +let assert_t_unit : type_value -> unit result = fun v -> get_t_unit v + +let e_record map : expression = E_record map +let ez_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 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_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_tez n : expression = E_literal (Literal_tez n) +let e_bool b : expression = E_literal (Literal_bool b) +let e_string s : expression = E_literal (Literal_string s) +let e_address s : expression = E_literal (Literal_address s) +let e_operation s : expression = E_literal (Literal_operation s) +let e_lambda l : expression = E_lambda l +let e_pair a b : expression = E_tuple [a; b] +let e_application a b : expression = E_application (a , b) +let e_variable v : expression = E_variable v +let e_list lst : expression = E_list lst + +let e_a_unit = make_a_e e_unit (t_unit ()) +let e_a_int n = make_a_e (e_int n) (t_int ()) +let e_a_nat n = make_a_e (e_nat n) (t_nat ()) +let e_a_tez n = make_a_e (e_tez n) (t_tez ()) +let e_a_bool b = make_a_e (e_bool b) (t_bool ()) +let e_a_string s = make_a_e (e_string s) (t_string ()) +let e_a_address s = make_a_e (e_address s) (t_address ()) +let e_a_pair a b = make_a_e (e_pair a b) (t_pair a.type_annotation b.type_annotation ()) +let e_a_some s = make_a_e (e_some s) (t_option s.type_annotation ()) +let e_a_lambda l = make_a_e (e_lambda l) (t_function l.input_type l.output_type ()) +let e_a_none t = make_a_e e_none (t_option t ()) +let e_a_tuple lst = make_a_e (E_tuple lst) (t_tuple (List.map get_type_annotation lst) ()) +let e_a_record r = make_a_e (e_record r) (t_record (SMap.map get_type_annotation r) ()) +let e_a_application a b = make_a_e (e_application a b) (get_type_annotation b) +let e_a_variable v ty = make_a_e (e_variable v) ty +let ez_e_a_record r = make_a_e (ez_e_record r) (ez_t_record (List.map (fun (x, y) -> x, y.type_annotation) r) ()) +let e_a_map lst k v = make_a_e (e_map lst) (t_map k v ()) +let e_a_list lst t = make_a_e (e_list lst) (t_list t ()) + +let get_a_int (t:annotated_expression) = + match t.expression with + | E_literal (Literal_int n) -> ok n + | _ -> simple_fail "not an int" + +let get_a_unit (t:annotated_expression) = + match t.expression with + | E_literal (Literal_unit) -> ok () + | _ -> simple_fail "not a unit" + +let get_a_bool (t:annotated_expression) = + match t.expression with + | E_literal (Literal_bool b) -> ok b + | _ -> simple_fail "not a bool" + + +let get_a_record_accessor = fun t -> + match t.expression with + | E_record_accessor (a , b) -> ok (a , b) + | _ -> simple_fail "not an accessor" + +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 + diff --git a/ast_typed/combinators_environment.ml b/ast_typed/combinators_environment.ml new file mode 100644 index 000000000..e8ca37530 --- /dev/null +++ b/ast_typed/combinators_environment.ml @@ -0,0 +1,28 @@ +open Types +open Combinators + +let make_a_e_empty expression type_annotation = make_a_e expression type_annotation Environment.full_empty + +let e_a_empty_unit = e_a_unit Environment.full_empty +let e_a_empty_int n = e_a_int n Environment.full_empty +let e_a_empty_nat n = e_a_nat n Environment.full_empty +let e_a_empty_tez n = e_a_tez n Environment.full_empty +let e_a_empty_bool b = e_a_bool b Environment.full_empty +let e_a_empty_string s = e_a_string s Environment.full_empty +let e_a_empty_address s = e_a_address s Environment.full_empty +let e_a_empty_pair a b = e_a_pair a b Environment.full_empty +let e_a_empty_some s = e_a_some s Environment.full_empty +let e_a_empty_none t = e_a_none t Environment.full_empty +let e_a_empty_tuple lst = e_a_tuple lst Environment.full_empty +let e_a_empty_record r = e_a_record r Environment.full_empty +let e_a_empty_map lst k v = e_a_map lst k v Environment.full_empty +let e_a_empty_list lst t = e_a_list lst t Environment.full_empty +let ez_e_a_empty_record r = ez_e_a_record r Environment.full_empty +let e_a_empty_lambda l = e_a_lambda l Environment.full_empty + +open Environment + +let env_sum_type ?(env = full_empty) + ?(name = "a_sum_type") + (lst : (string * type_value) list) = + add_type name (make_t_ez_sum lst) env diff --git a/ast_typed/dune b/ast_typed/dune new file mode 100644 index 000000000..ed65217e9 --- /dev/null +++ b/ast_typed/dune @@ -0,0 +1,13 @@ +(library + (name ast_typed) + (public_name ligo.ast_typed) + (libraries + simple-utils + tezos-utils + ast_simplified ; Is that a good idea? + ) + (preprocess + (pps simple-utils.ppx_let_generalized) + ) + (flags (:standard -open Simple_utils)) +) diff --git a/ast_typed/environment.ml b/ast_typed/environment.ml new file mode 100644 index 000000000..de0798c91 --- /dev/null +++ b/ast_typed/environment.ml @@ -0,0 +1,79 @@ +open Types +open Combinators + +type element = environment_element +let make_element : type_value -> full_environment -> environment_element_definition -> element = + fun type_value source_environment definition -> {type_value ; source_environment ; definition} + +let make_element_binder = fun t s -> make_element t s ED_binder +let make_element_declaration = fun t s d -> make_element t s (ED_declaration d) + +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 -> 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 -> 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_ez_binder : string -> type_value -> t -> t = fun k v e -> + List.Ne.hd_map (Small.add k (make_element_binder v e)) e +let add_ez_declaration : string -> type_value -> expression -> t -> t = fun k v expr e -> + List.Ne.hd_map (Small.add k (make_element_declaration v e expr)) e +let add_ez_ae : string -> annotated_expression -> t -> t = fun k ae e -> + add_ez_declaration k (get_type_annotation ae) (get_expression ae) 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 -> type_value option = fun k x -> List.Ne.find_map (Small.get_type_opt k) x + +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 + | T_sum m when Map.String.mem k m -> Some (Map.String.find k m , x) + | _ -> None + in + List.find_map aux (Small.get_type_environment x) in + List.Ne.find_map aux x + + +module PP = struct + open Format + open PP_helpers + + let list_sep_scope x = list_sep x (const " | ") + + 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 environment_element (const " , ")) lst + + let type_environment = fun ppf 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" + environment (Small.get_environment e) + type_environment (Small.get_type_environment e) + + let full_environment : _ -> full_environment -> unit = fun ppf e -> + fprintf ppf "@[%a]" + (ne_list_sep small_environment (tag "@;")) e +end + diff --git a/ast_typed/misc.ml b/ast_typed/misc.ml new file mode 100644 index 000000000..b562be0ff --- /dev/null +++ b/ast_typed/misc.ml @@ -0,0 +1,417 @@ +open Trace +open Types + +module Errors = struct + let different_kinds a b () = + let title = (thunk "different kinds") in + let full () = Format.asprintf "(%a) VS (%a)" PP.type_value a PP.type_value b in + error title full () + + let different_constants a b () = + let title = (thunk "different constants") in + let full () = Format.asprintf "%s VS %s" a b in + error title full () + + let different_size_type name a b () = + let title () = name ^ " have different sizes" in + let full () = Format.asprintf "%a VS %a" PP.type_value a PP.type_value b in + error title full () + + let different_size_constants = different_size_type "constants" + + let different_size_tuples = different_size_type "tuples" + + let different_size_sums = different_size_type "sums" + + let different_size_records = different_size_type "records" + +end + +module Free_variables = struct + + type bindings = string list + let mem : string -> bindings -> bool = List.mem + let singleton : string -> bindings = fun s -> [ s ] + let union : bindings -> bindings -> bindings = (@) + let unions : bindings list -> bindings = List.concat + let empty : bindings = [] + let of_list : string list -> bindings = fun x -> x + + let rec expression : bindings -> expression -> bindings = fun b e -> + let self = annotated_expression b in + match e with + | E_lambda l -> lambda b l + | E_literal _ -> empty + | E_constant (_ , lst) -> unions @@ List.map self lst + | E_variable name -> ( + match mem name b with + | true -> empty + | false -> singleton name + ) + | E_application (a, b) -> unions @@ List.map self [ a ; b ] + | E_tuple lst -> unions @@ List.map self lst + | E_constructor (_ , a) -> self a + | E_record m -> unions @@ List.map self @@ Map.String.to_list m + | E_record_accessor (a, _) -> self a + | E_tuple_accessor (a, _) -> self a + | E_list lst -> unions @@ List.map self lst + | E_map m -> unions @@ List.map self @@ List.concat @@ List.map (fun (a, b) -> [ a ; b ]) m + | E_look_up (a , b) -> unions @@ List.map self [ a ; b ] + | E_matching (a , cs) -> union (self a) (matching_expression b cs) + | E_failwith a -> self a + + and lambda : bindings -> lambda -> bindings = fun b l -> + let b' = union (singleton l.binder) b in + let (b'', frees) = block' b' l.body in + union (annotated_expression b'' l.result) frees + + and annotated_expression : bindings -> annotated_expression -> bindings = fun b ae -> + expression b ae.expression + + and instruction' : bindings -> instruction -> bindings * bindings = fun b i -> + match i with + | I_declaration n -> union (singleton n.name) b , (annotated_expression b n.annotated_expression) + | I_assignment n -> b , (annotated_expression b n.annotated_expression) + | I_skip -> b , empty + | I_do e -> b , annotated_expression b e + | I_loop (a , bl) -> b , union (annotated_expression b a) (block b bl) + | I_patch (_ , _ , a) -> b , annotated_expression b a + | I_matching (a , cs) -> b , union (annotated_expression b a) (matching_block b cs) + + and block' : bindings -> block -> (bindings * bindings) = fun b bl -> + let aux = fun (binds, frees) cur -> + let (binds', frees') = instruction' binds cur in + (binds', union frees frees') in + List.fold_left aux (b , []) bl + + and block : bindings -> block -> bindings = fun b bl -> + 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_variant (lst , _) -> unions @@ List.map (matching_variant_case f b) lst + + and matching_expression = fun x -> matching annotated_expression x + + and matching_block = fun x -> matching block x + +end + +(* module Dependencies = struct + * + * type bindings = string list + * let mem : string -> bindings -> bool = List.mem + * let singleton : string -> bindings = fun s -> [ s ] + * let union : bindings -> bindings -> bindings = (@) + * let unions : bindings list -> bindings = List.concat + * let empty : bindings = [] + * let of_list : string list -> bindings = fun x -> x + * + * let rec expression : bindings -> full_environment -> expression -> bindings = fun b _env e -> + * let self = annotated_expression b in + * match e with + * | E_lambda l -> + * let b' = union (singleton l.binder) b in + * let (b'', frees) = block' b' l.body in + * union (annotated_expression b'' l.result) frees + * | E_literal _ -> empty + * | E_constant (_ , lst) -> unions @@ List.map self lst + * | E_variable name -> ( + * match mem name b with + * | true -> empty + * | false -> singleton name + * ) + * | E_application (a, b) -> unions @@ List.map self [ a ; b ] + * | E_tuple lst -> unions @@ List.map self lst + * | E_constructor (_ , a) -> self a + * | E_record m -> unions @@ List.map self @@ Map.String.to_list m + * | E_record_accessor (a, _) -> self a + * | E_tuple_accessor (a, _) -> self a + * | E_list lst -> unions @@ List.map self lst + * | E_map m -> unions @@ List.map self @@ List.concat @@ List.map (fun (a, b) -> [ a ; b ]) m + * | E_look_up (a , b) -> unions @@ List.map self [ a ; b ] + * | E_matching (a , cs) -> union (self a) (matching_expression b cs) + * | E_failwith a -> self a + * + * and annotated_expression : bindings -> annotated_expression -> bindings = fun b ae -> + * let open Combinators in + * expression b (get_environment ae) (get_expression ae) + * + * and instruction' : bindings -> instruction -> bindings * bindings = fun b i -> + * match i with + * | I_declaration n -> union (singleton n.name) b , (annotated_expression b n.annotated_expression) + * | I_assignment n -> b , (annotated_expression b n.annotated_expression) + * | I_skip -> b , empty + * | I_do e -> b , annotated_expression b e + * | I_loop (a , bl) -> b , union (annotated_expression b a) (block b bl) + * | I_patch (_ , _ , a) -> b , annotated_expression b a + * | I_matching (a , cs) -> b , union (annotated_expression b a) (matching_block b cs) + * + * and block' : bindings -> block -> (bindings * bindings) = fun b bl -> + * let aux = fun (binds, frees) cur -> + * let (binds', frees') = instruction' binds cur in + * (binds', union frees frees') in + * List.fold_left aux (b , []) bl + * + * and block : bindings -> block -> bindings = fun b bl -> + * 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_variant (lst , _) -> unions @@ List.map (matching_variant_case f b) lst + * + * and matching_expression = fun x -> matching annotated_expression x + * + * and matching_block = fun x -> matching block x + * + * end *) + + +open Errors + +let rec assert_type_value_eq (a, b: (type_value * type_value)) : unit result = match (a.type_value', b.type_value') with + | T_tuple ta, T_tuple tb -> ( + let%bind _ = + trace_strong (fun () -> (different_size_tuples a b ())) + @@ Assert.assert_true List.(length ta = length tb) in + bind_list_iter assert_type_value_eq (List.combine ta tb) + ) + | T_tuple _, _ -> fail @@ different_kinds a b + | T_constant (ca, lsta), T_constant (cb, lstb) -> ( + let%bind _ = + trace_strong (different_size_constants a b) + @@ Assert.assert_true List.(length lsta = length lstb) in + let%bind _ = + trace_strong (different_constants ca cb) + @@ Assert.assert_true (ca = cb) in + trace (simple_error "constant sub-expression") + @@ bind_list_iter assert_type_value_eq (List.combine lsta lstb) + ) + | T_constant _, _ -> fail @@ different_kinds a b + | T_sum sa, T_sum sb -> ( + let sa' = SMap.to_kv_list sa in + let sb' = SMap.to_kv_list sb in + let aux ((ka, va), (kb, vb)) = + let%bind _ = + Assert.assert_true ~msg:"different keys in sum types" + @@ (ka = kb) in + assert_type_value_eq (va, vb) + in + let%bind _ = + trace_strong (different_size_sums a b) + @@ Assert.assert_list_same_size sa' sb' in + trace (simple_error "sum type") @@ + bind_list_iter aux (List.combine sa' sb') + + ) + | T_sum _, _ -> fail @@ different_kinds a b + | T_record ra, T_record rb -> ( + let ra' = SMap.to_kv_list ra in + let rb' = SMap.to_kv_list rb in + let aux ((ka, va), (kb, vb)) = + let%bind _ = + let error = + let title () = "different props in record" in + let content () = Format.asprintf "%s vs %s" ka kb in + error title content in + trace_strong error @@ + Assert.assert_true (ka = kb) in + assert_type_value_eq (va, vb) + in + let%bind _ = + trace_strong (different_size_records a b) + @@ Assert.assert_list_same_size ra' rb' in + trace (simple_error "record type") + @@ bind_list_iter aux (List.combine ra' rb') + + ) + | T_record _, _ -> fail @@ different_kinds a b + | T_function (param, result), T_function (param', result') -> + let%bind _ = assert_type_value_eq (param, param') in + let%bind _ = assert_type_value_eq (result, result') in + ok () + | T_function _, _ -> fail @@ different_kinds a b + +(* No information about what made it fail *) +let type_value_eq ab = Trace.to_bool @@ assert_type_value_eq ab + +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_tez a, Literal_tez b when a = b -> ok () + | Literal_tez _, Literal_tez _ -> simple_fail "different tezs" + | Literal_tez _, _ -> simple_fail "tez vs non-tez" + | 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" + | Literal_address a, Literal_address b when a = b -> ok () + | Literal_address _, Literal_address _ -> simple_fail "different addresss" + | Literal_address _, _ -> simple_fail "address vs non-address" + | Literal_operation _, Literal_operation _ -> simple_fail "can't compare operations" + | Literal_operation _, _ -> simple_fail "operation vs non-operation" + + +let rec assert_value_eq (a, b: (value*value)) : unit result = + let error_content () = + Format.asprintf "\n%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 @@ SMap.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" + +let merge_annotation (a:type_value option) (b:type_value option) : type_value result = + match a, b with + | None, None -> simple_fail "no annotation" + | Some a, None -> ok a + | None, Some b -> ok b + | Some a, Some b -> + let%bind _ = assert_type_value_eq (a, b) in + match a.simplified, b.simplified with + | _, None -> ok a + | _, Some _ -> ok b + +open Combinators + +let program_to_main : program -> string -> lambda result = fun p s -> + let%bind (main , input_type , output_type) = + let pred = fun d -> + match d with + | Declaration_constant (d , _) when d.name = s -> Some d.annotated_expression + | Declaration_constant _ -> None + in + let%bind main = + trace_option (simple_error "no main with given name") @@ + List.find_map (Function.compose pred Location.unwrap) p in + let%bind (input_ty , output_ty) = + match (get_type' @@ get_type_annotation main) with + | T_function (i , o) -> ok (i , o) + | _ -> simple_fail "program main isn't a function" in + ok (main , input_ty , output_ty) + in + let body = + let aux : declaration -> instruction = fun d -> + match d with + | Declaration_constant (d , _) -> I_declaration d in + List.map (Function.compose aux Location.unwrap) p in + let env = + let aux = fun _ d -> + match d with + | Declaration_constant (_ , env) -> env in + List.fold_left aux Environment.full_empty (List.map Location.unwrap p) in + let binder = "@contract_input" in + let result = + let input_expr = e_a_variable binder input_type env in + let main_expr = e_a_variable s (get_type_annotation main) env in + e_a_application main_expr input_expr env in + ok { + binder ; + input_type ; + output_type ; + body ; + result ; + } diff --git a/ast_typed/types.ml b/ast_typed/types.ml new file mode 100644 index 000000000..78dc31ab1 --- /dev/null +++ b/ast_typed/types.ml @@ -0,0 +1,169 @@ +[@@@warning "-30"] + +module S = Ast_simplified + +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 + +type program = declaration Location.wrap list + +and declaration = + | Declaration_constant of (named_expression * full_environment) + (* | Macro_declaration of macro_declaration *) + +and environment_element_definition = + | ED_binder + | ED_declaration of expression + +and environment_element = { + type_value : type_value ; + source_environment : full_environment ; + definition : environment_element_definition ; +} +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 + +and annotated_expression = { + expression: expression ; + type_annotation: tv ; + environment: full_environment ; + dummy_field: unit ; +} + +and named_expression = { + name: name ; + annotated_expression: ae ; +} + +and tv = type_value +and ae = annotated_expression +and tv_map = type_value type_name_map +and ae_map = annotated_expression name_map + +and type_value' = + | T_tuple of tv list + | T_sum of tv_map + | T_record of tv_map + | T_constant of type_name * tv list + | T_function of (tv * tv) + +and type_value = { + type_value' : type_value' ; + simplified : S.type_expression option ; +} + +and named_type_value = { + type_name: name ; + type_value : type_value ; +} + +and lambda = { + binder: name ; + input_type: tv ; + output_type: tv ; + 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_application of (ae * ae) + | E_lambda of lambda + (* Tuple *) + | E_tuple of ae list + | E_tuple_accessor of (ae * int) (* Access n'th tuple's element *) + (* Sum *) + | E_constructor of (name * ae) (* For user defined constructors *) + (* Record *) + | E_record of ae_map + | E_record_accessor of (ae * string) + (* Data Structures *) + | E_map of (ae * ae) list + | E_list of ae list + | E_look_up of (ae * ae) + (* Advanced *) + | E_matching of (ae * matching_expr) + | E_failwith of ae + +and value = annotated_expression (* todo (for refactoring) *) + +and literal = + | Literal_unit + | Literal_bool of bool + | Literal_int of int + | Literal_nat of int + | Literal_tez of int + | Literal_string of string + | Literal_bytes of bytes + | Literal_address of string + | Literal_operation of Memory_proto_alpha.Alpha_context.packed_internal_operation + +and block = instruction list +and b = block + +and instruction = + | I_declaration of named_expression + | I_assignment of named_expression + | I_matching of ae * matching_instr + | I_loop of ae * b + | I_do of ae + | I_skip + | I_patch of named_type_value * access_path * ae + +and access = + | Access_tuple of int + | Access_record of string + | Access_map of ae + +and access_path = access 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 * type_value) * 'a ; + } + | Match_tuple of (name list * 'a) + | Match_variant of (((constructor_name * name) * 'a) list * type_value) + +and matching_instr = b matching + +and matching_expr = ae matching + +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 _ -> None + in + let%bind result = + trace_option (simple_error "no entry point with given name") @@ + List.find_map aux (List.map Location.unwrap p) in + ok result + +let get_functional_entry (p:program) (entry : string) : (lambda * type_value) result = + let%bind entry = get_entry p entry in + match entry.expression with + | E_lambda l -> ok (l, entry.type_annotation) + | _ -> simple_fail "given entry point is not functional" + diff --git a/bin/cli.ml b/bin/cli.ml new file mode 100644 index 000000000..a37d5ffcd --- /dev/null +++ b/bin/cli.ml @@ -0,0 +1,107 @@ +open Cmdliner +open Trace + +let toplevel x = + match x with + | Trace.Ok ((), annotations) -> ignore annotations; () + | Errors ss -> + Format.printf "Errors: %a\n%!" errors_pp @@ List.map (fun f -> f()) ss + +let main = + let term = Term.(const print_endline $ const "Ligo needs a command. Do ligo --help") in + (term , Term.info "ligo") + +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_parameter = + 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 compile_storage = + let f source entry_point expression = + toplevel @@ + let%bind value = + trace (simple_error "compile-storage") @@ + Ligo.Contract.compile_contract_storage source entry_point expression in + Format.printf "Storage:\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 storage." in + (term , Term.info ~docs "compile-storage") + + +let () = Term.exit @@ Term.eval_choice main [compile_file ; compile_parameter ; compile_storage] diff --git a/bin/dune b/bin/dune new file mode 100644 index 000000000..b970a8805 --- /dev/null +++ b/bin/dune @@ -0,0 +1,14 @@ +(executable + (name cli) + (public_name ligo) + (libraries + simple-utils + cmdliner + ligo + ) + (package ligo) + (preprocess + (pps simple-utils.ppx_let_generalized) + ) + (flags (:standard -open Simple_utils)) +) diff --git a/compiler/compiler.ml b/compiler/compiler.ml new file mode 100644 index 000000000..fbdd8942a --- /dev/null +++ b/compiler/compiler.ml @@ -0,0 +1,6 @@ +module Uncompiler = Uncompiler +module Program = Compiler_program +module Type = Compiler_type +module Environment = Compiler_environment + +include Program diff --git a/compiler/compiler_environment.ml b/compiler/compiler_environment.ml new file mode 100644 index 000000000..c6980ee06 --- /dev/null +++ b/compiler/compiler_environment.ml @@ -0,0 +1,277 @@ +open Trace +open Mini_c +open Environment +open Micheline.Michelson +open Memory_proto_alpha.Script_ir_translator + +module Stack = Meta_michelson.Stack + +let get : environment -> string -> michelson result = fun e s -> + let%bind (type_value , position) = + let error = + let title () = "Environment.get" in + let content () = Format.asprintf "%s in %a" + s PP.environment e in + error title content in + generic_try error @@ + (fun () -> Environment.get_i s e) in + let rec aux = fun n -> + match n with + | 0 -> i_dup + | n -> seq [ + dip @@ aux (n - 1) ; + i_swap ; + ] + in + let code = aux position in + + let%bind () = + let error () = ok @@ simple_error "error producing Env.get" in + let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment e in + let%bind (Ex_ty ty) = Compiler_type.Ty.type_ type_value in + let output_stack_ty = Stack.(ty @: input_stack_ty) in + let%bind _ = + Trace.trace_tzresult_lwt_r error @@ + Memory_proto_alpha.parse_michelson code + input_stack_ty output_stack_ty in + ok () + in + + ok code + +let set : environment -> string -> michelson result = fun e s -> + let%bind (type_value , position) = + generic_try (simple_error "Environment.get") @@ + (fun () -> Environment.get_i s e) in + let rec aux = fun n -> + match n with + | 0 -> dip i_drop + | n -> seq [ + i_swap ; + dip (aux (n - 1)) ; + ] + in + let code = aux position in + + let%bind () = + let error () = ok @@ simple_error "error producing Env.set" in + let%bind (Stack.Ex_stack_ty env_stack_ty) = Compiler_type.Ty.environment e in + let%bind (Ex_ty ty) = Compiler_type.Ty.type_ type_value in + let input_stack_ty = Stack.(ty @: env_stack_ty) in + let output_stack_ty = env_stack_ty in + let%bind _ = + Trace.trace_tzresult_lwt_r error @@ + Memory_proto_alpha.parse_michelson code + input_stack_ty output_stack_ty in + ok () + in + + ok code + +let add : environment -> (string * type_value) -> michelson result = fun e (_s , type_value) -> + let code = seq [] in + + let%bind () = + let error () = ok @@ simple_error "error producing Env.get" in + let%bind (Stack.Ex_stack_ty env_stack_ty) = Compiler_type.Ty.environment e in + let%bind (Ex_ty ty) = Compiler_type.Ty.type_ type_value in + let input_stack_ty = Stack.(ty @: env_stack_ty) in + let output_stack_ty = Stack.(ty @: env_stack_ty) in + let%bind _ = + Trace.trace_tzresult_lwt_r error @@ + Memory_proto_alpha.parse_michelson code + input_stack_ty output_stack_ty in + ok () + in + + ok code + +let select : environment -> string list -> michelson result = fun e lst -> + let module L = Logger.Stateful() in + let e_lst = + let e_lst = Environment.to_list e in + let aux selector (s , _) = + L.log @@ Format.asprintf "Selector : %a\n" PP_helpers.(list_sep string (const " , ")) selector ; + match List.mem s selector with + | true -> List.remove_element s selector , true + | false -> selector , false in + let e_lst' = List.fold_map_right aux lst e_lst in + let e_lst'' = List.combine e_lst e_lst' in + e_lst'' in + let code = + let aux = fun code (_ , b) -> + match b with + | false -> seq [dip code ; i_drop] + | true -> dip code + in + List.fold_right' aux (seq []) e_lst in + + let%bind () = + let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment e in + let e' = + Environment.of_list + @@ List.map fst + @@ List.filter snd + @@ e_lst + in + let%bind (Stack.Ex_stack_ty output_stack_ty) = Compiler_type.Ty.environment e' in + let error () = + let title () = "error producing Env.select" in + let content () = Format.asprintf "\nInput : %a\nOutput : %a\nList : {%a}\nCode : %a\nLog : %s\n" + PP.environment e + PP.environment e' + PP_helpers.(list_sep (pair PP.environment_element bool) (const " || ")) e_lst + Micheline.Michelson.pp code + (L.get ()) + in + ok @@ (error title content) in + let%bind _ = + Trace.trace_tzresult_lwt_r error @@ + Memory_proto_alpha.parse_michelson code + input_stack_ty output_stack_ty in + ok () + in + + ok code + +let clear : environment -> michelson result = fun e -> select e [] + +let select_env : environment -> environment -> michelson result = fun e e' -> + let lst = Environment.get_names e' in + select e lst + +let pack : environment -> michelson result = fun e -> + let%bind () = + trace_strong (simple_error "pack empty env") @@ + Assert.assert_true (List.length e <> 0) in + let code = seq @@ List.map (Function.constant i_pair) @@ List.tl e in + + let%bind () = + let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment e in + let repr = Environment.closure_representation e in + let%bind (Ex_ty output_ty) = Compiler_type.Ty.type_ repr in + let output_stack_ty = Stack.(output_ty @: nil) in + let error () = + let title () = "error producing Env.pack" in + let content () = Format.asprintf "" + in + ok @@ (error title content) in + let%bind _ = + Trace.trace_tzresult_lwt_r error @@ + Memory_proto_alpha.parse_michelson code + input_stack_ty output_stack_ty in + ok () + in + + ok code + +let unpack : environment -> michelson result = fun e -> + let%bind () = + trace_strong (simple_error "unpack empty env") @@ + Assert.assert_true (List.length e <> 0) in + + let l = List.length e - 1 in + let rec aux n = + match n with + | 0 -> seq [] + | n -> seq [ + i_unpair ; + dip (aux (n - 1)) ; + ] in + let code = aux l in + + let%bind () = + let%bind (Stack.Ex_stack_ty output_stack_ty) = Compiler_type.Ty.environment e in + let repr = Environment.closure_representation e in + let%bind (Ex_ty input_ty) = Compiler_type.Ty.type_ repr in + let input_stack_ty = Stack.(input_ty @: nil) in + let error () = + let title () = "error producing Env.unpack" in + let content () = Format.asprintf "\nEnvironment:%a\nType Representation:%a\nCode:%a\n" + PP.environment e + PP.type_ repr + Micheline.Michelson.pp code + in + ok @@ (error title content) in + let%bind _ = + Trace.trace_tzresult_lwt_r error @@ + Memory_proto_alpha.parse_michelson code + input_stack_ty output_stack_ty in + ok () + in + + ok code + + +let pack_select : environment -> string list -> michelson result = fun e lst -> + let module L = Logger.Stateful() in + let e_lst = + let e_lst = Environment.to_list e in + let aux selector (s , _) = + L.log @@ Format.asprintf "Selector : %a\n" PP_helpers.(list_sep string (const " , ")) selector ; + match List.mem s selector with + | true -> List.remove_element s selector , true + | false -> selector , false in + let e_lst' = List.fold_map_right aux lst e_lst in + let e_lst'' = List.combine e_lst e_lst' in + e_lst'' in + let (_ , code) = + let aux = fun (first , code) (_ , b) -> + match b with + | false -> (first , seq [dip code ; i_swap]) + | true -> (false , + match first with + | true -> i_dup + | false -> seq [dip code ; i_dup ; dip i_pair ; i_swap] + ) + in + List.fold_right' aux (true , seq []) e_lst in + + let%bind () = + let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment e in + let e' = + Environment.of_list + @@ List.map fst + @@ List.filter snd + @@ e_lst + in + let%bind (Ex_ty output_ty) = Compiler_type.Ty.environment_representation e' in + let output_stack_ty = Stack.(output_ty @: input_stack_ty) in + let error () = + let title () = "error producing Env.pack_select" in + let content () = Format.asprintf "\nInput : %a\nOutput : %a\nList : {%a}\nCode : %a\nLog : %s\n" + PP.environment e + PP.environment e' + PP_helpers.(list_sep (pair PP.environment_element bool) (const " || ")) e_lst + Micheline.Michelson.pp code + (L.get ()) + in + ok @@ (error title content) in + let%bind _ = + Trace.trace_tzresult_lwt_r error @@ + Memory_proto_alpha.parse_michelson code + input_stack_ty output_stack_ty in + ok () + in + + ok code + +let add_packed_anon : environment -> type_value -> michelson result = fun e type_value -> + let code = seq [i_pair] in + + let%bind () = + let error () = ok @@ simple_error "error producing add packed" in + let%bind (Ex_ty input_ty) = Compiler_type.Ty.environment_representation e in + let e' = Environment.add ("_add_packed_anon" , type_value) e in + let%bind (Ex_ty output_ty) = Compiler_type.Ty.environment_representation e' in + let%bind (Ex_ty ty) = Compiler_type.Ty.type_ type_value in + let input_stack_ty = Stack.(ty @: input_ty @: nil) in + let output_stack_ty = Stack.(output_ty @: nil) in + let%bind _ = + Trace.trace_tzresult_lwt_r error @@ + Memory_proto_alpha.parse_michelson code + input_stack_ty output_stack_ty in + ok () + in + + ok code diff --git a/compiler/compiler_program.ml b/compiler/compiler_program.ml new file mode 100644 index 000000000..48a67ae65 --- /dev/null +++ b/compiler/compiler_program.ml @@ -0,0 +1,540 @@ +open Trace +open Mini_c + +module Michelson = Micheline.Michelson +open Michelson +module Stack = Meta_michelson.Stack +module Contract_types = Meta_michelson.Types + +open Memory_proto_alpha.Script_ir_translator + +open Operators.Compiler + +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 -> ( + match s with + | "MAP_REMOVE" -> + let%bind v = match lst with + | [ _ ; expr ] -> + let%bind (_, v) = Mini_c.Combinators.(get_t_map (Expression.get_type expr)) in + ok v + | _ -> 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 + | "CONTRACT" -> + let%bind r = match lst with + | [ _ ] -> get_t_contract ty + | _ -> simple_fail "mini_c . CONTRACT" in + let%bind r_ty = Compiler_type.type_ r in + ok @@ simple_unary @@ seq [ + prim ~children:[r_ty] I_CONTRACT ; + i_assert_some_msg (i_push_string "bad address for get_contract") ; + ] + | x -> simple_fail ("predicate \"" ^ x ^ "\" doesn't exist") + ) + +let rec translate_value (v:value) : michelson result = match v with + | D_bool b -> ok @@ prim (if b then D_True else D_False) + | D_int n -> ok @@ int (Z.of_int n) + | D_nat n -> ok @@ int (Z.of_int n) + | D_tez n -> ok @@ int (Z.of_int n) + | D_string s -> ok @@ string s + | D_bytes s -> ok @@ bytes (Tezos_stdlib.MBytes.of_bytes s) + | D_unit -> ok @@ prim D_Unit + | D_pair (a, b) -> ( + let%bind a = translate_value a in + let%bind b = translate_value b in + ok @@ prim ~children:[a;b] D_Pair + ) + | D_left a -> translate_value a >>? fun a -> ok @@ prim ~children:[a] D_Left + | D_right b -> translate_value b >>? fun b -> ok @@ prim ~children:[b] D_Right + | D_function anon -> translate_function anon + | D_none -> ok @@ prim D_None + | D_some s -> + let%bind s' = translate_value s in + ok @@ prim ~children:[s'] D_Some + | D_map lst -> + let%bind lst' = bind_map_list (bind_map_pair translate_value) lst in + let aux (a, b) = prim ~children:[a;b] D_Elt in + ok @@ seq @@ List.map aux lst' + | D_list lst -> + let%bind lst' = bind_map_list translate_value lst in + ok @@ seq lst' + | D_operation _ -> + simple_fail "can't compile an operation" + +and translate_function (content:anon_function) : michelson result = + let%bind body = translate_quote_body content in + ok @@ seq [ body ] + +and translate_expression ?(first=false) (expr:expression) (env:environment) : (michelson * environment) result = + let (expr' , ty) = Combinators.Expression.(get_content expr , get_type expr) in + let error_message () = Format.asprintf "%a" PP.expression expr in + + let return ?env' code = + let env' = + let default = env in + Environment.add ("_tmp_expression" , ty) @@ Option.unopt ~default env' in + let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment env in + let%bind output_type = Compiler_type.type_ ty in + let%bind (Stack.Ex_stack_ty output_stack_ty) = Compiler_type.Ty.environment env' in + let error_message () = + let%bind schema_michelsons = Compiler_type.environment env in + ok @@ Format.asprintf + "expression : %a\ncode : %a\nschema type : %a\noutput type : %a" + PP.expression expr + Michelson.pp code + PP_helpers.(list_sep Michelson.pp (const ".")) schema_michelsons + Michelson.pp output_type + in + let%bind _ = + Trace.trace_tzresult_lwt_r + (fun () -> + let%bind error_message = error_message () in + ok @@ (fun () -> error (thunk "error parsing expression code") + (fun () -> error_message) + ())) @@ + Tezos_utils.Memory_proto_alpha.parse_michelson code + input_stack_ty output_stack_ty + in + ok (code , env') + in + + trace (error (thunk "compiling expression") error_message) @@ + match expr' with + | E_capture_environment c -> + let%bind code = Compiler_environment.pack_select env c in + return @@ code + | E_literal v -> + let%bind v = translate_value v in + let%bind t = Compiler_type.type_ ty in + return @@ i_push t v + | E_application(f, arg) -> ( + match Combinators.Expression.get_type f with + | T_function _ -> ( + trace (simple_error "Compiling quote application") @@ + let%bind (f , env') = translate_expression ~first f env in + let%bind (arg , _) = translate_expression arg env' in + return @@ seq [ + i_comment "quote application" ; + i_comment "get f" ; + f ; + i_comment "get arg" ; + arg ; + prim I_EXEC ; + ] + ) + | T_deep_closure (small_env, input_ty , _) -> ( + trace (simple_error "Compiling deep closure application") @@ + let%bind (arg' , env') = translate_expression arg env in + let%bind (f' , env'') = translate_expression f env' in + let%bind f_ty = Compiler_type.type_ f.type_value in + let%bind append_closure = Compiler_environment.add_packed_anon small_env input_ty in + let error = + let error_title () = "michelson type-checking closure application" in + let error_content () = + Format.asprintf "\nEnv. %a\nEnv'. %a\nEnv''. %a\nclosure. %a ; %a ; %a\narg. %a\n" + PP.environment env + PP.environment env' + PP.environment env'' + PP.expression_with_type f Michelson.pp f_ty Michelson.pp f' + PP.expression_with_type arg + in + error error_title error_content + in + trace error @@ + return @@ seq [ + i_comment "closure application" ; + i_comment "arg" ; + arg' ; + i_comment "f'" ; + f' ; i_unpair ; + i_comment "append" ; + dip @@ seq [i_swap ; append_closure] ; + i_comment "exec" ; + i_swap ; i_exec ; + ] + ) + | _ -> simple_fail "E_applicationing something not appliable" + ) + | E_variable x -> + let%bind code = Compiler_environment.get env x in + return code + | E_constant(str, lst) -> + let module L = Logger.Stateful() in + let%bind lst' = + let aux env expr = + let%bind (code , env') = translate_expression expr env in + L.log @@ Format.asprintf "\n%a -> %a in %a\n" + PP.expression expr + Michelson.pp code + PP.environment env ; + ok (env' , code) + in + bind_fold_map_right_list aux env lst in + let%bind predicate = get_predicate str ty lst in + let pre_code = seq @@ List.rev lst' in + let%bind code = match (predicate, List.length lst) with + | Constant c, 0 -> ok @@ seq [ + pre_code ; + c ; + ] + | Unary f, 1 -> ok @@ seq [ + pre_code ; + f ; + ] + | Binary f, 2 -> ok @@ seq [ + pre_code ; + f ; + ] + | Ternary f, 3 -> ok @@ seq [ + pre_code ; + f ; + ] + | _ -> simple_fail "bad arity" + in + let error = + let title () = "error compiling constant" in + let content () = L.get () in + error title content in + trace error @@ + return code + | E_empty_map sd -> + let%bind (src, dst) = bind_map_pair Compiler_type.type_ sd in + return @@ i_empty_map src dst + | E_empty_list t -> + let%bind t' = Compiler_type.type_ t in + return @@ i_nil t' + | E_make_none o -> + let%bind o' = Compiler_type.type_ o in + return @@ i_none o' + | E_Cond (c, a, b) -> ( + let%bind (c' , env') = translate_expression c env in + let%bind (a' , _) = translate_expression a env' in + let%bind (b' , _) = translate_expression b env' in + let%bind code = ok (seq [ + c' ; + i_if a' b' ; + ]) in + return code + ) + | E_if_none (c, n, (_ , s)) -> ( + let%bind (c' , _env') = translate_expression c env in + let%bind (n' , _) = translate_expression n n.environment in + let%bind (s' , _) = translate_expression s s.environment in + let%bind restrict_s = Compiler_environment.select_env s.environment env in + let%bind code = ok (seq [ + c' ; + i_if_none n' (seq [ + s' ; + restrict_s ; + ]) + ; + ]) in + return code + ) + | E_if_left (c, (_ , l), (_ , r)) -> ( + let%bind (c' , _env') = translate_expression c env in + let%bind (l' , _) = translate_expression l l.environment in + let%bind (r' , _) = translate_expression r r.environment in + let%bind restrict_l = Compiler_environment.select_env l.environment env in + let%bind restrict_r = Compiler_environment.select_env r.environment env in + let%bind code = ok (seq [ + c' ; + i_if_left (seq [ + l' ; + i_comment "restrict left" ; + dip restrict_l ; + ]) (seq [ + r' ; + i_comment "restrict right" ; + dip restrict_r ; + ]) + ; + ]) in + return code + ) + | E_let_in (v, expr , body) -> ( + let%bind (expr' , _) = translate_expression expr env in + let env' = Environment.add v env in + let%bind (body' , _) = translate_expression body env' in + let%bind restrict = Compiler_environment.select_env env' env in + let%bind code = ok (seq [ + expr' ; + body' ; + i_comment "restrict let" ; + dip restrict ; + ]) in + return code + ) + +and translate_statement ((s', w_env) as s:statement) : michelson result = + let error_message () = Format.asprintf "%a" PP.statement s in + let return code = + let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment w_env.pre_environment in + let%bind (Stack.Ex_stack_ty output_stack_ty) = Compiler_type.Ty.environment w_env.post_environment in + let error_message () = + let%bind pre_env_michelson = Compiler_type.environment w_env.pre_environment in + let%bind post_env_michelson = Compiler_type.environment w_env.post_environment in + ok @@ Format.asprintf + "statement : %a\ncode : %a\npre type : %a\npost type : %a\n" + PP.statement s + Michelson.pp code + PP_helpers.(list_sep Michelson.pp (const " ; ")) pre_env_michelson + PP_helpers.(list_sep Michelson.pp (const " ; ")) post_env_michelson + in + let%bind _ = + Trace.trace_tzresult_lwt_r (fun () -> let%bind error_message = error_message () in + ok (fun () -> error (thunk "error parsing statement code") + (fun () -> error_message) + ())) @@ + Tezos_utils.Memory_proto_alpha.parse_michelson_fail code + input_stack_ty output_stack_ty + in + ok code + in + + trace (fun () -> error (thunk "compiling statement") error_message ()) @@ match s' with + | S_environment_add _ -> + simple_fail "add not ready yet" + | S_environment_select sub_env -> + let%bind code = Compiler_environment.select_env w_env.pre_environment sub_env in + return code + | S_environment_load (expr , env) -> + let%bind (expr' , _) = translate_expression expr w_env.pre_environment in + let%bind clear = Compiler_environment.select w_env.pre_environment [] in + let%bind unpack = Compiler_environment.unpack env in + return @@ seq [ + expr' ; + dip clear ; + unpack ; + ] + | S_declaration (s, expr) -> + let tv = Combinators.Expression.get_type expr in + let%bind (expr , _) = translate_expression expr w_env.pre_environment in + let%bind add = Compiler_environment.add w_env.pre_environment (s, tv) in + return @@ seq [ + i_comment "declaration" ; + seq [ + i_comment "expr" ; + expr ; + ] ; + seq [ + i_comment "env <- env . expr" ; + add ; + ]; + ] + | S_assignment (s, expr) -> + let%bind (expr , _) = translate_expression expr w_env.pre_environment in + let%bind set = Compiler_environment.set w_env.pre_environment s in + return @@ seq [ + i_comment "assignment" ; + seq [ + i_comment "expr" ; + expr ; + ] ; + seq [ + i_comment "env <- env . expr" ; + set ; + ]; + ] + | S_cond (expr, a, b) -> + let%bind (expr , _) = translate_expression expr w_env.pre_environment in + let%bind a' = translate_regular_block a in + let%bind b' = translate_regular_block b in + return @@ seq [ + expr ; + prim ~children:[seq [a'];seq [b']] I_IF ; + ] + | S_do expr -> ( + match Combinators.Expression.get_content expr with + | E_constant ("FAILWITH" , [ fw ] ) -> ( + let%bind (fw' , _) = translate_expression fw w_env.pre_environment in + return @@ seq [ + fw' ; + i_failwith ; + ] + ) + | _ -> ( + let%bind (expr' , _) = translate_expression expr w_env.pre_environment in + return @@ seq [ + expr' ; + i_drop ; + ] + ) + ) + | S_if_none (expr, none, ((name, tv), some)) -> + let%bind (expr , _) = translate_expression expr w_env.pre_environment in + let%bind none' = translate_regular_block none in + let%bind some' = translate_regular_block some in + let%bind add = + let env' = w_env.pre_environment in + Compiler_environment.add env' (name, tv) in + let%bind restrict_s = Compiler_environment.select_env (snd some).post_environment w_env.pre_environment in + return @@ seq [ + expr ; + prim ~children:[ + seq [none'] ; + seq [add ; some' ; restrict_s] ; + ] I_IF_NONE + ] + | S_while (expr, block) -> + let%bind (expr , _) = translate_expression expr w_env.pre_environment in + let%bind block' = translate_regular_block block in + let%bind restrict_block = + let env_while = (snd block).pre_environment in + Compiler_environment.select_env (snd block).post_environment env_while in + return @@ seq [ + expr ; + prim ~children:[seq [ + block' ; + restrict_block ; + expr]] I_LOOP ; + ] + | S_patch (name, lrs, expr) -> + let%bind (expr' , env') = translate_expression expr w_env.pre_environment in + let%bind get_code = Compiler_environment.get env' name in + let modify_code = + let aux acc step = match step with + | `Left -> seq [dip i_unpair ; acc ; i_pair] + | `Right -> seq [dip i_unpiar ; acc ; i_piar] + in + let init = dip i_drop in + List.fold_right' aux init lrs + in + let%bind set_code = Compiler_environment.set w_env.pre_environment name in + let error = + let title () = "michelson type-checking patch" in + let content () = + let aux ppf = function + | `Left -> Format.fprintf ppf "left" + | `Right -> Format.fprintf ppf "right" in + Format.asprintf "Sub path: %a\n" + PP_helpers.(list_sep aux (const " , ")) lrs + in + error title content in + trace error @@ + return @@ seq [ + expr' ; + get_code ; + i_swap ; modify_code ; + set_code ; + ] + +and translate_regular_block ((b, env):block) : michelson result = + let aux prev statement = + let%bind (lst : michelson list) = prev in + let%bind instruction = translate_statement statement in + ok (instruction :: lst) + in + let%bind codes = + let error_message () = + let%bind schema_michelsons = Compiler_type.environment env.pre_environment in + ok @@ Format.asprintf "\nblock : %a\nschema : %a\n" + PP.block (b, env) + PP_helpers.(list_sep Michelson.pp (const " ; ")) schema_michelsons + in + trace_r (fun () -> + let%bind error_message = error_message () in + ok (fun () -> error (thunk "compiling regular block") + (fun () -> error_message) + ())) @@ + List.fold_left aux (ok []) b in + let code = seq (List.rev codes) in + ok code + +and translate_quote_body ({body;result} as f:anon_function) : michelson result = + let%bind body' = translate_regular_block body in + let%bind (expr , _) = translate_expression result (snd body).post_environment in + let%bind restrict = Compiler_environment.clear (snd body).post_environment in + let code = seq [ + i_comment "function body" ; + body' ; + i_comment "function result" ; + expr ; + dip restrict ; + ] in + + let%bind _assert_type = + let%bind (Ex_ty input_ty) = Compiler_type.Ty.type_ f.input in + let%bind (Ex_ty output_ty) = Compiler_type.Ty.type_ f.output in + let input_stack_ty = Stack.(input_ty @: nil) in + let output_stack_ty = Stack.(output_ty @: nil) in + let error_message () = + Format.asprintf + "\ncode : %a\ninput : %a\noutput : %a\nenv : %a\n" + Tezos_utils.Micheline.Michelson.pp code + PP.type_ f.input + PP.type_ f.output + PP.environment (snd body).post_environment + in + let%bind _ = + Trace.trace_tzresult_lwt ( + error (thunk "error parsing quote code") error_message + ) @@ + Tezos_utils.Memory_proto_alpha.parse_michelson code + input_stack_ty output_stack_ty + in + ok () + in + + ok code + +type compiled_program = { + input : ex_ty ; + output : ex_ty ; + body : michelson ; +} + +let get_main : program -> string -> anon_function result = fun p entry -> + let is_main (((name , expr), _):toplevel_statement) = + match Combinators.Expression.(get_content expr , get_type expr)with + | (E_literal (D_function content) , T_function _) + when name = entry -> + Some content + | _ -> None + in + let%bind main = + trace_option (simple_error "no functional entry") @@ + 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 = 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_entry (p:anon_function) : compiled_program result = + let {input;output} : anon_function = p in + let%bind body = + trace (simple_error "compile entry body") @@ + translate_quote_body p 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 : anon_function -> michelson result = fun f -> + let%bind compiled_program = translate_entry f in + let%bind (param_ty , storage_ty) = Combinators.get_t_pair f.input in + let%bind param_michelson = Compiler_type.type_ param_ty in + let%bind storage_michelson = Compiler_type.type_ storage_ty in + let contract = Michelson.contract param_michelson storage_michelson compiled_program.body in + ok contract diff --git a/compiler/compiler_type.ml b/compiler/compiler_type.ml new file mode 100644 index 000000000..bfa6cd12f --- /dev/null +++ b/compiler/compiler_type.ml @@ -0,0 +1,173 @@ +open Trace +open Mini_c.Types + +open Tezos_utils.Memory_proto_alpha +open Script_ir_translator + +module O = Tezos_utils.Micheline.Michelson +module Contract_types = Meta_michelson.Types + +module Ty = struct + + let not_comparable name () = error (thunk "not a comparable type") (fun () -> name) () + + let comparable_type_base : type_base -> ex_comparable_ty result = fun tb -> + let open Contract_types in + let return x = ok @@ Ex_comparable_ty x in + match tb with + | Base_unit -> fail (not_comparable "unit") + | Base_bool -> fail (not_comparable "bool") + | Base_nat -> return nat_k + | Base_tez -> return tez_k + | Base_int -> return int_k + | Base_string -> return string_k + | Base_address -> return address_k + | Base_bytes -> return bytes_k + | Base_operation -> fail (not_comparable "operation") + + let comparable_type : type_value -> ex_comparable_ty result = fun tv -> + match tv with + | T_base b -> comparable_type_base b + | T_deep_closure _ -> fail (not_comparable "deep closure") + | T_function _ -> fail (not_comparable "function") + | T_or _ -> fail (not_comparable "or") + | T_pair _ -> fail (not_comparable "pair") + | T_map _ -> fail (not_comparable "map") + | T_list _ -> fail (not_comparable "list") + | T_option _ -> fail (not_comparable "option") + | T_contract _ -> fail (not_comparable "contract") + + let base_type : type_base -> ex_ty result = fun b -> + let open Contract_types in + let return x = ok @@ Ex_ty x in + match b with + | Base_unit -> return unit + | Base_bool -> return bool + | Base_int -> return int + | Base_nat -> return nat + | Base_tez -> return tez + | Base_string -> return string + | Base_address -> return address + | Base_bytes -> return bytes + | Base_operation -> return operation + + let rec type_ : type_value -> ex_ty result = + function + | T_base b -> base_type b + | T_pair (t, t') -> ( + type_ t >>? fun (Ex_ty t) -> + type_ t' >>? fun (Ex_ty t') -> + ok @@ Ex_ty (Contract_types.pair t t') + ) + | T_or (t, t') -> ( + type_ t >>? fun (Ex_ty t) -> + type_ t' >>? fun (Ex_ty t') -> + ok @@ Ex_ty (Contract_types.union t t') + ) + | T_function (arg, ret) -> + let%bind (Ex_ty arg) = type_ arg in + let%bind (Ex_ty ret) = type_ ret in + ok @@ Ex_ty (Contract_types.lambda arg ret) + | T_deep_closure (c, arg, ret) -> + let%bind (Ex_ty capture) = environment_representation c in + let%bind (Ex_ty arg) = type_ arg in + let%bind (Ex_ty ret) = type_ ret in + ok @@ Ex_ty Contract_types.(pair (lambda (pair arg capture) ret) capture) + | T_map (k, v) -> + let%bind (Ex_comparable_ty k') = comparable_type k in + let%bind (Ex_ty v') = type_ v in + ok @@ Ex_ty Contract_types.(map k' v') + | T_list t -> + let%bind (Ex_ty t') = type_ t in + ok @@ Ex_ty Contract_types.(list t') + | T_option t -> + let%bind (Ex_ty t') = type_ t in + ok @@ Ex_ty Contract_types.(option t') + | T_contract t -> + let%bind (Ex_ty t') = type_ t in + ok @@ Ex_ty Contract_types.(contract t') + + and environment_representation = function + | [] -> ok @@ Ex_ty Contract_types.unit + | [a] -> type_ @@ snd a + | a::b -> + let%bind (Ex_ty a) = type_ @@ snd a in + let%bind (Ex_ty b) = environment_representation b in + ok @@ Ex_ty (Contract_types.pair a b) + + and environment : environment -> Meta_michelson.Stack.ex_stack_ty result = fun env -> + let open Meta_michelson in + let%bind lst = + bind_map_list type_ + @@ List.map snd env in + let aux (Stack.Ex_stack_ty st) (Ex_ty cur) = + Stack.Ex_stack_ty (Stack.stack cur st) + in + ok @@ List.fold_right' aux (Ex_stack_ty Stack.nil) lst + +end + + +let base_type : type_base -> O.michelson result = + function + | Base_unit -> ok @@ O.prim T_unit + | Base_bool -> ok @@ O.prim T_bool + | Base_int -> ok @@ O.prim T_int + | Base_nat -> ok @@ O.prim T_nat + | Base_tez -> ok @@ O.prim T_mutez + | Base_string -> ok @@ O.prim T_string + | Base_address -> ok @@ O.prim T_address + | Base_bytes -> ok @@ O.prim T_bytes + | Base_operation -> ok @@ O.prim T_operation + +let rec type_ : type_value -> O.michelson result = + function + | T_base b -> base_type b + | T_pair (t, t') -> ( + type_ t >>? fun t -> + type_ t' >>? fun t' -> + ok @@ O.prim ~children:[t;t'] O.T_pair + ) + | T_or (t, t') -> ( + type_ t >>? fun t -> + type_ t' >>? fun t' -> + ok @@ O.prim ~children:[t;t'] O.T_or + ) + | T_map kv -> + let%bind (k', v') = bind_map_pair type_ kv in + ok @@ O.prim ~children:[k';v'] O.T_map + | T_list t -> + let%bind t' = type_ t in + ok @@ O.prim ~children:[t'] O.T_list + | T_option o -> + let%bind o' = type_ o in + ok @@ O.prim ~children:[o'] O.T_option + | T_contract o -> + let%bind o' = type_ o in + ok @@ O.prim ~children:[o'] O.T_contract + | T_function (arg, ret) -> + let%bind arg = type_ arg in + let%bind ret = type_ ret in + ok @@ O.prim ~children:[arg;ret] T_lambda + | T_deep_closure (c, arg, ret) -> + let%bind capture = environment_closure c in + let%bind arg = type_ arg in + let%bind ret = type_ ret in + ok @@ O.t_pair (O.t_lambda (O.t_pair arg capture) ret) capture + +and environment_element (name, tyv) = + let%bind michelson_type = type_ tyv in + ok @@ O.annotate ("@" ^ name) michelson_type + +and environment = fun env -> + bind_map_list type_ + @@ List.map snd env + +and environment_closure = + function + | [] -> simple_fail "Type of empty env" + | [a] -> type_ @@ snd a + | a :: b -> + let%bind a = type_ @@ snd a in + let%bind b = environment_closure b in + ok @@ O.t_pair a b diff --git a/compiler/dune b/compiler/dune new file mode 100644 index 000000000..5f94875b8 --- /dev/null +++ b/compiler/dune @@ -0,0 +1,15 @@ +(library + (name compiler) + (public_name ligo.compiler) + (libraries + simple-utils + tezos-utils + meta_michelson + mini_c + operators + ) + (preprocess + (pps simple-utils.ppx_let_generalized) + ) + (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Tezos_utils )) +) diff --git a/compiler/uncompiler.ml b/compiler/uncompiler.ml new file mode 100644 index 000000000..4f4b24cfb --- /dev/null +++ b/compiler/uncompiler.ml @@ -0,0 +1,91 @@ +open Trace +open Mini_c.Types +open Memory_proto_alpha +open Script_typed_ir +open Script_ir_translator + +let rec translate_value (Ex_typed_value (ty, value)) : value result = + match (ty, value) with + | Pair_t ((a_ty, _, _), (b_ty, _, _), _), (a, b) -> ( + let%bind a = translate_value @@ Ex_typed_value(a_ty, a) in + let%bind b = translate_value @@ Ex_typed_value(b_ty, b) in + ok @@ D_pair(a, b) + ) + | Union_t ((a_ty, _), _, _), L a -> ( + let%bind a = translate_value @@ Ex_typed_value(a_ty, a) in + ok @@ D_left a + ) + | Union_t (_, (b_ty, _), _), R b -> ( + let%bind b = translate_value @@ Ex_typed_value(b_ty, b) in + ok @@ D_right b + ) + | (Int_t _), n -> + let%bind n = + trace_option (simple_error "too big to fit an int") @@ + Alpha_context.Script_int.to_int n in + ok @@ D_int n + | (Nat_t _), n -> + let%bind n = + trace_option (simple_error "too big to fit an int") @@ + Alpha_context.Script_int.to_int n in + ok @@ D_nat n + | (Mutez_t _), n -> + let%bind n = + generic_try (simple_error "too big to fit an int") @@ + (fun () -> Int64.to_int @@ Alpha_context.Tez.to_mutez n) in + ok @@ D_nat n + | (Bool_t _), b -> + ok @@ D_bool b + | (String_t _), s -> + ok @@ D_string s + | (Address_t _), s -> + ok @@ D_string (Alpha_context.Contract.to_b58check s) + | (Unit_t _), () -> + ok @@ D_unit + | (Option_t _), None -> + ok @@ D_none + | (Option_t ((o_ty, _), _, _)), Some s -> + let%bind s' = translate_value @@ Ex_typed_value (o_ty, s) in + ok @@ D_some s' + | (Map_t (k_cty, v_ty, _)), m -> + let k_ty = Script_ir_translator.ty_of_comparable_ty k_cty in + let lst = + let aux k v acc = (k, v) :: acc in + let lst = Script_ir_translator.map_fold aux m [] in + List.rev lst in + let%bind lst' = + let aux (k, v) = + let%bind k' = translate_value (Ex_typed_value (k_ty, k)) in + let%bind v' = translate_value (Ex_typed_value (v_ty, v)) in + ok (k', v') + in + bind_map_list aux lst + in + ok @@ D_map lst' + | (List_t (ty, _)), lst -> + let lst' = + let aux acc cur = cur :: acc in + let lst = List.fold_left aux lst [] in + List.rev lst in + let%bind lst'' = + let aux = fun t -> translate_value (Ex_typed_value (ty, t)) in + bind_map_list aux lst' + in + ok @@ D_list lst'' + | (Operation_t _) , op -> + ok @@ D_operation op + | ty, v -> + let%bind error = + let%bind m_data = + trace_tzresult_lwt (simple_error "unparsing unrecognized data") @@ + Tezos_utils.Memory_proto_alpha.unparse_michelson_data ty v in + let%bind m_ty = + trace_tzresult_lwt (simple_error "unparsing unrecognized data") @@ + Tezos_utils.Memory_proto_alpha.unparse_michelson_ty ty in + let error_content () = + Format.asprintf "%a : %a" + Michelson.pp m_data + Michelson.pp m_ty in + ok @@ (fun () -> error (thunk "this value can't be transpiled back yet") error_content ()) + in + fail error diff --git a/contracts/annotation.ligo b/contracts/annotation.ligo new file mode 100644 index 000000000..1cae3ffe9 --- /dev/null +++ b/contracts/annotation.ligo @@ -0,0 +1,5 @@ +const lst : list(int) = list [] ; + +const address : address = "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" ; + +const address_2 : address = ("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address) ; diff --git a/contracts/arithmetic.ligo b/contracts/arithmetic.ligo new file mode 100644 index 000000000..25b756b04 --- /dev/null +++ b/contracts/arithmetic.ligo @@ -0,0 +1,17 @@ +function mod_op (const n : int) : nat is + begin skip end with n mod 42 + +function plus_op (const n : int) : int is + begin skip end with n + 42 + +function minus_op (const n : int) : int is + begin skip end with n - 42 + +function times_op (const n : int) : int is + begin skip end with n * 42 + +function div_op (const n : int) : int is + begin skip end with n / 2 + +function int_op (const n : nat) : int is + block { skip } with int(n) diff --git a/contracts/basic.mligo b/contracts/basic.mligo new file mode 100644 index 000000000..34be829e0 --- /dev/null +++ b/contracts/basic.mligo @@ -0,0 +1,3 @@ +type toto = int + +let foo : toto = 42 + 127 diff --git a/contracts/boolean_operators.ligo b/contracts/boolean_operators.ligo new file mode 100644 index 000000000..38b94ba02 --- /dev/null +++ b/contracts/boolean_operators.ligo @@ -0,0 +1,11 @@ +function or_true (const b : bool) : bool is + begin skip end with b or True + +function or_false (const b : bool) : bool is + begin skip end with b or False + +function and_true (const b : bool) : bool is + begin skip end with b and True + +function and_false (const b : bool) : bool is + begin skip end with b and False diff --git a/contracts/closure.ligo b/contracts/closure.ligo new file mode 100644 index 000000000..d43d5400f --- /dev/null +++ b/contracts/closure.ligo @@ -0,0 +1,11 @@ +function foo (const i : int) : int is + function bar (const j : int) : int is + block { skip } with i + j ; + block { skip } with bar (i) + +function toto (const i : int) : int is + function tata (const j : int) : int is + block { skip } with i + j ; + function titi (const j : int) : int is + block { skip } with i + j ; + block { skip } with tata(i) + titi(i) diff --git a/contracts/coase.ligo b/contracts/coase.ligo new file mode 100644 index 000000000..8d5ad912f --- /dev/null +++ b/contracts/coase.ligo @@ -0,0 +1,98 @@ +// Copyright Coase, Inc 2019 + +type card_pattern_id is nat +type card_pattern is record [ + coefficient : tez ; + quantity : nat ; +] + +type card_patterns is map(card_pattern_id , card_pattern) + +type card_id is nat +type card is record [ + card_owner : address ; + card_pattern : card_pattern_id ; +] +type cards is map(card_id , card) + +type storage_type is record [ + cards : cards ; + card_patterns : card_patterns ; + next_id : nat ; +] + +type action_buy_single is record [ + card_to_buy : card_pattern_id ; +] +type action_sell_single is record [ + card_to_sell : card_id ; +] +type action_transfer_single is record [ + card_to_transfer : card_id ; + destination : address ; +] + +type action is +| Buy_single of action_buy_single +| Sell_single of action_sell_single +| Transfer_single of action_transfer_single + +function transfer_single(const action : action_transfer_single ; const s : storage_type) : (list(operation) * storage_type) is + begin + const cards : cards = s.cards ; + const card : card = get_force(action.card_to_transfer , cards) ; + if (card.card_owner =/= source) then fail "This card doesn't belong to you" else skip ; + card.card_owner := action.destination ; + cards[action.card_to_transfer] := card ; + s.cards := cards ; + const operations : list(operation) = nil ; + end with (operations , s) ; + +function sell_single(const action : action_sell_single ; const s : storage_type) : (list(operation) * storage_type) is + begin + const card : card = get_force(action.card_to_sell , s.cards) ; + if (card.card_owner =/= source) then fail "This card doesn't belong to you" else skip ; + const card_pattern : card_pattern = get_force(card.card_pattern , s.card_patterns) ; + card_pattern.quantity := abs(card_pattern.quantity - 1n); + const card_patterns : card_patterns = s.card_patterns ; + card_patterns[card.card_pattern] := card_pattern ; + s.card_patterns := card_patterns ; + const cards : cards = s.cards ; + remove action.card_to_sell from map cards ; + s.cards := cards ; + const price : tez = card_pattern.coefficient * card_pattern.quantity ; + const receiver : contract(unit) = get_contract(source) ; + const op : operation = transaction(unit , price , receiver) ; + const operations : list(operation) = list op end ; + end with (operations , s) + +function buy_single(const action : action_buy_single ; const s : storage_type) : (list(operation) * storage_type) is + begin + // Check funds + const card_pattern : card_pattern = get_force(action.card_to_buy , s.card_patterns) ; + const price : tez = card_pattern.coefficient * (card_pattern.quantity + 1n) ; + if (price > amount) then fail "Not enough money" else skip ; + // Administrative procedure + const operations : list(operation) = nil ; + // Increase quantity + card_pattern.quantity := card_pattern.quantity + 1n ; + const card_patterns : card_patterns = s.card_patterns ; + card_patterns[action.card_to_buy] := card_pattern ; + s.card_patterns := card_patterns ; + // Add card + const cards : cards = s.cards ; + cards[s.next_id] := record + card_owner = source ; + card_pattern = action.card_to_buy ; + end ; + s.cards := cards ; + s.next_id := s.next_id + 1n ; + end with (operations , s) + +function main(const action : action ; const s : storage_type) : (list(operation) * storage_type) is + block {skip} with + case action of + | Buy_single bs -> buy_single (bs , s) + | Sell_single as -> sell_single (as , s) + | Transfer_single at -> transfer_single (at , s) + end diff --git a/contracts/condition.ligo b/contracts/condition.ligo new file mode 100644 index 000000000..68c949640 --- /dev/null +++ b/contracts/condition.ligo @@ -0,0 +1,8 @@ +function main (const i : int) : int is + var result : int := 23 ; + begin + if i = 2 then + result := 42 + else + result := 0 + end with result diff --git a/contracts/counter.ligo b/contracts/counter.ligo new file mode 100644 index 000000000..469681a4c --- /dev/null +++ b/contracts/counter.ligo @@ -0,0 +1,6 @@ +type some_type is int + +function main (const p : int ; const s : some_type) : (list(operation) * int) is + block { skip } // skip is a do nothing instruction, needed for empty blocks + with ((nil : list(operation)), p + s) + diff --git a/contracts/counter.mligo b/contracts/counter.mligo new file mode 100644 index 000000000..0cfa95bdf --- /dev/null +++ b/contracts/counter.mligo @@ -0,0 +1,4 @@ +type storage = int + +let%entry main (p:int) storage = + (list [] : operation list , p + storage) diff --git a/contracts/declarations.ligo b/contracts/declarations.ligo new file mode 100644 index 000000000..c153b0c57 --- /dev/null +++ b/contracts/declarations.ligo @@ -0,0 +1,6 @@ +const foo : int = 42 + +function main (const i : int) : int is + begin + skip + end with i + foo diff --git a/contracts/dispatch-counter.ligo b/contracts/dispatch-counter.ligo new file mode 100644 index 000000000..c8c59250a --- /dev/null +++ b/contracts/dispatch-counter.ligo @@ -0,0 +1,16 @@ +type action is +| Increment of int +| Decrement of int + +function increment(const i : int ; const n : int) : int is + block { skip } with (i + n) + +function decrement(const i : int ; const n : int) : int is + block { skip } with (i - n) + +function main (const p : action ; const s : int) : (list(operation) * int) is + block {skip} with ((nil : list(operation)), + case p of + | Increment n -> increment(s , n) + | Decrement n -> decrement(s , n) + end) diff --git a/contracts/function-complex.ligo b/contracts/function-complex.ligo new file mode 100644 index 000000000..ec34cab7e --- /dev/null +++ b/contracts/function-complex.ligo @@ -0,0 +1,7 @@ +function main (const i : int) : int is + var j : int := 0 ; + var k : int := 1 ; + begin + j := k + i ; + k := i + j ; + end with (k + j) diff --git a/contracts/function-shared.ligo b/contracts/function-shared.ligo new file mode 100644 index 000000000..c84fec402 --- /dev/null +++ b/contracts/function-shared.ligo @@ -0,0 +1,8 @@ +function inc ( const i : int ) : int is + block { skip } with i + 1 + +function double_inc ( const i : int ) : int is + block { skip } with inc(i + 1) + +function foo ( const i : int ) : int is + block { skip } with inc(i) + double_inc(i) diff --git a/contracts/function.ligo b/contracts/function.ligo new file mode 100644 index 000000000..8149b2e15 --- /dev/null +++ b/contracts/function.ligo @@ -0,0 +1,4 @@ +function main (const i : int) : int is + begin + skip + end with i diff --git a/contracts/heap-instance.ligo b/contracts/heap-instance.ligo new file mode 100644 index 000000000..b214f0fab --- /dev/null +++ b/contracts/heap-instance.ligo @@ -0,0 +1,6 @@ +type heap_element is int * string + +function heap_element_lt(const x : heap_element ; const y : heap_element) : bool is + block { skip } with x.0 < y.0 + +#include "heap.ligo" diff --git a/contracts/heap.ligo b/contracts/heap.ligo new file mode 100644 index 000000000..23d7425b7 --- /dev/null +++ b/contracts/heap.ligo @@ -0,0 +1,90 @@ +type heap is map(nat, heap_element) ; + +function is_empty (const h : heap) : bool is + block {skip} with size(h) = 0n + +function get_top (const h : heap) : heap_element is + block {skip} with get_force(1n, h) + +function pop_switch (const h : heap) : heap is + block { + const result : heap_element = get_top (h) ; + const s : nat = size(h) ; + const last : heap_element = get_force(s, h) ; + remove 1n from map h ; + h[1n] := last ; + } with h + +function pop_ (const h : heap) : nat is + begin + const result : heap_element = get_top (h) ; + const s : nat = size(h) ; + var current : heap_element := get_force(s, h) ; + const i : nat = 1n ; + const left : nat = 2n * i ; + const right : nat = left + 1n ; + remove 1n from map h ; + h[1n] := current ; + var largest : nat := i ; + if (left <= s and heap_element_lt(get_force(s , h) , get_force(left , h))) then + largest := left + else if (right <= s and heap_element_lt(get_force(s , h) , get_force(right , h))) then + largest := right + else skip + end with largest + +function insert (const h : heap ; const e : heap_element) : heap is + begin + var i : nat := size(h) + 1n ; + h[i] := e ; + var largest : nat := i ; + var parent : nat := 0n ; + while (largest =/= i) block { + parent := i / 2n ; + largest := i ; + if (parent >= 1n) then block { + if (heap_element_lt(get_force(parent , h) , get_force(i , h))) then block { + largest := parent ; + const tmp : heap_element = get_force(i , h) ; + h[i] := get_force(parent , h) ; + h[parent] := tmp ; + } else skip + } else skip + } + end with h + +function pop (const h : heap) : (heap * heap_element * nat) is + begin + const result : heap_element = get_top (h) ; + var s : nat := size(h) ; + const last : heap_element = get_force(s, h) ; + remove s from map h ; + h[1n] := last ; + s := size(h) ; + var i : nat := 0n ; + var largest : nat := 1n ; + var left : nat := 0n ; + var right : nat := 0n ; + var c : nat := 0n ; + while (largest =/= i) block { + c := c + 1n ; + i := largest ; + left := 2n * i ; + right := left + 1n ; + if (left <= s) then begin + if (heap_element_lt(get_force(left , h) , get_force(i , h))) then begin + largest := left ; + const tmp : heap_element = get_force(i , h) ; + h[i] := get_force(left , h) ; + h[left] := tmp ; + end else skip ; + end else if (right <= s) then begin + if (heap_element_lt(get_force(right , h) , get_force(i , h))) then begin + largest := right ; + const tmp : heap_element = get_force(i , h) ; + h[i] := get_force(right , h) ; + h[left] := tmp ; + end else skip ; + end else skip ; + } + end with (h , result , c) diff --git a/contracts/high-order.ligo b/contracts/high-order.ligo new file mode 100644 index 000000000..8dc7f3e4b --- /dev/null +++ b/contracts/high-order.ligo @@ -0,0 +1,6 @@ +function foobar (const i : int) : int is + function foo (const i : int) : int is + block { skip } with i ; + function bar (const f : int -> int) : int is + block { skip } with f ( i ) ; + block { skip } with bar (foo) ; diff --git a/contracts/included.ligo b/contracts/included.ligo new file mode 100644 index 000000000..3f0a2d1ca --- /dev/null +++ b/contracts/included.ligo @@ -0,0 +1 @@ +const foo : int = 144 diff --git a/contracts/includer.ligo b/contracts/includer.ligo new file mode 100644 index 000000000..e68975796 --- /dev/null +++ b/contracts/includer.ligo @@ -0,0 +1,3 @@ +#include "included.ligo" + +const bar : int = foo diff --git a/contracts/list.ligo b/contracts/list.ligo new file mode 100644 index 000000000..60af05003 --- /dev/null +++ b/contracts/list.ligo @@ -0,0 +1,19 @@ +type foobar is list(int) + +const fb : foobar = list + 23 ; + 42 ; +end + +function size_ (const m : foobar) : nat is + block {skip} with (size(m)) + +// function hdf (const m : foobar) : int is begin skip end with hd(m) + +const bl : foobar = list + 144 ; + 51 ; + 42 ; + 120 ; + 421 ; +end diff --git a/contracts/loop.ligo b/contracts/loop.ligo new file mode 100644 index 000000000..0408f85ef --- /dev/null +++ b/contracts/loop.ligo @@ -0,0 +1,19 @@ +function counter (var n : nat) : nat is block { + var i : nat := 0n ; + while (i < n) block { + i := i + 1n ; + } +} with i + +function sum (var n : nat) : nat is block { + var i : nat := 0n ; + var r : nat := 0n ; + while (i < n) block { + i := i + 1n ; + r := r + i ; + } +} with r + +function dummy (const n : nat) : nat is block { + while (False) block { skip } +} with n diff --git a/contracts/map.ligo b/contracts/map.ligo new file mode 100644 index 000000000..bcc2a8005 --- /dev/null +++ b/contracts/map.ligo @@ -0,0 +1,33 @@ +type foobar is map(int, int) + +const fb : foobar = map + 23 -> 0 ; + 42 -> 0 ; +end + +function set_ (var n : int ; var m : foobar) : foobar is block { + m[23] := n ; +} with m + + +function rm (var m : foobar) : foobar is block { + remove 42 from map m +} with m + +function size_ (const m : foobar) : nat is + block {skip} with (size(m)) + +function gf (const m : foobar) : int is begin skip end with get_force(23, m) + +function get (const m : foobar) : option(int) is + begin + skip + end with m[42] + +const bm : foobar = map + 144 -> 23 ; + 51 -> 23 ; + 42 -> 23 ; + 120 -> 23 ; + 421 -> 23 ; +end diff --git a/contracts/match.ligo b/contracts/match.ligo new file mode 100644 index 000000000..57a74d7dd --- /dev/null +++ b/contracts/match.ligo @@ -0,0 +1,31 @@ +function match_bool (const i : int) : int is + var result : int := 23 ; + begin + case i = 2 of + | True -> result := 42 + | False -> result := 0 + end + end with result + +function match_option (const o : option(int)) : int is + var result : int := 23 ; + begin + case o of + | None -> skip + | Some(s) -> result := s + end + end with result + +function match_expr_bool (const i : int) : int is + begin skip end with + case i = 2 of + | 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/contracts/multiple-parameters.ligo b/contracts/multiple-parameters.ligo new file mode 100644 index 000000000..fe2373076 --- /dev/null +++ b/contracts/multiple-parameters.ligo @@ -0,0 +1,8 @@ +function ab(const a : int; const b : int) : int is + begin skip end with (a + b) + +function abcd(const a : int; const b : int; const c : int; const d : int) : int is + begin skip end with (a + b + c + d + 2) + +function abcde(const a : int; const b : int; const c : int; const d : int; const e : int) : int is + begin skip end with (c + e + 3) diff --git a/contracts/new-syntax.mligo b/contracts/new-syntax.mligo new file mode 100644 index 000000000..f2fed5396 --- /dev/null +++ b/contracts/new-syntax.mligo @@ -0,0 +1,21 @@ +(** Type of storage for this contract *) +type storage = { + challenge : string ; +} + +(** Initial storage *) +let%init storage = { + challenge = "" ; +} + +type param = { + new_challenge : string ; + attempt : bytes ; +} + +let%entry attempt (p:param) storage = + if Crypto.hash (Bytes.pack p.attempt) <> Bytes.pack storage.challenge then failwith "Failed challenge" ; + let contract : unit contract = Operation.get_contract sender in + let transfer : operation = Operation.transaction (unit , contract , 10.00tz) in + let storage : storage = storage.challenge <- p.new_challenge in + ((list [] : operation list), storage) diff --git a/contracts/option.ligo b/contracts/option.ligo new file mode 100644 index 000000000..85e3396e0 --- /dev/null +++ b/contracts/option.ligo @@ -0,0 +1,4 @@ +type foobar is option(int) + +const s : foobar = Some(42) +const n : foobar = None diff --git a/contracts/quote-declaration.ligo b/contracts/quote-declaration.ligo new file mode 100644 index 000000000..4c5547d4c --- /dev/null +++ b/contracts/quote-declaration.ligo @@ -0,0 +1,8 @@ +function foo (const input : int) : int is begin + skip +end with (input + 42) + +function main (const i : int) : int is + begin + skip + end with i + foo (i) diff --git a/contracts/quote-declarations.ligo b/contracts/quote-declarations.ligo new file mode 100644 index 000000000..1b783066d --- /dev/null +++ b/contracts/quote-declarations.ligo @@ -0,0 +1,13 @@ +function foo (const input : int) : int is begin + skip +end with (input + 23) + +function bar (const input : int) : int is begin + skip +end with (input + 51) + + +function main (const i : int) : int is + begin + skip + end with foo (i) + bar (i) diff --git a/contracts/record.ligo b/contracts/record.ligo new file mode 100644 index 000000000..e0fbb5d04 --- /dev/null +++ b/contracts/record.ligo @@ -0,0 +1,56 @@ +type foobar is record + foo : int ; + bar : int ; +end + +const fb : foobar = record + foo = 0 ; + bar = 0 ; +end + +type abc is record + a : int ; + b : int ; + c : int ; +end + +const abc : abc = record + a = 42 ; + b = 142 ; + c = 242 ; +end + +const a : int = abc.a ; +const b : int = abc.b ; +const c : int = abc.c ; + +function projection (const r : foobar) : int is + begin + skip + end with r.foo + r.bar + +function modify (const r : foobar) : foobar is + block { + r.foo := 256 ; + } with r + +function modify_abc (const r : abc) : abc is + block { + r.b := 2048 ; + } with r + +type big_record is record + a : int ; + b : int ; + c : int ; + d : int ; + e : int ; +end + +const br : big_record = record + a = 23 ; + b = 23 ; + c = 23 ; + d = 23 ; + e = 23 ; +end diff --git a/contracts/shadow.ligo b/contracts/shadow.ligo new file mode 100644 index 000000000..4232cb0a6 --- /dev/null +++ b/contracts/shadow.ligo @@ -0,0 +1,4 @@ +function foo (const i : int) : int is + function bar (const i : int) : int is + block { skip } with i ; + block { skip } with bar (0) diff --git a/contracts/string.ligo b/contracts/string.ligo new file mode 100644 index 000000000..ae54f8c09 --- /dev/null +++ b/contracts/string.ligo @@ -0,0 +1 @@ +const s : string = "toto" diff --git a/contracts/super-counter.ligo b/contracts/super-counter.ligo new file mode 100644 index 000000000..45ce7462a --- /dev/null +++ b/contracts/super-counter.ligo @@ -0,0 +1,10 @@ +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 : list(operation)), + case p of + | Increment n -> s + n + | Decrement n -> s - n + end) diff --git a/contracts/toto.ligo b/contracts/toto.ligo new file mode 100644 index 000000000..785655b4a --- /dev/null +++ b/contracts/toto.ligo @@ -0,0 +1,6 @@ +type toto is record + a : nat ; + b : nat +end + +const foo : int = 3 diff --git a/contracts/tuple.ligo b/contracts/tuple.ligo new file mode 100644 index 000000000..9a39cde03 --- /dev/null +++ b/contracts/tuple.ligo @@ -0,0 +1,22 @@ +type abc is (int * int * int) + +function projection_abc (const tpl : abc) : int is + block { skip } with tpl.1 + +function modify_abc (const tpl : abc) : abc is + block { + tpl.1 := 2048 ; + } with tpl + +type foobar is (int * int) + +const fb : foobar = (0, 0) + +function projection (const tpl : foobar) : int is + begin + skip + end with tpl.0 + tpl.1 + +type big_tuple is (int * int * int * int * int) + +const br : big_tuple = (23, 23, 23, 23, 23) diff --git a/contracts/unit.ligo b/contracts/unit.ligo new file mode 100644 index 000000000..5b05cb2b7 --- /dev/null +++ b/contracts/unit.ligo @@ -0,0 +1 @@ +const u : unit = unit diff --git a/contracts/variant-matching.ligo b/contracts/variant-matching.ligo new file mode 100644 index 000000000..5c13a5053 --- /dev/null +++ b/contracts/variant-matching.ligo @@ -0,0 +1,11 @@ +type foobar is +| Foo of int +| Bar of bool +| Kee of nat + +function fb(const p : foobar) : int is + block { skip } with (case p of + | Foo (n) -> n + | Bar (t) -> 42 + | Kee (n) -> 23 + end) diff --git a/contracts/variant.ligo b/contracts/variant.ligo new file mode 100644 index 000000000..b98001a02 --- /dev/null +++ b/contracts/variant.ligo @@ -0,0 +1,10 @@ +type foobar is +| Foo of int +| Bar of bool +| Kee of nat + +const foo : foobar = Foo (42) + +const bar : foobar = Bar (True) + +const kee : foobar = Kee (23n) diff --git a/dune b/dune new file mode 100644 index 000000000..5f4aa3ebd --- /dev/null +++ b/dune @@ -0,0 +1,25 @@ +(library + (name ligo) + (public_name ligo) + (libraries + simple-utils + tezos-utils + tezos-micheline + meta_michelson + main + ) + (preprocess + (pps simple-utils.ppx_let_generalized) + ) +) + +(alias +( name ligo-test) + (action (run test/test.exe)) + (deps (glob_files contracts/*)) +) + +(alias + (name runtest) + (deps (alias ligo-test)) +) diff --git a/dune-project b/dune-project new file mode 100644 index 000000000..13109bb9b --- /dev/null +++ b/dune-project @@ -0,0 +1,2 @@ +(lang dune 1.6) +(using menhir 2.0) diff --git a/ligo.ml b/ligo.ml new file mode 100644 index 000000000..1e27a74ab --- /dev/null +++ b/ligo.ml @@ -0,0 +1 @@ +include Main diff --git a/ligo.opam b/ligo.opam new file mode 100644 index 000000000..9294b375f --- /dev/null +++ b/ligo.opam @@ -0,0 +1,28 @@ +name: "ligo" +opam-version: "2.0" +version: "1.0" +maintainer: "gabriel.alfour@gmail.com" +authors: [ "Galfour" ] +homepage: "https://gitlab.com/gabriel.alfour/tezos" +bug-reports: "https://gitlab.com/gabriel.alfour/tezos/issues" +synopsis: "A higher-level language which compiles to Michelson" +dev-repo: "git+https://gitlab.com/gabriel.alfour/tezos.git" +license: "MIT" +depends: [ + "ocamlfind" { build } + "dune" { build & >= "1.0.1" } + "menhir" + "ppx_let" + "ppx_deriving" + "tezos-utils" + "yojson" + "alcotest" { with-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 { + src: "https://gitlab.com/gabriel.alfour/tezos/-/archive/master/tezos.tar.gz" +} diff --git a/main/contract.ml b/main/contract.ml new file mode 100644 index 000000000..ff3f8a98b --- /dev/null +++ b/main/contract.ml @@ -0,0 +1,178 @@ +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 + +include struct + open Ast_typed + open Combinators + + 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 (arg' , 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 (arg' , storage_param) + + 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 , _) -> 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 + (e:Ast_typed.annotated_expression) : Mini_c.value result = + let%bind f = + let open Transpiler in + let (f , _) = functionalize e in + let%bind main = translate_main f 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 mini_c = + trace (simple_error "transpiling") @@ + Transpiler.translate_entry typed entry_point in + let%bind michelson = + trace (simple_error "compiling") @@ + Compiler.translate_contract mini_c in + let str = + 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 -> + let%bind (program , 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 (param_ty , _) = + get_entry_point typed entry_point in + ok (typed , param_ty) + 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 = + 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 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 + 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_stripped michelson in + ok str + in + ok expr + + +let compile_contract_storage : string -> string -> string -> string result = fun source entry_point expression -> + let%bind (program , storage_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 (_ , storage_ty) = + get_entry_point typed entry_point in + ok (typed , storage_ty) + 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 = + 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 env simplified in + let%bind () = + trace (simple_error "expression type doesn't match type storage") @@ + Ast_typed.assert_type_value_eq (storage_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_stripped michelson in + ok str + in + ok expr diff --git a/main/dune b/main/dune new file mode 100644 index 000000000..4135d0514 --- /dev/null +++ b/main/dune @@ -0,0 +1,21 @@ +(library + (name main) + (public_name ligo.main) + (libraries + simple-utils + tezos-utils + parser + simplify + ast_simplified + typer + ast_typed + transpiler + mini_c + operators + compiler + ) + (preprocess + (pps simple-utils.ppx_let_generalized) + ) + (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Tezos_utils )) +) diff --git a/main/main.ml b/main/main.ml new file mode 100644 index 000000000..34bd70fe1 --- /dev/null +++ b/main/main.ml @@ -0,0 +1,197 @@ +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 , _) = functionalize e in + let%bind main = translate_main f 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) ?options (entry:string) + (program:AST_Typed.program) (input:AST_Typed.annotated_expression) : AST_Typed.annotated_expression result = + let%bind () = + let open Ast_typed in + let%bind (Declaration_constant (d , _)) = get_declaration_by_name program entry in + let%bind (arg_ty , _) = + trace_strong (simple_error "entry-point doesn't have a function type") @@ + get_t_function @@ get_type_annotation d.annotated_expression in + Ast_typed.assert_type_value_eq (arg_ty , (Ast_typed.get_type_annotation input)) + in + + 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) + ) ; + + 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 + in + error title content in + trace error @@ + Run_mini_c.run_entry ?options 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) ?(debug_michelson = false) ?options (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) + ) ; + + 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 = + let error = + let title () = "run Mini_c" in + let content () = + Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main + in + error title content in + trace error @@ + Run_mini_c.run_entry ~debug_michelson ?options 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 + +module Contract = Contract diff --git a/main/run_mini_c.ml b/main/run_mini_c.ml new file mode 100644 index 000000000..5fb8d908f --- /dev/null +++ b/main/run_mini_c.ml @@ -0,0 +1,60 @@ +open Trace +open Mini_c +open! Compiler.Program +open Memory_proto_alpha.Script_ir_translator + +let run_aux ?options (program:compiled_program) (input_michelson:Michelson.t) : ex_typed_value result = + let Compiler.Program.{input;output;body} : compiled_program = program in + let (Ex_ty input_ty) = input in + let (Ex_ty output_ty) = output in + let%bind input = + Trace.trace_tzresult_lwt (simple_error "error parsing input") @@ + Tezos_utils.Memory_proto_alpha.parse_michelson_data input_michelson input_ty in + let body = Michelson.strip_annots body in + let%bind descr = + Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@ + Tezos_utils.Memory_proto_alpha.parse_michelson body + (Stack.(input_ty @: nil)) (Stack.(output_ty @: nil)) in + let open! Memory_proto_alpha.Script_interpreter in + let%bind (Item(output, Empty)) = + Trace.trace_tzresult_lwt (simple_error "error of execution") @@ + Tezos_utils.Memory_proto_alpha.interpret ?options descr (Item(input, Empty)) in + ok (Ex_typed_value (output_ty, output)) + +let run_node (program:program) (input:Michelson.t) : Michelson.t result = + let%bind compiled = translate_program program "main" in + let%bind (Ex_typed_value (output_ty, output)) = run_aux compiled input in + let%bind output = + Trace.trace_tzresult_lwt (simple_error "error unparsing output") @@ + Tezos_utils.Memory_proto_alpha.unparse_michelson_data output_ty output in + ok output + +let run_entry ?(debug_michelson = false) ?options (entry:anon_function) (input:value) : value result = + let%bind compiled = + let error = + let title () = "compile entry" in + let content () = + Format.asprintf "%a" PP.function_ entry + in + error title content in + trace error @@ + translate_entry entry in + if debug_michelson then Format.printf "Program: %a\n" Michelson.pp compiled.body ; + let%bind input_michelson = translate_value input in + let%bind ex_ty_value = run_aux ?options compiled input_michelson in + let%bind (result : value) = Compiler.Uncompiler.translate_value ex_ty_value in + ok result + +let run (program:program) (input:value) : value result = + let%bind input_michelson = translate_value input in + let%bind compiled = translate_program program "main" in + let%bind ex_ty_value = run_aux compiled input_michelson in + let%bind (result : value) = Compiler.Uncompiler.translate_value ex_ty_value in + ok result + +let expression_to_value (e:expression) : value result = + match (Combinators.Expression.get_content e) with + | E_literal v -> ok v + | _ -> fail + @@ error (thunk "not a value") + @@ (fun () -> Format.asprintf "%a" PP.expression e) diff --git a/meta_michelson/alpha_wrap.ml b/meta_michelson/alpha_wrap.ml new file mode 100644 index 000000000..196f6a9c4 --- /dev/null +++ b/meta_michelson/alpha_wrap.ml @@ -0,0 +1,30 @@ +open Tezos_utils.Error_monad + +let dummy_environment = force_lwt ~msg:"getting dummy env" @@ Misc.init_environment () + +let tc = dummy_environment.tezos_context + +module Proto_alpha = Tezos_utils.Memory_proto_alpha +open Proto_alpha +open Alpha_context +open Alpha_environment + +let pack ty v = fst @@ force_lwt_alpha ~msg:"packing" @@ Script_ir_translator.pack_data tc ty v +let unpack_opt (type a) : a Script_typed_ir.ty -> MBytes.t -> a option = fun ty bytes -> + force_lwt ~msg:"unpacking : parse" ( + if Compare.Int.(MBytes.length bytes >= 1) && + Compare.Int.(MBytes.get_uint8 bytes 0 = 0x05) then + let bytes = MBytes.sub bytes 1 (MBytes.length bytes - 1) in + match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with + | None -> return None + | Some expr -> + Script_ir_translator.parse_data tc ty (Micheline.root expr) >>=?? fun x -> return (Some (fst x)) + else + return None + ) + +let unpack ty a = match unpack_opt ty a with + | None -> raise @@ Failure "unpacking : of_bytes" + | Some x -> x + +let blake2b b = Alpha_environment.Raw_hashes.blake2b b diff --git a/meta_michelson/contract.ml b/meta_michelson/contract.ml new file mode 100644 index 000000000..1c1b7ccd8 --- /dev/null +++ b/meta_michelson/contract.ml @@ -0,0 +1,316 @@ +open Misc + +open Tezos_utils.Error_monad +open Memory_proto_alpha +open Alpha_context + +open Script_ir_translator +open Script_typed_ir + +module Option = Simple_utils.Option +module Cast = Tezos_utils.Cast + +type ('param, 'storage) toplevel = { + param_type : 'param ty ; + storage_type : 'storage ty ; + code : ('param * 'storage, packed_internal_operation list * 'storage) lambda +} + +type ex_toplevel = + Ex_toplevel : ('a, 'b) toplevel -> ex_toplevel + +let get_toplevel ?environment toplevel_path claimed_storage_type claimed_parameter_type = + let toplevel_str = Streams.read_file toplevel_path in + contextualize ?environment ~msg:"toplevel" @@ fun {tezos_context = context ; _ } -> + let toplevel_expr = Cast.tl_of_string toplevel_str in + let (param_ty_node, storage_ty_node, code_field) = + force_ok_alpha ~msg:"parsing toplevel" @@ + parse_toplevel toplevel_expr in + let (Ex_ty param_type, _) = + force_ok_alpha ~msg:"parse arg ty" @@ + Script_ir_translator.parse_ty context ~allow_big_map:false ~allow_operation:false param_ty_node in + let (Ex_ty storage_type, _) = + force_ok_alpha ~msg:"parse storage ty" @@ + parse_storage_ty context storage_ty_node in + let _ = force_ok_alpha ~msg:"storage eq" @@ Script_ir_translator.ty_eq context storage_type claimed_storage_type in + let _ = force_ok_alpha ~msg:"param eq" @@ Script_ir_translator.ty_eq context param_type claimed_parameter_type in + let param_type_full = Pair_t ((claimed_parameter_type, None, None), + (claimed_storage_type, None, None), None) in + let ret_type_full = + Pair_t ((List_t (Operation_t None, None), None, None), + (claimed_storage_type, None, None), None) in + parse_returning (Toplevel { storage_type = claimed_storage_type ; param_type = claimed_parameter_type }) + context (param_type_full, None) ret_type_full code_field >>=?? fun (code, _) -> + Error_monad.return { + param_type = claimed_parameter_type; + storage_type = claimed_storage_type; + code ; + } + +let make_toplevel code storage_type param_type = + { param_type ; storage_type ; code } + +module type ENVIRONMENT = sig + val identities : identity list + val tezos_context : t +end + +type ex_typed_stack = Ex_typed_stack : ('a stack_ty * 'a Script_interpreter.stack) -> ex_typed_stack + +open Error_monad + +module Step (Env: ENVIRONMENT) = struct + open Env + + type config = { + source : Contract.t option ; + payer : Contract.t option ; + self : Contract.t option ; + visitor : (Script_interpreter.ex_descr_stack -> unit) option ; + timestamp : Script_timestamp.t option ; + debug_visitor : (ex_typed_stack -> unit) option ; + amount : Tez.t option ; + } + + let no_config = { + source = None ; + payer = None ; + self = None ; + visitor = None ; + debug_visitor = None ; + timestamp = None ; + amount = None ; + } + + let of_param base param = match param with + | None -> base + | Some _ as x -> x + + let make_config ?base_config ?source ?payer ?self ?visitor ?debug_visitor ?timestamp ?amount () = + let base_config = Option.unopt ~default:no_config base_config in { + source = Option.first_some source base_config.source ; + payer = Option.first_some payer base_config.payer ; + self = Option.first_some self base_config.self ; + visitor = Option.first_some visitor base_config.visitor ; + debug_visitor = Option.first_some debug_visitor base_config.debug_visitor ; + timestamp = Option.first_some timestamp base_config.timestamp ; + amount = Option.first_some amount base_config.amount ; + } + + open Error_monad + + let debug_visitor ?f () = + let open Script_interpreter in + let aux (Ex_descr_stack (descr, stack)) = + (match (descr.instr, descr.bef) with + | Nop, Item_t (String_t _, stack_ty, _) -> ( + let (Item (s, stack)) = stack in + if s = "_debug" + then ( + match f with + | None -> Format.printf "debug: %s\n%!" @@ Cast.stack_to_string stack_ty stack + | Some f -> f (Ex_typed_stack(stack_ty, stack)) + ) else () + ) + | _ -> ()) ; + () in + aux + + let step_lwt ?(config=no_config) (stack:'a Script_interpreter.stack) (code:('a, 'b) descr) = + let source = Option.unopt + ~default:(List.nth identities 0).implicit_contract config.source in + let payer = Option.unopt + ~default:(List.nth identities 1).implicit_contract config.payer in + let self = Option.unopt + ~default:(List.nth identities 2).implicit_contract config.self in + let amount = Option.unopt ~default:(Tez.one) config.amount in + let visitor = + let default = debug_visitor ?f:config.debug_visitor () in + Option.unopt ~default config.visitor in + let tezos_context = match config.timestamp with + | None -> tezos_context + | Some s -> Alpha_context.Script_timestamp.set_now tezos_context s in + Script_interpreter.step tezos_context ~source ~payer ~self ~visitor amount code stack >>=?? fun (stack, _) -> + return stack + + let step_1_2 ?config (a:'a) (descr:('a * end_of_stack, 'b * ('c * end_of_stack)) descr) = + let open Script_interpreter in + step_lwt ?config (Item(a, Empty)) descr >>=? fun (Item(b, Item(c, Empty))) -> + return (b, c) + + let step_3_1 ?config (a:'a) (b:'b) (c:'c) + (descr:('a * ('b * ('c * end_of_stack)), 'd * end_of_stack) descr) = + let open Script_interpreter in + step_lwt ?config (Item(a, Item(b, Item(c, Empty)))) descr >>=? fun (Item(d, Empty)) -> + return d + + let step_2_1 ?config (a:'a) (b:'b) (descr:('a * ('b * end_of_stack), 'c * end_of_stack) descr) = + let open Script_interpreter in + step_lwt ?config (Item(a, Item(b, Empty))) descr >>=? fun (Item(c, Empty)) -> + return c + + let step_1_1 ?config (a:'a) (descr:('a * end_of_stack, 'b * end_of_stack) descr) = + let open Script_interpreter in + step_lwt ?config (Item(a, Empty)) descr >>=? fun (Item(b, Empty)) -> + return b + + let step_value ?config (a:'a) (descr:('a * end_of_stack, 'a * end_of_stack) descr) = + step_1_1 ?config a descr + + let step ?config stack code = + force_lwt ~msg:"running a step" @@ step_lwt ?config stack code + +end + +let run_lwt_full ?source ?payer ?self toplevel storage param {identities ; tezos_context = context} = + let { code ; _ } : (_, _) toplevel = toplevel in + + let source = Option.unopt + ~default:(List.nth identities 0).implicit_contract source in + let payer = Option.unopt + ~default:(List.nth identities 1).implicit_contract payer in + let self = Option.unopt + ~default:(List.nth identities 2).implicit_contract self in + let amount = Tez.one in + + Script_interpreter.interp context ~source ~payer ~self amount code (param, storage) + >>=?? fun ((ops, storage), new_ctxt) -> + let gas = Alpha_context.Gas.consumed ~since:context ~until:new_ctxt in + return (storage, ops, gas) + +let run_lwt ?source ?payer ?self toplevel storage param env = + run_lwt_full ?source ?payer ?self toplevel storage param env >>=? fun (storage, _ops, _gas) -> + return storage + +let run ?environment toplevel storage param = + contextualize ?environment ~msg:"run toplevel" @@ run_lwt toplevel storage param + +let run_node ?environment toplevel storage_node param_node = + contextualize ?environment ~msg:"run toplevel" @@ fun {tezos_context = context ; _} -> + let {param_type ; storage_type ; _ } = toplevel in + parse_data context param_type param_node >>=?? fun (param, _) -> + parse_data context storage_type storage_node >>=?? fun (storage, _) -> + let storage = run toplevel storage param in + unparse_data context Readable storage_type storage >>=?? fun (storage_node, _) -> + return storage_node + +let run_str toplevel storage_str param_str = + let param_node = Cast.node_of_string param_str in + let storage_node = Cast.node_of_string storage_str in + run_node toplevel storage_node param_node + +type input = { + toplevel_path : string ; + storage : string ; + parameter : string +} + +let parse_json json_str : input = + let json = force_ok_str ~msg:"main_contract: invalid json" @@ Tezos_utils.Data_encoding.Json.from_string json_str in + let json = match json with + | `O json -> json + | _ -> raise @@ Failure "main_contract: not recorD" + in + let open Json in + let toplevel_path = force_string ~msg:"main_contract, top_level" @@ List.assoc "top_level" json in + let parameter = force_string ~msg:"main_contract, param" @@ List.assoc "param" json in + let storage = force_string ~msg:"main_contract, storage" @@ List.assoc "storage" json in + { toplevel_path ; storage ; parameter } + +let generate_json (storage_node:Script.node) : string = + let storage_expr = Tezos_micheline.Micheline.strip_locations storage_node in + let json = Data_encoding.Json.construct Script.expr_encoding storage_expr in + Format.fprintf Format.str_formatter "%a" Data_encoding.Json.pp json ; + Format.flush_str_formatter () + +module Types = struct + open Script_typed_ir + + let union a b = Union_t ((a, None), (b, None), None) + let assert_union = function + | Union_t ((a, _), (b, _), _) -> (a, b) + | _ -> assert false + + let pair a b = Pair_t ((a, None, None), (b, None, None), None) + let assert_pair = function + | Pair_t ((a, _, _), ((b, _, _)), _) -> (a, b) + | _ -> assert false + let assert_pair_ex ?(msg="assert pair") (Ex_ty ty) = match ty with + | Pair_t ((a, _, _), ((b, _, _)), _) -> (Ex_ty a, Ex_ty b) + | _ -> raise (Failure msg) + + let unit = Unit_t None + + let bytes = Bytes_t None + let bytes_k = Bytes_key None + + let nat = Nat_t None + let tez = Mutez_t None + let int = Int_t None + let nat_k = Nat_key None + let tez_k = Mutez_key None + let int_k = Int_key None + + let big_map k v = Big_map_t (k, v, None) + + let signature = Signature_t None + let operation = Operation_t None + + let bool = Bool_t None + + let mutez = Mutez_t None + + let string = String_t None + let string_k = String_key None + let address_k = Address_key None + + let key = Key_t None + + let list a = List_t (a, None) + let assert_list = function + | List_t (a, _) -> a + | _ -> assert false + + let option a = Option_t ((a, None), None, None) + let contract a = Contract_t (a, None) + let assert_option = function + | Option_t ((a, _), _, _) -> a + | _ -> assert false + + let address = Address_t None + + let lambda a b = Lambda_t (a, b, None) + let assert_lambda = function + | Lambda_t (a, b, _) -> (a, b) + | _ -> assert false + type ex_lambda = Ex_lambda : (_, _) lambda ty -> ex_lambda + let is_lambda : type a . a ty -> ex_lambda option = function + | Lambda_t (_, _, _) as x -> Some (Ex_lambda x) + | _ -> None + + let timestamp = Timestamp_t None + let timestamp_k = Timestamp_key None + + let map a b = Map_t (a, b, None) + + let assert_type (_:'a ty) (_:'a) = () +end + +module Values = struct + let empty_map t = empty_map t + + let empty_big_map key_type comparable_key_ty value_type : ('a, 'b) big_map = { + key_type ; value_type ; diff = empty_map comparable_key_ty ; + } + + let int n = Script_int.of_int n + + let nat n = Script_int.abs @@ Script_int.of_int n + let nat_to_int n = Option.unopt_exn @@ Script_int.to_int n + + let tez n = Option.unopt_exn @@ Tez.of_mutez @@ Int64.of_int n + + let left a = L a + + let right b = R b +end diff --git a/meta_michelson/dune b/meta_michelson/dune new file mode 100644 index 000000000..ba6c4d95f --- /dev/null +++ b/meta_michelson/dune @@ -0,0 +1,10 @@ +(library + (name meta_michelson) + (public_name ligo.meta_michelson) + (libraries + simple-utils + tezos-utils + michelson-parser + tezos-micheline + ) +) diff --git a/meta_michelson/json.ml b/meta_michelson/json.ml new file mode 100644 index 000000000..9ed070d0c --- /dev/null +++ b/meta_michelson/json.ml @@ -0,0 +1,7 @@ +let force_record ~msg json = match json with + | `O json -> json + | _ -> raise @@ Failure ("not json record : " ^ msg) + +let force_string ~msg json = match json with + | `String str -> str + | _ -> raise @@ Failure ("not json str : " ^ msg) diff --git a/meta_michelson/meta_michelson.ml b/meta_michelson/meta_michelson.ml new file mode 100644 index 000000000..7e80979ed --- /dev/null +++ b/meta_michelson/meta_michelson.ml @@ -0,0 +1,12 @@ +module Run = struct + open Contract + let run_lwt_full = run_lwt_full + let run_lwt = run_lwt + let run_str = run_str + let run_node = run_node + let run = run +end +module Stack = Michelson_wrap.Stack +module Values = Contract.Values +module Types = Contract.Types + diff --git a/meta_michelson/michelson_wrap.ml b/meta_michelson/michelson_wrap.ml new file mode 100644 index 000000000..c53378c89 --- /dev/null +++ b/meta_michelson/michelson_wrap.ml @@ -0,0 +1,514 @@ +open Tezos_utils.Memory_proto_alpha +module AC = Alpha_context + +module Types = Contract.Types +module Option = Simple_utils.Option +module MBytes = Alpha_environment.MBytes + +module Stack = struct + open Script_typed_ir + + let descr bef aft instr = + { + loc = 0 ; + bef ; aft ; instr + } + + type nonrec 'a ty = 'a ty + type 'a t = 'a stack_ty + type nonrec ('a, 'b) descr = ('a, 'b) descr + type ('a, 'b) code = ('a t) -> ('a, 'b) descr + + type ex_stack_ty = Ex_stack_ty : 'a t -> ex_stack_ty + type ex_descr = Ex_descr : ('a, 'b) descr -> ex_descr + type ex_code = Ex_code : ('a, 'b) code -> ex_code + + let stack ?annot a b = Item_t (a, b, annot) + let unstack (item: (('a * 'rest) stack_ty)) : ('a ty * 'rest stack_ty) = + let Item_t (hd, tl, _) = item in + (hd, tl) + + let nil = Empty_t + let head x = fst @@ unstack x + let tail x = snd @@ unstack x + + let seq a b bef = + let a_descr = a bef in + let b_descr = b a_descr.aft in + let aft = b_descr.aft in + descr bef aft @@ Seq (a_descr, b_descr) + + let (@>) (stack : 'b t) (code : ('a, 'b) code) = code stack + let (@|) = seq + let (@:) = stack + + let (!:) : ('a, 'b) descr -> ('a, 'b) code = fun d _ -> d + + let (<.) (stack:'a t) (code: ('a, 'b) code): ('a, 'b) descr = code stack + + let (<::) : ('a, 'b) descr -> ('b, 'c) descr -> ('a, 'c) descr = fun ab bc -> + descr ab.bef bc.aft @@ Seq(ab, bc) + + let (<:) (ab_descr:('a, 'b) descr) (code:('b, 'c) code) : ('a, 'c) descr = + let bc_descr = code ab_descr.aft in + ab_descr <:: bc_descr + +end + +open Stack + +type nat = AC.Script_int.n AC.Script_int.num +type int_num = AC.Script_int.z AC.Script_int.num +type bytes = MBytes.t +type address = AC.Contract.t Script_typed_ir.ty +type mutez = AC.Tez.t Script_typed_ir.ty + + +module Stack_ops = struct + open Script_typed_ir + let dup : ('a * 'rest, 'a * ('a * 'rest)) code = fun bef -> + let Item_t (ty, rest, _) = bef in + descr bef (Item_t (ty, Item_t (ty, rest, None), None)) Dup + + let drop : ('a * 'rest, 'rest) code = fun bef -> + let aft = snd @@ unstack bef in + descr bef aft Drop + + let swap (bef : (('a * ('b * 'c)) stack_ty)) = + let Item_t (a, Item_t (b, rest, _), _) = bef in + descr bef (Item_t (b, (Item_t (a, rest, None)), None)) Swap + + let dip code (bef : ('ty * 'rest) stack_ty) = + let Item_t (ty, rest, _) = bef in + let applied = code rest in + let aft = Item_t (ty, applied.aft, None) in + descr bef aft (Dip (code rest)) + + let noop : ('r, 'r) code = fun bef -> + descr bef bef Nop + + let exec : (_, _) code = fun bef -> + let lambda = head @@ tail bef in + let (_, ret) = Types.assert_lambda lambda in + let aft = ret @: (tail @@ tail bef) in + descr bef aft Exec + + let fail aft : ('a * 'r, 'b) code = fun bef -> + let head = fst @@ unstack bef in + descr bef aft (Failwith head) + + let push_string str (bef : 'rest stack_ty) : (_, (string * 'rest)) descr = + let aft = Item_t (Types.string, bef, None) in + descr bef aft (Const (str)) + + let push_none (a:'a ty) : ('rest, 'a option * 'rest) code = fun r -> + let aft = stack (Types.option a) r in + descr r aft (Const None) + + let push_unit : ('rest, unit * 'rest) code = fun r -> + let aft = stack Types.unit r in + descr r aft (Const ()) + + let push_nat n (bef : 'rest stack_ty) : (_, (nat * 'rest)) descr = + let aft = Item_t (Types.nat, bef, None) in + descr bef aft (Const (Contract.Values.nat n)) + + let push_int n (bef : 'rest stack_ty) : (_, (int_num * 'rest)) descr = + let aft = Types.int @: bef in + descr bef aft (Const (Contract.Values.int n)) + + let push_tez n (bef : 'rest stack_ty) : (_, (AC.Tez.tez * 'rest)) descr = + let aft = Types.mutez @: bef in + descr bef aft (Const (Contract.Values.tez n)) + + let push_bool b : ('s, bool * 's) code = fun bef -> + let aft = stack Types.bool bef in + descr bef aft (Const b) + + let push_generic ty v : ('s, _ * 's) code = fun bef -> + let aft = stack ty bef in + descr bef aft (Const v) + + let failstring str aft = + push_string str @| fail aft + +end + +module Stack_shortcuts = struct + open Stack_ops + + let diip c x = dip (dip c) x + let diiip c x = dip (diip c) x + let diiiip c x = dip (diiip c) x + + let bubble_1 = swap + let bubble_down_1 = swap + + let bubble_2 : ('a * ('b * ('c * 'r)), 'c * ('a * ('b * 'r))) code = fun bef -> + bef <. dip swap <: swap + let bubble_down_2 : ('a * ('b * ('c * 'r)), ('b * ('c * ('a * 'r)))) code = fun bef -> + bef <. swap <: dip swap + + let bubble_3 : ('a * ('b * ('c * ('d * 'r))), 'd * ('a * ('b * ('c * 'r)))) code = fun bef -> + bef <. diip swap <: dip swap <: swap + + let keep_1 : type r s . ('a * r, s) code -> ('a * r, 'a * s) code = fun code bef -> + bef <. dup <: dip code + + let save_1_1 : type r . ('a * r, 'b * r) code -> ('a * r, 'b * ('a * r)) code = fun code s -> + s <. keep_1 code <: swap + + let keep_2 : type r s . ('a * ('b * r), s) code -> ('a * ('b * r), ('a * ('b * s))) code = fun code bef -> + (dup @| dip (swap @| dup @| dip (swap @| code))) bef + + let keep_2_1 : type r s . ('a * ('b * r), s) code -> ('a * ('b * r), 'b * s) code = fun code bef -> + (dip dup @| swap @| dip code) bef + + let relativize_1_1 : ('a * unit, 'b * unit) descr -> ('a * 'r, 'b * 'r) code = fun d s -> + let aft = head d.aft @: tail s in + descr s aft d.instr + +end + +module Pair_ops = struct + let car (bef : (('a * 'b) * 'rest) Stack.t) = + let (pair, rest) = unstack bef in + let (a, _) = Contract.Types.assert_pair pair in + descr bef (stack a rest) Car + + let cdr (bef : (('a * 'b) * 'rest) Stack.t) = + let (pair, rest) = unstack bef in + let (_, b) = Contract.Types.assert_pair pair in + descr bef (stack b rest) Cdr + + let pair (bef : ('a * ('b * 'rest)) Stack.t) = + let (a, rest) = unstack bef in + let (b, rest) = unstack rest in + let aft = (Types.pair a b) @: rest in + descr bef aft Cons_pair + + open Stack_ops + let carcdr s = s <. car <: Stack_ops.dip cdr + + let cdrcar s = s <. cdr <: dip car + + let cdrcdr s = s <. cdr <: dip cdr + + let carcar s = s <. car <: dip car + + let cdar s = s <. cdr <: car + + let unpair s = s <. dup <: car <: dip cdr +end + +module Option_ops = struct + open Script_typed_ir + + let cons bef = + let (hd, tl) = unstack bef in + descr bef (stack (Contract.Types.option hd) tl) Cons_some + + let cond ?target none_branch some_branch : ('a option * 'r, 'b) code = fun bef -> + let (a_opt, base) = unstack bef in + let a = Types.assert_option a_opt in + let target = Option.unopt ~default:(none_branch base).aft target in + descr bef target (If_none (none_branch base, some_branch (stack a base))) + + let force_some ?msg : ('a option * 'r, 'a * 'r) code = fun s -> + let (a_opt, base) = unstack s in + let a = Types.assert_option a_opt in + let target = a @: base in + cond ~target + (Stack_ops.failstring ("force_some : " ^ Option.unopt ~default:"" msg) target) + Stack_ops.noop s +end + +module Union_ops = struct + open Script_typed_ir + + let left (b:'b ty) : ('a * 'r, ('a, 'b) union * 'r) code = fun bef -> + let (a, base) = unstack bef in + let aft = Types.union a b @: base in + descr bef aft Left + + let right (a:'a ty) : ('b * 'r, ('a, 'b) union * 'r) code = fun bef -> + let (b, base) = unstack bef in + let aft = Types.union a b @: base in + descr bef aft Right + + + let loop ?after (code: ('a * 'r, ('a, 'b) union * 'r) code): (('a, 'b) union * 'r, 'b * 'r) code = fun bef -> + let (union, base) = unstack bef in + let (a, b) = Types.assert_union union in + let code_stack = a @: base in + let aft = Option.unopt ~default:(b @: base) after in + descr bef aft (Loop_left (code code_stack)) + +end + +module Arithmetic = struct + let neq : (int_num * 'r, bool *'r) code = fun bef -> + let aft = stack Types.bool @@ snd @@ unstack bef in + descr bef aft Neq + + let neg : (int_num * 'r, int_num *'r) code = fun bef -> + let aft = stack Types.int @@ snd @@ unstack bef in + descr bef aft Neg_int + + let abs : (int_num * 'r, nat *'r) code = fun bef -> + let aft = stack Types.nat @@ snd @@ unstack bef in + descr bef aft Abs_int + + let int : (nat * 'r, int_num*'r) code = fun bef -> + let aft = stack Types.int @@ snd @@ unstack bef in + descr bef aft Int_nat + + let nat_opt : (int_num * 'r, nat option * 'r) code = fun bef -> + let aft = stack Types.(option nat) @@ tail bef in + descr bef aft Is_nat + + let nat_neq = fun s -> (int @| neq) s + + let add_natnat (bef : (nat * (nat * 'rest)) Stack.t) = + let (nat, rest) = unstack bef in + let rest = tail rest in + let aft = stack nat rest in + descr bef aft Add_natnat + + let add_intint (bef : (int_num * (int_num * 'rest)) Stack.t) = + let (nat, rest) = unstack bef in + let rest = tail rest in + let aft = stack nat rest in + descr bef aft Add_intint + + let add_teztez : (AC.Tez.tez * (AC.Tez.tez * 'rest), _) code = fun bef -> + let aft = tail bef in + descr bef aft Add_tez + + let mul_natnat (bef : (nat * (nat * 'rest)) Stack.t) = + let nat = head bef in + let rest = tail @@ tail bef in + let aft = stack nat rest in + descr bef aft Mul_natnat + + let mul_intint (bef : (int_num * (int_num * 'rest)) Stack.t) = + let nat = head bef in + let rest = tail @@ tail bef in + let aft = stack nat rest in + descr bef aft Mul_intint + + let sub_intint : (int_num * (int_num * 'r), int_num * 'r) code = fun bef -> + let aft = tail bef in + descr bef aft Sub_int + + let sub_natnat : (nat * (nat * 'r), int_num * 'r) code = + fun bef -> bef <. int <: Stack_ops.dip int <: sub_intint + + let ediv : (nat * (nat * 'r), (nat * nat) option * 'r) code = fun s -> + let (n, base) = unstack @@ snd @@ unstack s in + let aft = Types.option (Types.pair n n) @: base in + descr s aft Ediv_natnat + + let ediv_tez = fun s -> + let aft = Types.(option @@ pair (head s) (head s)) @: tail @@ tail s in + descr s aft Ediv_teznat + + open Option_ops + let force_ediv x = x <. ediv <: force_some + let force_ediv_tez x = (ediv_tez @| force_some) x + + open Pair_ops + let div x = x <. force_ediv <: car + + open Stack_ops + let div_n n s = s <. push_nat n <: swap <: div + let add_n n s = s <. push_nat n <: swap <: add_natnat + let add_teztez_n n s = s <. push_tez n <: swap <: add_teztez + let sub_n n s = s <. push_nat n <: swap <: sub_natnat + + let force_nat s = s <. nat_opt <: force_some ~msg:"force nat" +end + +module Boolean = struct + let bool_and (type r) : (bool * (bool * r), bool * r) code = fun bef -> + let aft = Types.bool @: tail @@ tail bef in + descr bef aft And + + let bool_or (type r) : (bool * (bool * r), bool * r) code = fun bef -> + let aft = Types.bool @: tail @@ tail bef in + descr bef aft Or + + open Script_typed_ir + let cond ?target true_branch false_branch : (bool * 'r, 's) code = fun bef -> + let base = tail bef in + let aft = Option.unopt ~default:((true_branch base).aft) target in + descr bef aft (If (true_branch base, false_branch base)) + + let loop (code : ('s, bool * 's) code) : ((bool * 's), 's) code = fun bef -> + let aft = tail bef in + descr bef aft @@ Loop (code aft) + +end + +module Comparison_ops = struct + let cmp c_ty : _ code = fun bef -> + let aft = stack Contract.Types.int @@ tail @@ tail @@ bef in + descr bef aft (Compare c_ty) + + let cmp_bytes = fun x -> cmp (Bytes_key None) x + + let eq : (int_num * 'r, bool *'r) code = fun bef -> + let aft = stack Contract.Types.bool @@ snd @@ unstack bef in + descr bef aft Eq + + open Arithmetic + let eq_n n s = s <. sub_n n <: eq + + let ge : (int_num * 'r, bool * 'r) code = fun bef -> + let base = tail bef in + let aft = stack Types.bool base in + descr bef aft Ge + + let gt : (int_num * 'r, bool * 'r) code = fun bef -> + let base = tail bef in + let aft = stack Types.bool base in + descr bef aft Gt + + let lt : (int_num * 'r, bool * 'r) code = fun bef -> + let base = tail bef in + let aft = stack Types.bool base in + descr bef aft Lt + + let gt_nat s = s <. int <: gt + + open Stack_ops + let assert_positive_nat s = s <. dup <: gt_nat <: Boolean.cond noop (failstring "positive" s) + + let cmp_ge_nat : (nat * (nat * 'r), bool * 'r) code = fun bef -> + bef <. sub_natnat <: ge + + let cmp_ge_timestamp : (AC.Script_timestamp.t * (AC.Script_timestamp.t * 'r), bool * 'r) code = fun bef -> + bef <. cmp Types.timestamp_k <: ge + + let assert_cmp_ge_nat : (nat * (nat * 'r), 'r) code = fun bef -> + bef <. cmp_ge_nat <: Boolean.cond noop (failstring "assert cmp ge nat" (tail @@ tail bef)) + + let assert_cmp_ge_timestamp : (AC.Script_timestamp.t * (AC.Script_timestamp.t * 'r), 'r) code = fun bef -> + bef <. cmp_ge_timestamp <: Boolean.cond noop (failstring "assert cmp ge timestamp" (tail @@ tail bef)) +end + + +module Bytes = struct + + open Script_typed_ir + + let pack (ty:'a ty) : ('a * 'r, bytes * 'r) code = fun bef -> + let aft = stack Types.bytes @@ tail bef in + descr bef aft (Pack ty) + + let unpack_opt : type a . a ty -> (bytes * 'r, a option * 'r) code = fun ty bef -> + let aft = stack (Types.option ty) (tail bef) in + descr bef aft (Unpack ty) + + let unpack ty s = s <. unpack_opt ty <: Option_ops.force_some + + let concat : (MBytes.t * (MBytes.t * 'rest), MBytes.t * 'rest) code = fun bef -> + let aft = tail bef in + descr bef aft Concat_bytes_pair + + let sha256 : (MBytes.t * 'rest, MBytes.t * 'rest) code = fun bef -> + descr bef bef Sha256 + + let blake2b : (MBytes.t * 'rest, MBytes.t * 'rest) code = fun bef -> + descr bef bef Blake2b +end + + +module Map = struct + open Script_typed_ir + + type ('a, 'b) t = ('a, 'b) map + + let empty c_ty = Script_ir_translator.empty_map c_ty + let set (type a b) m (k:a) (v:b) = Script_ir_translator.map_update k (Some v) m + + module Ops = struct + let update (bef : (('a * ('b option * (('a, 'b) map * ('rest)))) Stack.t)) : (_, ('a, 'b) map * 'rest) descr = + let Item_t (_, Item_t (_, Item_t (map, rest, _), _), _) = bef in + let aft = Item_t (map, rest, None) in + descr bef aft Map_update + + let get : ?a:('a ty) -> 'b ty -> ('a * (('a, 'b) map * 'r), 'b option * 'r) code = fun ?a b bef -> + let _ = a in + let base = snd @@ unstack @@ snd @@ unstack bef in + let aft = stack (Types.option b) base in + descr bef aft Map_get + + let big_get : 'a ty -> 'b ty -> ('a * (('a, 'b) big_map * 'r), 'b option * 'r) code = fun _a b bef -> + let base = snd @@ unstack @@ snd @@ unstack bef in + let aft = stack (Types.option b) base in + descr bef aft Big_map_get + + let big_update : ('a * ('b option * (('a, 'b) big_map * 'r)), ('a, 'b) big_map * 'r) code = fun bef -> + let base = tail @@ tail bef in + descr bef base Big_map_update + end +end + +module List_ops = struct + let nil ele bef = + let aft = stack (Types.list ele) bef in + descr bef aft Nil + + let cons bef = + let aft = tail bef in + descr bef aft Cons_list + + let cond ~target cons_branch nil_branch bef = + let (lst, aft) = unstack bef in + let a = Types.assert_list lst in + let cons_descr = cons_branch (a @: Types.list a @: aft) in + let nil_descr = nil_branch aft in + descr bef target (If_cons (cons_descr, nil_descr)) + + let list_iter : type a r . (a * r, r) code -> (a list * r, r) code = fun code bef -> + let (a_lst, aft) = unstack bef in + let a = Types.assert_list a_lst in + descr bef aft (List_iter (code (a @: aft))) + +end + +module Tez = struct + + let amount : ('r, AC.Tez.t * 'r) code = fun bef -> + let aft = Types.mutez @: bef in + descr bef aft Amount + + open Bytes + + let tez_nat s = s <. pack Types.mutez <: unpack Types.nat + let amount_nat s = s <. amount <: pack Types.mutez <: unpack Types.nat +end + +module Misc = struct + + open Stack_ops + open Stack_shortcuts + open Comparison_ops + let min_nat : (nat * (nat * 'r), nat * 'r) code = fun s -> + s <. + keep_2 cmp_ge_nat <: bubble_2 <: + Boolean.cond drop (dip drop) + + let debug ~msg () s = s <. push_string msg <: push_string "_debug" <: noop <: drop <: drop + + let debug_msg msg = debug ~msg () + + let now : ('r, AC.Script_timestamp.t * 'r) code = fun bef -> + let aft = stack Types.timestamp bef in + descr bef aft Now + +end + + + diff --git a/meta_michelson/misc.ml b/meta_michelson/misc.ml new file mode 100644 index 000000000..5fa0357c3 --- /dev/null +++ b/meta_michelson/misc.ml @@ -0,0 +1,302 @@ +module Signature = Tezos_base.TzPervasives.Signature +open Tezos_utils.Memory_proto_alpha +module Data_encoding = Alpha_environment.Data_encoding +module MBytes = Alpha_environment.MBytes +module Error_monad = Tezos_utils.Error_monad +open Error_monad + +module Context_init = struct + + type account = { + pkh : Signature.Public_key_hash.t ; + pk : Signature.Public_key.t ; + sk : Signature.Secret_key.t ; + } + + let generate_accounts n : (account * Tez_repr.t) list = + let amount = Tez_repr.of_mutez_exn 4_000_000_000_000L in + List.map (fun _ -> + let (pkh, pk, sk) = Signature.generate_key () in + let account = { pkh ; pk ; sk } in + account, amount) + (Simple_utils.List.range n) + + let make_shell + ~level ~predecessor ~timestamp ~fitness ~operations_hash = + Tezos_base.Block_header.{ + level ; + predecessor ; + timestamp ; + fitness ; + operations_hash ; + (* We don't care of the following values, only the shell validates them. *) + proto_level = 0 ; + validation_passes = 0 ; + context = Alpha_environment.Context_hash.zero ; + } + + let default_proof_of_work_nonce = + MBytes.create Alpha_context.Constants.proof_of_work_nonce_size + + let protocol_param_key = [ "protocol_parameters" ] + + let check_constants_consistency constants = + let open Constants_repr in + let open Error_monad in + let { blocks_per_cycle ; blocks_per_commitment ; + blocks_per_roll_snapshot ; _ } = constants in + Error_monad.unless (blocks_per_commitment <= blocks_per_cycle) + (fun () -> failwith "Inconsistent constants : blocks per commitment must be \ + less than blocks per cycle") >>=? fun () -> + Error_monad.unless (blocks_per_cycle >= blocks_per_roll_snapshot) + (fun () -> failwith "Inconsistent constants : blocks per cycle \ + must be superior than blocks per roll snapshot") >>=? + return + + + let initial_context + constants + header + commitments + initial_accounts + security_deposit_ramp_up_cycles + no_reward_cycles + = + let open Tezos_base.TzPervasives.Error_monad in + let bootstrap_accounts = + List.map (fun ({ pk ; pkh ; _ }, amount) -> + let open! Parameters_repr in + { public_key_hash = pkh ; public_key = Some pk ; amount } + ) initial_accounts + in + let json = + Data_encoding.Json.construct + Parameters_repr.encoding + Parameters_repr.{ + bootstrap_accounts ; + bootstrap_contracts = [] ; + commitments ; + constants ; + security_deposit_ramp_up_cycles ; + no_reward_cycles ; + } + in + let proto_params = + Data_encoding.Binary.to_bytes_exn Data_encoding.json json + in + Tezos_protocol_environment_memory.Context.( + set empty ["version"] (MBytes.of_string "genesis") + ) >>= fun ctxt -> + Tezos_protocol_environment_memory.Context.( + set ctxt protocol_param_key proto_params + ) >>= fun ctxt -> + Main.init ctxt header + >|= Alpha_environment.wrap_error >>=? fun { context; _ } -> + return context + + let genesis + ?(preserved_cycles = Constants_repr.default.preserved_cycles) + ?(blocks_per_cycle = Constants_repr.default.blocks_per_cycle) + ?(blocks_per_commitment = Constants_repr.default.blocks_per_commitment) + ?(blocks_per_roll_snapshot = Constants_repr.default.blocks_per_roll_snapshot) + ?(blocks_per_voting_period = Constants_repr.default.blocks_per_voting_period) + ?(time_between_blocks = Constants_repr.default.time_between_blocks) + ?(endorsers_per_block = Constants_repr.default.endorsers_per_block) + ?(hard_gas_limit_per_operation = Constants_repr.default.hard_gas_limit_per_operation) + ?(hard_gas_limit_per_block = Constants_repr.default.hard_gas_limit_per_block) + ?(proof_of_work_threshold = Int64.(neg one)) + ?(tokens_per_roll = Constants_repr.default.tokens_per_roll) + ?(michelson_maximum_type_size = Constants_repr.default.michelson_maximum_type_size) + ?(seed_nonce_revelation_tip = Constants_repr.default.seed_nonce_revelation_tip) + ?(origination_size = Constants_repr.default.origination_size) + ?(block_security_deposit = Constants_repr.default.block_security_deposit) + ?(endorsement_security_deposit = Constants_repr.default.endorsement_security_deposit) + ?(block_reward = Constants_repr.default.block_reward) + ?(endorsement_reward = Constants_repr.default.endorsement_reward) + ?(cost_per_byte = Constants_repr.default.cost_per_byte) + ?(hard_storage_limit_per_operation = Constants_repr.default.hard_storage_limit_per_operation) + ?(commitments = []) + ?(security_deposit_ramp_up_cycles = None) + ?(no_reward_cycles = None) + (initial_accounts : (account * Tez_repr.t) list) + = + if initial_accounts = [] then + Pervasives.failwith "Must have one account with a roll to bake"; + + (* Check there is at least one roll *) + let open Tezos_base.TzPervasives.Error_monad in + begin try + let (>>?=) x y = match x with + | Ok(a) -> y a + | Error(b) -> fail @@ List.hd b in + fold_left_s (fun acc (_, amount) -> + Alpha_environment.wrap_error @@ + Tez_repr.(+?) acc amount >>?= fun acc -> + if acc >= tokens_per_roll then + raise Exit + else return acc + ) Tez_repr.zero initial_accounts >>=? fun _ -> + failwith "Insufficient tokens in initial accounts to create one roll" + with Exit -> return () + end >>=? fun () -> + + let constants : Constants_repr.parametric = { + preserved_cycles ; + blocks_per_cycle ; + blocks_per_commitment ; + blocks_per_roll_snapshot ; + blocks_per_voting_period ; + time_between_blocks ; + endorsers_per_block ; + hard_gas_limit_per_operation ; + hard_gas_limit_per_block ; + proof_of_work_threshold ; + tokens_per_roll ; + michelson_maximum_type_size ; + seed_nonce_revelation_tip ; + origination_size ; + block_security_deposit ; + endorsement_security_deposit ; + block_reward ; + endorsement_reward ; + cost_per_byte ; + hard_storage_limit_per_operation ; + } in + check_constants_consistency constants >>=? fun () -> + + let hash = + Alpha_environment.Block_hash.of_b58check_exn "BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU" + in + let shell = make_shell + ~level:0l + ~predecessor:hash + ~timestamp:Tezos_utils.Time.epoch + ~fitness: (Fitness_repr.from_int64 0L) + ~operations_hash: Alpha_environment.Operation_list_list_hash.zero in + initial_context + constants + shell + commitments + initial_accounts + security_deposit_ramp_up_cycles + no_reward_cycles + >>=? fun context -> + return (context, shell, hash) + + let init + ?(slow=false) + ?preserved_cycles + ?endorsers_per_block + ?commitments + n = + let open Error_monad in + let accounts = generate_accounts n in + let contracts = List.map (fun (a, _) -> + Alpha_context.Contract.implicit_contract (a.pkh)) accounts in + begin + if slow then + genesis + ?preserved_cycles + ?endorsers_per_block + ?commitments + accounts + else + genesis + ?preserved_cycles + ~blocks_per_cycle:32l + ~blocks_per_commitment:4l + ~blocks_per_roll_snapshot:8l + ~blocks_per_voting_period:(Int32.mul 32l 8l) + ?endorsers_per_block + ?commitments + accounts + end >>=? fun ctxt -> + return (ctxt, accounts, contracts) + + let contents + ?(proof_of_work_nonce = default_proof_of_work_nonce) + ?(priority = 0) ?seed_nonce_hash () = + Alpha_context.Block_header.({ + priority ; + proof_of_work_nonce ; + seed_nonce_hash ; + }) + + + let begin_construction ?(priority=0) ~timestamp ~(header:Alpha_context.Block_header.shell_header) ~hash ctxt = + let contents = contents ~priority () in + let protocol_data = + let open! Alpha_context.Block_header in { + contents ; + signature = Signature.zero ; + } in + let header = { + Alpha_context.Block_header.shell = { + predecessor = hash ; + proto_level = header.proto_level ; + validation_passes = header.validation_passes ; + fitness = header.fitness ; + timestamp ; + level = header.level ; + context = Alpha_environment.Context_hash.zero ; + operations_hash = Alpha_environment.Operation_list_list_hash.zero ; + } ; + protocol_data = { + contents ; + signature = Signature.zero ; + } ; + } in + Main.begin_construction + ~chain_id: Alpha_environment.Chain_id.zero + ~predecessor_context: ctxt + ~predecessor_timestamp: header.shell.timestamp + ~predecessor_fitness: header.shell.fitness + ~predecessor_level: header.shell.level + ~predecessor:hash + ~timestamp + ~protocol_data + () >>= fun x -> Lwt.return @@ Alpha_environment.wrap_error x >>=? fun state -> + return state.ctxt + + let main n = + init n >>=? fun ((ctxt, header, hash), accounts, contracts) -> + let timestamp = Tezos_base.Time.now () in + begin_construction ~timestamp ~header ~hash ctxt >>=? fun ctxt -> + return (ctxt, accounts, contracts) + +end + +type identity = { + public_key_hash : Signature.public_key_hash; + public_key : Signature.public_key; + secret_key : Signature.secret_key; + implicit_contract : Alpha_context.Contract.t; +} + +type environment = { + tezos_context : Alpha_context.t ; + identities : identity list ; +} + +let init_environment () = + Context_init.main 10 >>=? fun (tezos_context, accounts, contracts) -> + let accounts = List.map fst accounts in + let tezos_context = Alpha_context.Gas.set_limit tezos_context @@ Z.of_int 350000 in + let identities = + List.map (fun ((a:Context_init.account), c) -> { + public_key = a.pk ; + public_key_hash = a.pkh ; + secret_key = a.sk ; + implicit_contract = c ; + }) @@ + List.combine accounts contracts in + return {tezos_context ; identities} + +let contextualize ~msg ?environment f = + let lwt = + let environment = match environment with + | None -> init_environment () + | Some x -> return x in + environment >>=? f + in + force_ok ~msg @@ Lwt_main.run lwt diff --git a/meta_michelson/streams.ml b/meta_michelson/streams.ml new file mode 100644 index 000000000..b45176516 --- /dev/null +++ b/meta_michelson/streams.ml @@ -0,0 +1,18 @@ +let read_file f = + let ic = open_in f in + let n = in_channel_length ic in + let s = Bytes.create n in + really_input ic s 0 n; + close_in ic; + Bytes.to_string s + +let read_lines filename = + let lines = ref [] in + let chan = open_in filename in + try + while true; do + lines := input_line chan :: !lines + done; !lines + with End_of_file -> + close_in chan; + List.rev !lines diff --git a/mini_c/PP.ml b/mini_c/PP.ml new file mode 100644 index 000000000..6dfa90e4a --- /dev/null +++ b/mini_c/PP.ml @@ -0,0 +1,120 @@ +open Simple_utils.PP_helpers +open Types +open Format + +let list_sep_d x = list_sep x (const " , ") + +let space_sep ppf () = fprintf ppf " " + +let lr = fun ppf -> function `Left -> fprintf ppf "L" | `Right -> fprintf ppf "R" + +let type_base ppf : type_base -> _ = function + | Base_unit -> fprintf ppf "unit" + | Base_bool -> fprintf ppf "bool" + | Base_int -> fprintf ppf "int" + | Base_nat -> fprintf ppf "nat" + | Base_tez -> fprintf ppf "tez" + | Base_string -> fprintf ppf "string" + | Base_address -> fprintf ppf "address" + | Base_bytes -> fprintf ppf "bytes" + | Base_operation -> fprintf ppf "operation" + +let rec type_ ppf : type_value -> _ = function + | T_or(a, b) -> fprintf ppf "(%a) | (%a)" type_ a type_ b + | T_pair(a, b) -> fprintf ppf "(%a) & (%a)" type_ a type_ b + | T_base b -> type_base ppf b + | T_function(a, b) -> fprintf ppf "(%a) -> (%a)" type_ a type_ b + | T_map(k, v) -> fprintf ppf "map(%a -> %a)" type_ k type_ v + | T_list(t) -> fprintf ppf "list(%a)" type_ t + | T_option(o) -> fprintf ppf "option(%a)" type_ o + | T_contract(t) -> fprintf ppf "contract(%a)" type_ t + | T_deep_closure(c, arg, ret) -> + fprintf ppf "[%a](%a)->(%a)" + environment c + type_ arg type_ ret + +and environment_element ppf ((s, tv) : environment_element) = + Format.fprintf ppf "%s : %a" s type_ tv + +and environment ppf (x:environment) = + fprintf ppf "Env[%a]" (list_sep_d environment_element) x + +let rec value ppf : value -> unit = function + | D_bool b -> fprintf ppf "%b" b + | D_operation _ -> fprintf ppf "operation[...bytes]" + | D_int n -> fprintf ppf "%d" n + | D_nat n -> fprintf ppf "+%d" n + | D_tez n -> fprintf ppf "%dtz" n + | D_unit -> fprintf ppf " " + | D_string s -> fprintf ppf "\"%s\"" s + | D_bytes _ -> fprintf ppf "[bytes]" + | D_pair (a, b) -> fprintf ppf "(%a), (%a)" value a value b + | D_left a -> fprintf ppf "L(%a)" value a + | D_right b -> fprintf ppf "R(%a)" value b + | D_function x -> function_ ppf x + | D_none -> fprintf ppf "None" + | D_some s -> fprintf ppf "Some (%a)" value s + | D_map m -> fprintf ppf "Map[%a]" (list_sep_d value_assoc) m + | D_list lst -> fprintf ppf "List[%a]" (list_sep_d value) lst + +and value_assoc ppf : (value * value) -> unit = fun (a, b) -> + fprintf ppf "%a -> %a" value a value b + +and expression' ppf (e:expression') = match e with + | E_capture_environment s -> fprintf ppf "capture(%a)" (list_sep string (const " ; ")) s + | E_variable v -> fprintf ppf "%s" v + | E_application(a, b) -> fprintf ppf "(%a)@(%a)" expression a expression b + | E_constant(p, lst) -> fprintf ppf "%s %a" p (pp_print_list ~pp_sep:space_sep expression) lst + | E_literal v -> fprintf ppf "%a" value v + | E_empty_map _ -> fprintf ppf "map[]" + | 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 e.content + +and expression_with_type : _ -> expression -> _ = fun ppf e -> + fprintf ppf "%a : %a" + expression' e.content + type_ e.type_value + +and function_ ppf ({binder ; input ; output ; body ; result}:anon_function) = + fprintf ppf "fun (%s:%a) : %a %a return %a" + binder + type_ input + type_ output + block body + expression result + +and assignment ppf ((n, e):assignment) = fprintf ppf "%s = %a;" n expression e + +and declaration ppf ((n, e):assignment) = fprintf ppf "let %s = %a;" n expression e + +and statement ppf ((s, _) : statement) = match s with + | S_environment_load _ -> fprintf ppf "load env" + | S_environment_select _ -> fprintf ppf "select env" + | S_environment_add (name, tv) -> fprintf ppf "add %s %a" name type_ tv + | S_declaration ass -> declaration ppf ass + | S_assignment ass -> assignment ppf ass + | S_do e -> fprintf ppf "do %a" expression e + | S_cond (expr, i, e) -> fprintf ppf "if (%a) %a %a" expression expr block i block e + | S_patch (r, path, e) -> + fprintf ppf "%s.%a := %a" r (list_sep lr (const ".")) path expression e + | S_if_none (expr, none, ((name, _), some)) -> fprintf ppf "if_none (%a) %a %s->%a" expression expr block none name block some + | S_while (e, b) -> fprintf ppf "while (%a) %a" expression e block b + +and block ppf ((b, _):block) = + match b with + | [] -> fprintf ppf "{}" + | b -> fprintf ppf "{@; @[%a@]@;}" (pp_print_list ~pp_sep:(tag "@;") statement) b + +let tl_statement ppf (ass, _) = assignment ppf ass + +let program ppf (p:program) = + fprintf ppf "Program:\n---\n%a" (pp_print_list ~pp_sep:pp_print_newline tl_statement) p diff --git a/mini_c/combinators.ml b/mini_c/combinators.ml new file mode 100644 index 000000000..5f5a061fb --- /dev/null +++ b/mini_c/combinators.ml @@ -0,0 +1,161 @@ +open Trace +open Types + +module Expression = struct + type t' = expression' + type t = expression + + let get_content : t -> t' = fun e -> e.content + let get_type : t -> type_value = fun e -> e.type_value + let get_environment : t -> environment = fun e -> e.environment + let is_toplevel : t -> bool = fun e -> e.is_toplevel + + let make = fun ?(itl = false) e' t env -> { + content = e' ; + type_value = t ; + environment = env ; + is_toplevel = itl ; + } + + let make_tpl = fun ?(itl = false) (e' , t , env) -> { + content = e' ; + type_value = t ; + environment = env ; + is_toplevel = itl ; + } + + let pair : t -> t -> t' = fun a b -> E_constant ("PAIR" , [ a ; b ]) + +end + +let get_bool (v:value) = match v with + | D_bool b -> ok b + | _ -> simple_fail "not a bool" + +let get_int (v:value) = match v with + | D_int n -> ok n + | _ -> simple_fail "not an int" + +let get_nat (v:value) = match v with + | D_nat n -> ok n + | _ -> simple_fail "not a nat" + +let get_string (v:value) = match v with + | D_string s -> ok s + | _ -> simple_fail "not a string" + +let get_bytes (v:value) = match v with + | D_bytes b -> ok b + | _ -> simple_fail "not a bytes" + +let get_unit (v:value) = match v with + | D_unit -> ok () + | _ -> simple_fail "not a unit" + +let get_option (v:value) = match v with + | D_none -> ok None + | D_some s -> ok (Some s) + | _ -> simple_fail "not an option" + +let get_map (v:value) = match v with + | D_map lst -> ok lst + | _ -> simple_fail "not a map" + +let get_list (v:value) = match v with + | D_list lst -> ok lst + | _ -> simple_fail "not a list" + +let get_t_option (v:type_value) = match v with + | T_option t -> ok t + | _ -> simple_fail "not an option" + +let get_pair (v:value) = match v with + | D_pair (a, b) -> ok (a, b) + | _ -> simple_fail "not a pair" + +let get_t_pair (t:type_value) = match t with + | T_pair (a, b) -> ok (a, b) + | _ -> simple_fail "not a type pair" + +let get_t_map (t:type_value) = match t with + | T_map kv -> ok kv + | _ -> simple_fail "not a type map" + +let get_t_list (t:type_value) = match t with + | T_list t -> ok t + | _ -> simple_fail "not a type list" + +let get_left (v:value) = match v with + | D_left b -> ok b + | _ -> simple_fail "not a left" + +let get_right (v:value) = match v with + | D_right b -> ok b + | _ -> simple_fail "not a right" + +let get_or (v:value) = match v with + | D_left b -> ok (false, b) + | 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_t_contract t = match t with + | T_contract x -> ok x + | _ -> fail @@ wrong_type "contract" t + +let get_t_operation t = match t with + | T_base Base_operation -> ok () + | _ -> fail @@ wrong_type "operation" t + +let get_operation (v:value) = match v with + | D_operation x -> ok x + | _ -> simple_fail "not an operation" + + +let get_last_statement ((b', _):block) : statement result = + let aux lst = match lst with + | [] -> simple_fail "get_last: empty list" + | lst -> ok List.(nth lst (length lst - 1)) in + aux b' + +let t_int : type_value = T_base Base_int +let t_nat : type_value = T_base Base_nat + +let t_function x y : type_value = T_function ( x , y ) +let t_deep_closure x y z : type_value = T_deep_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 = + { + binder ; input ; output ; + body ; result ; + } + +let basic_quote i o b : anon_function result = + let%bind (_, e) = get_last_statement b in + let r : expression = Expression.make_tpl (E_variable "output", o, e.post_environment) in + ok @@ quote "input" i o b r + +let basic_int_quote b : anon_function result = + basic_quote t_int t_int b + +let e_int expr env : expression = Expression.make_tpl (expr, t_int, env) +let e_var_int name env : expression = e_int (E_variable name) env + +let d_unit : value = D_unit + +let environment_wrap pre_environment post_environment = { pre_environment ; post_environment } +let id_environment_wrap e = environment_wrap e e diff --git a/mini_c/combinators_smart.ml b/mini_c/combinators_smart.ml new file mode 100644 index 000000000..4e0126f35 --- /dev/null +++ b/mini_c/combinators_smart.ml @@ -0,0 +1,52 @@ +open Trace +open Types +open Combinators + +let basic_int_quote_env : environment = + let e = Environment.empty in + Environment.add ("input", t_int) e + +let statement s' env : statement = + match s' with + | S_environment_load (_ , env') -> s', environment_wrap env env' + | S_environment_select env' -> s', environment_wrap env env' + | S_environment_add (name, tv) -> s' , environment_wrap env (Environment.add (name , tv) env) + | S_cond _ -> s' , id_environment_wrap env + | S_do _ -> s' , id_environment_wrap env + | S_if_none _ -> s' , id_environment_wrap env + | S_while _ -> s' , id_environment_wrap env + | S_patch _ -> s' , id_environment_wrap env + | S_declaration (name , e) -> s', environment_wrap env (Environment.add (name , (Expression.get_type e)) env) + | S_assignment (name , e) -> s', environment_wrap env (Environment.add (name , (Expression.get_type e)) env) + +let block (statements:statement list) : block result = + match statements with + | [] -> simple_fail "no statements in block" + | lst -> + let first = List.hd lst in + let last = List.(nth lst (length lst - 1)) in + ok (lst, environment_wrap (snd first).pre_environment (snd last).post_environment) + +let append_statement' : block -> statement' -> block = fun b s' -> + let b_wrap = snd b in + let s = statement s' b_wrap.post_environment in + let s_wrap = snd s in + let b_wrap' = { b_wrap with post_environment = s_wrap.post_environment } in + let b_content = fst b in + (b_content @ [s], b_wrap') + +let prepend_statement : statement -> block -> block = fun s b -> + let s_wrap = snd s in + let b_wrap = snd b in + let b_wrap' = { b_wrap with pre_environment = s_wrap.pre_environment } in + let b_content = fst b in + (s :: b_content, b_wrap') + +let statements (lst:(environment -> statement) list) e : statement list = + let rec aux lst e = match lst with + | [] -> [] + | hd :: tl -> + let s = hd e in + s :: aux tl (snd s).post_environment + in + aux lst e diff --git a/mini_c/dune b/mini_c/dune new file mode 100644 index 000000000..059ce005f --- /dev/null +++ b/mini_c/dune @@ -0,0 +1,13 @@ +(library + (name mini_c) + (public_name ligo.mini_c) + (libraries + simple-utils + tezos-utils + meta_michelson + ) + (preprocess + (pps simple-utils.ppx_let_generalized) + ) + (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils )) +) diff --git a/mini_c/environment.ml b/mini_c/environment.ml new file mode 100644 index 000000000..8c1bc796c --- /dev/null +++ b/mini_c/environment.ml @@ -0,0 +1,61 @@ +(* open Trace *) +open Types + +(* module type ENVIRONMENT = sig + * type element = environment_element + * type t = environment + * + * val empty : t + * val add : element -> t -> t + * val concat : t list -> t + * val get_opt : string -> t -> type_value option + * val get_i : string -> t -> (type_value * int) + * val of_list : element list -> t + * val closure_representation : t -> type_value + * end *) + +module Environment (* : ENVIRONMENT *) = struct + type element = environment_element + type t = environment + + let empty : t = [] + let add : element -> t -> t = List.cons + let concat : t list -> t = List.concat + let get_opt : string -> t -> type_value option = List.assoc_opt + let has : string -> t -> bool = fun s t -> + match get_opt s t with + | None -> false + | Some _ -> true + let get_i : string -> t -> (type_value * int) = List.assoc_i + let of_list : element list -> t = fun x -> x + let to_list : t -> element list = fun x -> x + let get_names : t -> string list = List.map fst + let remove : int -> t -> t = List.remove + + let select : string list -> t -> t = fun lst env -> + let e_lst = + let e_lst = to_list env in + let aux selector (s , _) = + match List.mem s selector with + | true -> List.remove_element s selector , true + | false -> selector , false in + let e_lst' = List.fold_map_right aux lst e_lst in + let e_lst'' = List.combine e_lst e_lst' in + e_lst'' in + of_list + @@ List.map fst + @@ List.filter snd + @@ e_lst + + + let fold : _ -> 'a -> t -> 'a = List.fold_left + let filter : _ -> t -> t = List.filter + + let closure_representation : t -> type_value = fun t -> + match t with + | [] -> T_base Base_unit + | [ a ] -> snd a + | hd :: tl -> List.fold_left (fun acc cur -> T_pair (acc , snd cur)) (snd hd) tl +end + +include Environment diff --git a/mini_c/mini_c.ml b/mini_c/mini_c.ml new file mode 100644 index 000000000..5f4e9f5a2 --- /dev/null +++ b/mini_c/mini_c.ml @@ -0,0 +1,10 @@ +module Types = Types +include Types + +module PP = PP +module Combinators = struct + include Combinators + include Combinators_smart +end +include Combinators +module Environment = Environment diff --git a/mini_c/types.ml b/mini_c/types.ml new file mode 100644 index 000000000..d37fb4daf --- /dev/null +++ b/mini_c/types.ml @@ -0,0 +1,109 @@ +type type_name = string + +type type_base = + | Base_unit + | Base_bool + | Base_int | Base_nat | Base_tez + | Base_string | Base_bytes | Base_address + | Base_operation + +type type_value = + | T_pair of (type_value * type_value) + | T_or of type_value * type_value + | T_function of type_value * type_value + | T_deep_closure of environment * type_value * type_value + | T_base of type_base + | T_map of (type_value * type_value) + | T_list of type_value + | T_contract of type_value + | T_option of type_value + +and environment_element = string * type_value + +and environment = environment_element list + +type environment_wrap = { + pre_environment : environment ; + post_environment : environment ; +} + +type var_name = string +type fun_name = string + +type value = + | D_unit + | D_bool of bool + | D_nat of int + | D_tez of int + | D_int of int + | D_string of string + | D_bytes of bytes + | D_pair of value * value + | D_left of value + | D_right of value + | D_some of value + | D_none + | D_map of (value * value) list + | D_list of value list + (* | `Macro of anon_macro ... The future. *) + | D_function of anon_function + | D_operation of Memory_proto_alpha.Alpha_context.packed_internal_operation + +and selector = var_name list + +and expression' = + | E_literal of value + | E_capture_environment of selector + | E_constant of string * expression list + | E_application of expression * expression + | E_variable of var_name + | E_empty_map of (type_value * type_value) + | 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' ; + type_value : type_value ; + environment : environment ; (* Environment in which the expressions are evaluated *) + is_toplevel : bool ; +} + +and assignment = var_name * expression + +and statement' = + | S_environment_select of environment + | S_environment_load of (expression * environment) + | S_environment_add of (var_name * type_value) + | S_declaration of assignment (* First assignment *) + | S_assignment of assignment + | S_do of expression + | S_cond of expression * block * block + | S_patch of string * [`Left | `Right] list * expression + | S_if_none of expression * block * ((var_name * type_value) * block) + | S_while of expression * block + +and statement = statement' * environment_wrap + +and toplevel_statement = assignment * environment_wrap + +and anon_function = { + binder : string ; + input : type_value ; + output : type_value ; + body : block ; + result : expression ; +} + +and capture = + | No_capture (* For functions that don't capture their environments. Quotes. *) + | Deep_capture of environment (* Retrieves only the values it needs. Multiple SETs on init. Lighter GETs and SETs at use. *) + +and block' = statement list + +and block = block' * environment_wrap + +and program = toplevel_statement list diff --git a/operators/dune b/operators/dune new file mode 100644 index 000000000..f19047fd0 --- /dev/null +++ b/operators/dune @@ -0,0 +1,14 @@ +(library + (name operators) + (public_name ligo.operators) + (libraries + simple-utils + tezos-utils + ast_typed + mini_c + ) + (preprocess + (pps simple-utils.ppx_let_generalized) + ) + (flags (:standard -open Simple_utils )) +) diff --git a/operators/operators.ml b/operators/operators.ml new file mode 100644 index 000000000..827c42bc6 --- /dev/null +++ b/operators/operators.ml @@ -0,0 +1,407 @@ +open Trace + +module Simplify = struct + + let type_constants = [ + ("unit" , 0) ; + ("string" , 0) ; + ("bytes" , 0) ; + ("nat" , 0) ; + ("int" , 0) ; + ("tez" , 0) ; + ("bool" , 0) ; + ("operation" , 0) ; + ("address" , 0) ; + ("contract" , 1) ; + ("list" , 1) ; + ("option" , 1) ; + ("set" , 1) ; + ("map" , 2) ; + ("big_map" , 2) ; + ] + + let constants = [ + ("get_force" , 2) ; + ("transaction" , 3) ; + ("get_contract" , 1) ; + ("size" , 1) ; + ("int" , 1) ; + ("abs" , 1) ; + ("amount" , 0) ; + ("unit" , 0) ; + ("source" , 0) ; + ] + + module Camligo = struct + let constants = [ + ("Bytes.pack" , 1) ; + ("Crypto.hash" , 1) ; + ("Operation.transaction" , 3) ; + ("Operation.get_contract" , 1) ; + ("sender" , 0) ; + ("unit" , 0) ; + ("source" , 0) ; + ] + end + +end + +module Typer = struct + module Errors = struct + let wrong_param_number = fun name -> + let title () = "wrong number of params" in + let full () = name in + error title full + end + + open Ast_typed + + type typer_predicate = type_value list -> bool + type type_result = string * type_value + type typer' = type_value list -> type_value option -> type_result result + type typer = string * int * (typer_predicate * typer') list + + let predicate_0 : typer_predicate = fun lst -> + match lst with + | [] -> true + | _ -> false + + let predicate_1 : (type_value -> bool) -> typer_predicate = fun f lst -> + match lst with + | [ a ] -> f a + | _ -> false + + let predicate_2 : (type_value -> type_value -> bool) -> typer_predicate = fun f lst -> + match lst with + | [ a ; b ] -> f a b + | _ -> false + + let predicate_3 : (type_value -> type_value -> type_value -> bool) -> typer_predicate = fun f lst -> + match lst with + | [ a ; b ; c ] -> f a b c + | _ -> false + + let true_1 = predicate_1 (fun _ -> true) + let true_2 = predicate_2 (fun _ _ -> true) + let true_3 = predicate_3 (fun _ _ _ -> true) + + let eq_1 : type_value -> typer_predicate = fun v -> + let aux = fun a -> type_value_eq (a, v) in + predicate_1 aux + + let eq_2 : type_value -> typer_predicate = fun v -> + let aux = fun a b -> type_value_eq (a, v) && type_value_eq (b, v) in + predicate_2 aux + + let typer'_0 : (type_value option -> type_result result) -> typer' = fun f lst tv -> + match lst with + | [] -> f tv + | _ -> simple_fail "!!!" + + let typer'_1 : (type_value -> type_result result) -> typer' = fun f lst _ -> + match lst with + | [ a ] -> f a + | _ -> simple_fail "!!!" + + let typer'_1_opt : (type_value -> type_value option -> type_result result) -> typer' = fun f lst tv_opt -> + match lst with + | [ a ] -> f a tv_opt + | _ -> simple_fail "!!!" + + let typer'_2 : (type_value -> type_value -> type_result result) -> typer' = fun f lst _ -> + match lst with + | [ a ; b ] -> f a b + | _ -> simple_fail "!!!" + + let typer'_3 : (type_value -> type_value -> type_value -> type_result result) -> typer' = fun f lst _ -> + match lst with + | [ a ; b ; c ] -> f a b c + | _ -> simple_fail "!!!" + + let typer_constant cst : typer' = fun _ _ -> ok cst + + let constant_2 : string -> type_value -> typer' = fun s tv -> + let aux = fun _ _ -> ok (s, tv) in + typer'_2 aux + + let make_2 : string -> _ list -> typer = fun name pfs -> + (name , 2 , List.map (Tuple.map_h_2 predicate_2 typer'_2) pfs) + + let same_2 : string -> (string * type_value) list -> typer = fun s lst -> + let aux (s, tv) = eq_2 tv, constant_2 s tv in + (s , 2 , List.map aux lst) + + let very_same_2 : string -> type_value -> typer = fun s tv -> same_2 s [s , tv] + + open Combinators + + let comparator : string -> typer = fun s -> s , 2 , [ + (eq_2 (t_int ()), constant_2 s (t_bool ())) ; + (eq_2 (t_nat ()), constant_2 s (t_bool ())) ; + (eq_2 (t_tez ()), constant_2 s (t_bool ())) ; + (eq_2 (t_bytes ()), constant_2 s (t_bool ())) ; + (eq_2 (t_string ()), constant_2 s (t_bool ())) ; + (eq_2 (t_address ()), constant_2 s (t_bool ())) ; + ] + + let boolean_operator_2 : string -> typer = fun s -> very_same_2 s (t_bool ()) + + let none = "NONE" , 0 , [ + predicate_0 , typer'_0 (fun tv_opt -> match tv_opt with + | None -> simple_fail "untyped NONE" + | Some t -> ok ("NONE", t)) + ] + + let sub = "SUB" , 2 , [ + eq_2 (t_int ()) , constant_2 "SUB_INT" (t_int ()) ; + eq_2 (t_nat ()) , constant_2 "SUB_NAT" (t_int ()) ; + ] + + let some = "SOME" , 1 , [ + true_1 , typer'_1 (fun s -> ok ("SOME", t_option s ())) ; + ] + + let map_remove : typer = "MAP_REMOVE" , 2 , [ + (true_2 , typer'_2 (fun k m -> + let%bind (src, _) = get_t_map m in + let%bind () = assert_type_value_eq (src, k) in + ok ("MAP_REMOVE", m) + )) + ] + + let map_update : typer = "MAP_UPDATE" , 3 , [ + (true_3 , typer'_3 (fun k v m -> + let%bind (src, dst) = get_t_map m in + let%bind () = assert_type_value_eq (src, k) in + let%bind () = assert_type_value_eq (dst, v) in + ok ("MAP_UPDATE", m))) + ] + + let size : typer = "size" , 1 , [ + (true_1, typer'_1 (fun t -> + let%bind () = bind_or (assert_t_map t, assert_t_list t) in + ok ("SIZE", t_nat ()))) + ] + + let get_force : typer = "get_force" , 2 , [ + (true_2, typer'_2 (fun i_ty m_ty -> + let%bind (src, dst) = get_t_map m_ty in + let%bind _ = assert_type_value_eq (src, i_ty) in + ok ("GET_FORCE", dst))) + ] + + let int : typer = "int" , 1 , [ + (eq_1 (t_nat ()), typer_constant ("INT" , t_int ())) + ] + + let bytes_pack : typer = "Bytes.pack" , 1 , [ + (true_1 , typer'_1 (fun _ -> ok ("PACK" , t_bytes ()))) + ] + + let bytes_unpack = "Bytes.unpack" , 1 , [ + eq_1 (t_bytes ()) , typer'_1_opt (fun _ tv_opt -> match tv_opt with + | None -> simple_fail "untyped UNPACK" + | Some t -> ok ("UNPACK", t)) + ] + + let crypto_hash = "Crypto.hash" , 1 , [ + eq_1 (t_bytes ()) , typer_constant ("HASH" , t_bytes ()) ; + ] + + let sender = "sender" , 0 , [ + predicate_0 , typer_constant ("SENDER", t_address ()) + ] + + let source = "source" , 0 , [ + predicate_0 , typer_constant ("SOURCE", t_address ()) + ] + + let unit = "unit" , 0 , [ + predicate_0 , typer_constant ("UNIT", t_unit ()) + ] + + let amount = "amount" , 0 , [ + predicate_0 , typer_constant ("AMOUNT", t_tez ()) + ] + + let transaction = "Operation.transaction" , 3 , [ + true_3 , typer'_3 ( + fun param amount contract -> + let%bind () = + assert_t_tez amount in + let%bind contract_param = + get_t_contract contract in + let%bind () = + assert_type_value_eq (param , contract_param) in + ok ("TRANSFER_TOKENS" , t_operation ()) + ) + ] + let transaction' = "transaction" , 3 , [ + true_3 , typer'_3 ( + fun param amount contract -> + let%bind () = + assert_t_tez amount in + let%bind contract_param = + get_t_contract contract in + let%bind () = + assert_type_value_eq (param , contract_param) in + ok ("TRANSFER_TOKENS" , t_operation ()) + ) + ] + + let get_contract = "Operation.get_contract" , 1 , [ + eq_1 (t_address ()) , typer'_1_opt ( + fun _ tv_opt -> + let%bind tv = + trace_option (simple_error "get_contract needs a type annotation") tv_opt in + let%bind tv' = + trace_strong (simple_error "get_contract has a not-contract annotation") @@ + get_t_contract tv in + ok ("CONTRACT" , t_contract tv' ()) + ) + ] + let get_contract' = "get_contract" , 1 , [ + eq_1 (t_address ()) , typer'_1_opt ( + fun _ tv_opt -> + let%bind tv = + trace_option (simple_error "get_contract needs a type annotation") tv_opt in + let%bind tv' = + trace_strong (simple_error "get_contract has a not-contract annotation") @@ + get_t_contract tv in + ok ("CONTRACT" , t_contract tv' ()) + ) + ] + + let num_2 : typer_predicate = + let aux = fun a b -> + (type_value_eq (a , t_int ()) || type_value_eq (a , t_nat ())) && + (type_value_eq (b , t_int ()) || type_value_eq (b , t_nat ())) in + predicate_2 aux + + let mod_ = "MOD" , 2 , [ + num_2 , constant_2 "MOD" (t_nat ()) ; + ] + + let abs = "abs" , 1 , [ + eq_1 (t_int ()) , typer_constant ("ABS" , (t_nat ())) ; + ] + + let times = "TIMES" , 2 , [ + (eq_2 (t_nat ()) , constant_2 "TIMES_NAT" (t_nat ())) ; + (num_2 , constant_2 "TIMES_INT" (t_int ())) ; + ( + let aux a b = + (type_value_eq (a , t_nat ()) && type_value_eq (b , t_tez ())) || + (type_value_eq (b , t_nat ()) && type_value_eq (a , t_tez ())) in + predicate_2 aux , constant_2 "TIMES_TEZ" (t_tez ()) + ) ; + ] + + let constant_typers = + let typer_to_kv : typer -> (string * _) = fun (a, b, c) -> (a, (b, c)) in + Map.String.of_list + @@ List.map typer_to_kv [ + same_2 "ADD" [ + ("ADD_INT" , t_int ()) ; + ("ADD_NAT" , t_nat ()) ; + ("CONCAT" , t_string ()) ; + ] ; + times ; + same_2 "DIV" [ + ("DIV_INT" , t_int ()) ; + ("DIV_NAT" , t_nat ()) ; + ] ; + mod_ ; + sub ; + none ; + some ; + comparator "EQ" ; + comparator "NEQ" ; + comparator "LT" ; + comparator "GT" ; + comparator "LE" ; + comparator "GE" ; + boolean_operator_2 "OR" ; + boolean_operator_2 "AND" ; + map_remove ; + map_update ; + int ; + size ; + get_force ; + bytes_pack ; + bytes_unpack ; + crypto_hash ; + sender ; + source ; + unit ; + amount ; + transaction ; + transaction' ; + get_contract ; + get_contract' ; + abs ; + ] + +end + +module Compiler = struct + + module Michelson = Tezos_utils.Micheline.Michelson + open Michelson + + type predicate = + | Constant of michelson + | Unary of michelson + | Binary of michelson + | Ternary of michelson + + let simple_constant c = Constant c + + let simple_unary c = Unary c + + let simple_binary c = Binary c + + let simple_ternary c = Ternary c + + let predicates = Map.String.of_list [ + ("ADD_INT" , simple_binary @@ prim I_ADD) ; + ("ADD_NAT" , simple_binary @@ prim I_ADD) ; + ("SUB_INT" , simple_binary @@ prim I_SUB) ; + ("SUB_NAT" , simple_binary @@ prim I_SUB) ; + ("TIMES_INT" , simple_binary @@ prim I_MUL) ; + ("TIMES_NAT" , simple_binary @@ prim I_MUL) ; + ("TIMES_TEZ" , simple_binary @@ prim I_MUL) ; + ("DIV_INT" , simple_binary @@ seq [prim I_EDIV ; i_assert_some_msg (i_push_string "DIV by 0") ; i_car]) ; + ("DIV_NAT" , simple_binary @@ seq [prim I_EDIV ; i_assert_some_msg (i_push_string "DIV by 0") ; i_car]) ; + ("MOD" , simple_binary @@ seq [prim I_EDIV ; i_assert_some_msg (i_push_string "MOD by 0") ; i_cdr]) ; + ("NEG" , simple_unary @@ prim I_NEG) ; + ("OR" , simple_binary @@ prim I_OR) ; + ("AND" , simple_binary @@ prim I_AND) ; + ("PAIR" , simple_binary @@ prim I_PAIR) ; + ("CAR" , simple_unary @@ prim I_CAR) ; + ("CDR" , simple_unary @@ prim I_CDR) ; + ("EQ" , simple_binary @@ seq [prim I_COMPARE ; prim I_EQ]) ; + ("NEQ" , simple_binary @@ seq [prim I_COMPARE ; prim I_NEQ]) ; + ("LT" , simple_binary @@ seq [prim I_COMPARE ; prim I_LT]) ; + ("LE" , simple_binary @@ seq [prim I_COMPARE ; prim I_LE]) ; + ("GT" , simple_binary @@ seq [prim I_COMPARE ; prim I_GT]) ; + ("GE" , simple_binary @@ seq [prim I_COMPARE ; prim I_GE]) ; + ("UPDATE" , simple_ternary @@ prim I_UPDATE) ; + ("SOME" , simple_unary @@ prim I_SOME) ; + ("GET_FORCE" , simple_binary @@ seq [prim I_GET ; i_assert_some_msg (i_push_string "GET_FORCE")]) ; + ("GET" , simple_binary @@ prim I_GET) ; + ("SIZE" , simple_unary @@ prim I_SIZE) ; + ("FAILWITH" , simple_unary @@ prim I_FAILWITH) ; + ("ASSERT" , simple_binary @@ i_if (seq [i_failwith]) (seq [i_drop ; i_push_unit])) ; + ("INT" , simple_unary @@ prim I_INT) ; + ("ABS" , simple_unary @@ prim I_ABS) ; + ("CONS" , simple_binary @@ prim I_CONS) ; + ("UNIT" , simple_constant @@ prim I_UNIT) ; + ("AMOUNT" , simple_constant @@ prim I_AMOUNT) ; + ("TRANSFER_TOKENS" , simple_ternary @@ prim I_TRANSFER_TOKENS) ; + ("SOURCE" , simple_constant @@ prim I_SOURCE) ; + ("SENDER" , simple_constant @@ prim I_SENDER) ; + ( "MAP_UPDATE" , simple_ternary @@ seq [dip (i_some) ; prim I_UPDATE ]) ; + ] + +end diff --git a/parser/camligo/.gitignore b/parser/camligo/.gitignore new file mode 100644 index 000000000..5d2e66768 --- /dev/null +++ b/parser/camligo/.gitignore @@ -0,0 +1,2 @@ +ast_generated.ml +parser_generated.mly diff --git a/parser/camligo/ast.ml b/parser/camligo/ast.ml new file mode 100644 index 000000000..00523c894 --- /dev/null +++ b/parser/camligo/ast.ml @@ -0,0 +1 @@ +include Ast_generated diff --git a/parser/camligo/dune b/parser/camligo/dune new file mode 100644 index 000000000..c83279eed --- /dev/null +++ b/parser/camligo/dune @@ -0,0 +1,60 @@ +(library + (name parser_camligo) + (public_name ligo.parser.camligo) + (libraries + simple-utils + tezos-utils + lex + ) + (modules ast ast_generated parser user) + (flags (:standard -w +1..62-4-9-44-40-42-48@39@33 -open Simple_utils -open Tezos_utils )) + (preprocess + (pps + simple-utils.ppx_let_generalized + ppx_deriving.std + ) + ) +) + +;; Generating parser + +(rule + (targets parser.ml parser.mli) + (deps parser_generated.mly ast.ml) + (action (system "menhir --explain --external-tokens Lex.Token lex/token.mly parser_generated.mly --base parser")) +) + +(rule + (targets parser_generated.mly) + (deps partial_parser.mly pre_parser.mly) + (action (system "cat pre_parser.mly partial_parser.mly > parser_generated.mly")) + (mode promote-until-clean) +) + +(rule + (targets partial_parser.mly) + (deps generator.exe) + (action (system "./generator.exe parser > partial_parser.mly")) +) + +;; Generating AST + +(rule + (targets ast_generated.ml) + (deps generator.exe) + (action (system "./generator.exe ast > ast_generated.ml")) + (mode promote-until-clean) +) + +;; Generating Generator + +(executable + (name generator) + (libraries + ocamlgraph + simple-utils + tezos-utils + lex + ) + (modules generator) +) diff --git a/parser/camligo/generator.ml b/parser/camligo/generator.ml new file mode 100644 index 000000000..c8abd06bd --- /dev/null +++ b/parser/camligo/generator.ml @@ -0,0 +1,739 @@ +open Simple_utils + +type 'a name = { + content : 'a ; + name : string ; +} + +let make_name name content = { name ; content } +let destruct {name ; content} = (name, content) +let get_name x = x.name +let get_content x = x.content + +module Token = Lex.Token +type token = Token.token + +module O = struct + + type list_mode = + | Trail of token + | Trail_option of token + | Trail_force of token + | Trail_force_ne of token + | Lead of token + | Lead_ne of token + | Separated of token + | Separated_ne of token + | Separated_nene of token + | Naked + | Naked_ne + + type 'a list_element = list_mode * 'a + + type rhs_element = [ + | `Named of string + | `Token of token + | `List of string list_element + | `Option of string + ] + + type rhs = rhs_element list name + type rule = rhs list name + + type manual_rule_content = { + menhir_codes : string list ; + ast_code : string ; + } + type manual_rule = manual_rule_content name + + type singleton = + | Manual of manual_rule + | Generated of rule + + type name_element = [ + | `Named of string + | `Current + | `Lower + ] + + type element = [ + | `Named of string + | `Token of token + | `List of name_element list_element + | `Current + | `Lower + ] + + type operator = element list + type n_operator = operator name + + type n_operators = n_operator list + type level = n_operators name + type level_list = level list + type levels = level List.Ne.t + + type hierarchy = { + prefix : string ; + levels : levels ; + auxiliary_rules : rule list ; + } + type n_hierarchy = hierarchy name + let make_hierarchy prefix levels auxiliary_rules : hierarchy = { levels ; auxiliary_rules ; prefix } + + type language = { + entry_point : string ; + singletons : singleton list ; + hierarchies : n_hierarchy list ; + } + + let get_op : n_operator -> operator = get_content + + let manual_singleton name menhir_codes ast_code : singleton = Manual (make_name name {menhir_codes ; ast_code}) + let rule_singleton rule : singleton = Generated rule + let language entry_point singletons hierarchies = {entry_point ; singletons ; hierarchies} + + let name_hierarchy name prefix : n_operators list -> rule list -> n_hierarchy = fun nopss rules -> + let nopss' = List.Ne.of_list nopss in + let name_i : int -> n_operators -> level = fun i x -> + let first = get_name (List.hd x) in + let name' = Format.asprintf "%s_%d_%s" name i first in + make_name name' x in + let levels : levels = List.Ne.mapi name_i nopss' in + make_name name @@ make_hierarchy prefix levels rules + +end + +module Check = struct + open O + + let well_formed : language -> unit = fun l -> + let elements : element list -> unit = fun es -> + let rec aux = fun es -> + match es with + | [] -> () + | [ _ ] -> () + | (`List _ | `Named _ | `Current | `Lower) :: (`List _ | `Named _ | `Current | `Lower) :: _ -> + raise (Failure "two non-token separated ops in a row") + | _ :: tl -> aux tl + in + (if (List.length es < 2) then raise (Failure "operator is too short")) ; + aux es in + let op : n_operator -> unit = fun x -> elements @@ get_content x in + let level : level -> unit = fun l -> List.iter op @@ get_content l in + let hierarchy : n_hierarchy -> unit = fun h -> List.Ne.iter level @@ h.content.levels in + List.iter hierarchy l.hierarchies + + let associativity : language -> unit = fun l -> + let level : level -> unit = fun l -> + let aux : ([`Left | `Right | `None] as 'a) -> n_operator -> 'a = fun ass nop -> + let op = get_content nop in + match ass, List.hd op, List.nth op (List.length op - 1) with + | _, `Lower, `Lower -> raise (Failure "double assoc") + | `None, `Lower, _ -> `Left + | `None, _, `Lower -> `Right + | `Left, _, `Lower -> raise (Failure "different assocs") + | `Right, `Lower, _ -> raise (Failure "different assocs") + | m, _, _ -> m + in + let _assert = List.fold_left aux `None (get_content l) in + () + in + let hierarchy : n_hierarchy -> unit = fun h -> + List.Ne.iter level h.content.levels in + List.iter hierarchy l.hierarchies + +end + + +let make_constructor : _ -> (string * string) -> unit = fun ppf (gr, rhs) -> + let gr = String.capitalize_ascii gr in + match rhs with + | "" -> Format.fprintf ppf "%s" gr + | s -> Format.fprintf ppf "%s_%s" gr s + +let make_operator : _ -> (string * string) -> unit = fun ppf (prefix, op) -> + Format.fprintf ppf "%s_%s" prefix op + +module Print_AST = struct + open Format + open PP_helpers + + let manual_rule : _ -> O.manual_rule -> _ = fun ppf mr -> + fprintf ppf "%s = %s" mr.name mr.content.ast_code + + let generated_rule : _ -> O.rule -> _ = fun ppf gr -> + let aux : _ -> O.rhs -> _ = fun ppf rhs -> + let type_elements = + let aux : O.rhs_element -> string option = fun e -> + match e with + | `Named s -> Some (s ^ " Location.wrap") + | `List ( _, s) -> Some ("(" ^ s ^ " Location.wrap list)") + | `Option s -> Some ("(" ^ s ^ " Location.wrap option)") + | `Token _ -> None + in + List.filter_map aux rhs.content in + let type_element = fun ppf te -> fprintf ppf "%s" te in + fprintf ppf "| %a of (%a)" + make_constructor (gr.name, rhs.name) + (list_sep type_element (const " * ")) type_elements + in + fprintf ppf "%s =@. @[%a@]" gr.name + (list_sep aux new_line) gr.content + + let singleton : _ -> O.singleton -> _ = fun ppf s -> + match s with + | Manual s -> manual_rule ppf s + | Generated s -> generated_rule ppf s + + let singletons : _ -> O.singleton list -> _ = fun ppf ss -> + match ss with + | [] -> () + | hd :: tl -> + fprintf ppf "%a\n" (prepend "type " (singleton)) hd ; + fprintf ppf "%a" (list_sep (prepend "and " (singleton)) (const "\n")) tl + + let n_operator prefix level_name : _ -> O.n_operator -> _ = fun ppf nop -> + let type_elements = + let aux : O.element -> string option = fun e -> + match e with + | `Named s -> Some (s ^ " Location.wrap") + | `List ( _, s) -> Some ("(" ^ (match s with + | `Lower | `Current -> level_name |`Named s -> s + ) ^ " Location.wrap list)") + | `Token _ -> None + | `Current | `Lower -> Some (level_name ^ " Location.wrap") in + List.filter_map aux (get_content nop) in + let type_element = fun ppf te -> fprintf ppf "%s" te in + fprintf ppf "| %a of (%a)" + make_operator (prefix, nop.name) + (list_sep type_element (const " * ")) type_elements + + let n_hierarchy t : _ -> O.n_hierarchy -> _ = fun ppf nh -> + let levels = List.Ne.map get_content ((get_content nh).levels) in + let nops = List.Ne.concat levels in + let name = get_name nh in + fprintf ppf "%s %s =@.@[%a@] [@@@@deriving show]" t + name + (list_sep (n_operator nh.content.prefix name) new_line) nops + + let n_hierarchies (first:bool) : _ -> O.n_hierarchy list -> _ = fun ppf ss -> + match ss with + | [] -> () + | hd :: tl -> + fprintf ppf "%a\n" (n_hierarchy (if first then "type" else "and")) hd ; + fprintf ppf "%a" (list_sep (n_hierarchy "and") (const "\n")) tl + + let language : _ -> O.language -> _ = fun ppf l -> + fprintf ppf "%a@.@." comment "Language" ; + let first = List.length l.singletons = 0 in + fprintf ppf " %a@.%a@.@." comment "Singletons" singletons l.singletons ; + fprintf ppf " %a@.%a@." comment "Hierarchies" (n_hierarchies first) l.hierarchies ; + fprintf ppf " %a@.type entry_point = %s Location.wrap@.@." comment "Entry point" l.entry_point ; + () +end + +module Print_Grammar = struct + open Format + open PP_helpers + + let letters = [| "a" ; "b" ; "c" ; "d" ; "e" ; "f" ; "g" ; "h" ; "i" ; "j" |] + + + let manual_rule : _ -> O.manual_rule -> _ = fun ppf mr -> + let {name;content} = mr in + fprintf ppf "%s:@. @[%a@]" name (list_sep string new_line) content.menhir_codes + + let generated_rule : _ -> O.rule -> _ = fun ppf gr -> + let aux_rule : _ -> O.rhs -> _ = fun ppf rhs -> + let i = ref 0 in + let aux : _ -> O.rhs_element -> _ = fun ppf e -> + (match e with + | `Named s -> fprintf ppf "%s = wrap(%s)" letters.(!i) s + | `Option s -> fprintf ppf "%s = option(wrap(%s))" letters.(!i) s + | `List (mode, s) -> + fprintf ppf "%s = %swrap(%s))" + letters.(!i) + (match mode with + | Naked -> "naked_list(" + | Naked_ne -> "naked_list_ne(" + | Lead s -> "lead_list(" ^ (Token.to_string s) ^ "," + | Lead_ne s -> "lead_list_ne(" ^ (Token.to_string s) ^ "," + | Trail s -> "trail_list(" ^ (Token.to_string s) ^ "," + | Trail_option s -> "trail_option_list(" ^ (Token.to_string s) ^ "," + | Trail_force s -> "trail_force_list(" ^ (Token.to_string s) ^ "," + | Trail_force_ne s -> "trail_force_list_ne(" ^ (Token.to_string s) ^ "," + | Separated s -> "separated_list(" ^ (Token.to_string s) ^ "," + | Separated_ne s -> "separated_list_ne(" ^ (Token.to_string s) ^ "," + | Separated_nene s -> "separated_list_nene(" ^ (Token.to_string s) ^ "," + ) + s + | `Token t -> i := !i - 1 ; string ppf @@ Token.to_string t) ; + i := !i + 1 + in + fprintf ppf "%a" (list_sep aux (const " ")) rhs.content in + let aux_code : _ -> O.rhs -> _ = fun ppf rhs -> + let i = ref 0 in + let aux : O.rhs_element -> _ = fun e -> + let s = (match e with + | `Named _ | `List _ | `Option _ -> Some (letters.(!i)) + | `Token _ -> i := !i - 1 ; None) in + i := !i + 1 ; s + in + let content = List.filter_map aux rhs.content in + fprintf ppf "%a (%a)" make_constructor (gr.name, rhs.name) (list_sep string (const " , ")) content + in + let aux : _ -> O.rhs -> _ = fun ppf rhs -> + fprintf ppf "| %a { %a }" + aux_rule rhs + aux_code rhs in + fprintf ppf "%s:@.%a" gr.name (list_sep aux (const "\n")) gr.content + + let singleton : _ -> O.singleton -> _ = fun ppf s -> + match s with + | Manual s -> manual_rule ppf s + | Generated s -> generated_rule ppf s + + + let n_operator_rule prev_lvl_name cur_lvl_name : _ -> O.n_operator -> _ = fun ppf nop -> + let i = ref 0 in + let element : _ -> O.element -> _ = fun ppf element -> + (match element with + | `Token t -> i := !i - 1 ; string ppf @@ Token.to_string t + | `List (mode, content) -> + fprintf ppf "%s = %swrap(%s))" + letters.(!i) + (match mode with + | Naked -> "naked_list(" + | Naked_ne -> "naked_list_ne(" + | Lead s -> "lead_list(" ^ (Token.to_string s) ^ "," + | Lead_ne s -> "lead_list_ne(" ^ (Token.to_string s) ^ "," + | Trail s -> "trail_list(" ^ (Token.to_string s) ^ "," + | Trail_option s -> "trail_option_list(" ^ (Token.to_string s) ^ "," + | Trail_force s -> "trail_force_list(" ^ (Token.to_string s) ^ "," + | Trail_force_ne s -> "trail_force_list_ne(" ^ (Token.to_string s) ^ "," + | Separated s -> "separated_list(" ^ (Token.to_string s) ^ "," + | Separated_ne s -> "separated_list_ne(" ^ (Token.to_string s) ^ "," + | Separated_nene s -> "separated_list_nene(" ^ (Token.to_string s) ^ "," + ) + (match content with | `Lower -> prev_lvl_name | `Named s -> s | `Current -> cur_lvl_name) + | `Named n -> + fprintf ppf "%s = wrap(%s)" letters.(!i) n + | `Current -> + fprintf ppf "%s = wrap(%s)" letters.(!i) cur_lvl_name + | `Lower -> + fprintf ppf "%s = wrap(%s)" letters.(!i) prev_lvl_name + ) ; + i := !i + 1 + in + (list_sep element (const " ")) ppf (get_content nop) + + let n_operator_code prefix : _ -> O.n_operator -> _ = fun ppf nop -> + let (name, elements) = destruct nop in + let elements' = + let i = ref 0 in + let aux : O.element -> _ = fun e -> + let r = + match e with + | `Token _ -> i := !i - 1 ; None + | `List _ | `Named _ | `Current | `Lower -> Some letters.(!i) + in i := !i + 1 ; r + in + List.filter_map aux elements in + fprintf ppf "%a (%a)" make_operator (prefix, name) (list_sep string (const " , ")) elements' + + let n_operator prefix prev_lvl_name cur_lvl_name : _ -> O.n_operator -> _ = fun ppf nop -> + let name = get_name nop in + fprintf ppf "%a@;| %a { %a }" comment name + (n_operator_rule prev_lvl_name cur_lvl_name) nop + (n_operator_code prefix) nop + + let level prefix prev_lvl_name : _ -> O.level -> _ = fun ppf l -> + let name = get_name l in + match prev_lvl_name with + | "" -> ( + fprintf ppf "%s :@. @[%a@]" name + (list_sep (n_operator prefix prev_lvl_name name) new_line) (get_content l) ; + ) + | _ -> ( + fprintf ppf "%s :@. @[%a@;| %s { $1 }@]" name + (list_sep (n_operator prefix prev_lvl_name name) new_line) (get_content l) + prev_lvl_name + ) + + let n_hierarchy : _ -> O.n_hierarchy -> _ = fun ppf nh -> + let name = get_name nh in + let top_level = get_name @@ List.Ne.hd nh.content.levels in + fprintf ppf "%a@.%%inline %s : %s { $1 }@.@;" comment ("Top-level for " ^ name) name top_level; + let (hd, tl) = List.Ne.rev (get_content nh).levels in + fprintf ppf "%a" (level nh.content.prefix "") hd ; + let aux prev_name lvl = + new_lines 2 ppf () ; + fprintf ppf "%a" (level nh.content.prefix prev_name) lvl ; + get_name lvl + in + let _last_name = List.fold_left aux (get_name hd) tl in + () + + let language : _ -> O.language -> _ = fun ppf l -> + fprintf ppf "%a@.@." comment "Generated Language" ; + fprintf ppf "entry_point : wrap(%s) EOF { $1 }@.@." l.entry_point ; + fprintf ppf "%a@.@." comment "Singletons" ; + fprintf ppf "@[%a@]@.@." (list_sep singleton new_line) l.singletons ; + fprintf ppf "%a@.@." comment "Hierarchies" ; + fprintf ppf "@[%a@]" (list_sep n_hierarchy new_line) l.hierarchies ; + +end + + +let infix : string -> [`Left | `Right] -> token -> O.n_operator = fun name assoc t -> + match assoc with + | `Left -> make_name name [`Current ; `Token t ; `Lower] + | `Right -> make_name name [`Lower ; `Token t ; `Current] + +(* Ocaml is bad *) +let empty_infix : string -> [`Left | `Right] -> O.n_operator = fun name assoc -> + match assoc with + | `Left -> make_name name [`Current ; `Lower] + | `Right -> make_name name [`Lower ; `Current] + + +let paren : string -> string -> O.n_operator = fun constructor_name name -> + make_name constructor_name [`Token Token.LPAREN ; `Named name ; `Token Token.RPAREN] + +let expression_name = "expression" +let type_expression_name = "type_expression" +let restricted_type_expression_name = "restricted_type_expression" +let program_name = "program" +let variable_name = "variable" +let pattern_name = "pattern" +let constructor_name = "constructor" +let int_name = "int_" +let tz_name = "tz_" +let unit_name = "unit_" +let string_name = "string_" + +let variable = O.manual_singleton variable_name ["| NAME { $1 }"] "string" +let int = O.manual_singleton int_name ["| INT { $1 }"] "int" +let tz = O.manual_singleton tz_name ["| TZ { $1 }"] "int" +let unit = O.manual_singleton unit_name ["| UNIT { () }"] "unit" +let string = O.manual_singleton string_name ["| STRING { $1 }"] "string" +let constructor = O.manual_singleton constructor_name ["| CONSTRUCTOR_NAME { $1 }"] "string" + +module Pattern = struct + + open Token + open O + + let application = empty_infix "application" `Left + + let data_structure : O.n_operator = make_name "data_structure" [ + `Named variable_name ; `Token LSQUARE ; `List (Lead SEMICOLON, `Current) ; `Token RSQUARE ; + ] + + let record_element : O.rule = make_name "p_record_element" [ + make_name "" [`Named variable_name ; `Token EQUAL ; `Named pattern_name] + ] + + let record : O.n_operator = make_name "record" [ + `Token LBRACKET ; + `List (Trail SEMICOLON, `Named record_element.name) ; + `Token RBRACKET ; + ] + + let pair = infix "pair" `Left COMMA + let type_annotation = make_name "type_annotation" [ + `Current ; `Token COLON ; `Named restricted_type_expression_name + ] + + let variable : O.n_operator = make_name "variable" [ `Named variable_name ] + let constructor : O.n_operator = make_name "constructor" [ `Named constructor_name ] + + let module_ident : O.n_operator = make_name "module_ident" [ + `List (Trail_force_ne DOT, `Named constructor_name) ; `Named variable_name ; + ] + + let unit : O.n_operator = make_name "unit" [ `Named unit_name ] + + let restricted_pattern_name = "restricted_pattern" + + let restricted_pattern = O.name_hierarchy restricted_pattern_name "Pr" [ + [variable ; unit] ; + [paren "restrict" pattern_name] + ] [] + + let main = O.name_hierarchy pattern_name "P" [ + [record] ; + [type_annotation] ; + [pair] ; + [data_structure] ; + [application] ; + [variable ; constructor ; module_ident ; unit] ; + [paren "paren" pattern_name] + ] [] + + let singletons = [O.rule_singleton record_element] +end + +module Expression = struct + + open Token + open O + + let application = empty_infix "application" `Right + + let type_annotation = make_name "type_annotation" [ + `Current ; `Token COLON ; `Named restricted_type_expression_name + ] + + let data_structure : O.n_operator = make_name "data_structure" [ + `Named variable_name ; `Token LSQUARE ; `List (Trail SEMICOLON, `Current) ; `Token RSQUARE ; + ] + + let fun_ : O.n_operator = make_name "fun" [ + `Token FUN ; `Named pattern_name ; + `Token ARROW ; `Current ; + ] + + let let_in : O.n_operator = make_name "let_in" [ + `Token LET ; `Named pattern_name ; + `Token EQUAL ; `Current ; + `Token IN ; `Current ; + ] + + let no_seq_name = "expression_no_seq" + let no_match_name = "expression_no_match" + + let record_element : O.rule = make_name "e_record_element" [ + make_name "record_explicit" [`Named variable_name ; `Token EQUAL ; `Named no_seq_name] ; + make_name "record_implicit" [`Named variable_name ] ; + ] + + let record : O.n_operator = make_name "record" [ + `Token LBRACKET ; + `List (Trail SEMICOLON, `Named record_element.name) ; + `Token RBRACKET ; + ] + + let ite : O.n_operator = make_name "ifthenelse" [ + `Token IF ; + `Current ; + `Token THEN ; + `Lower ; + `Token ELSE ; + `Current ; + ] + + let it : O.n_operator = make_name "ifthen" [ + `Token IF ; + `Current ; + `Token THEN ; + `Lower ; + ] + + (* let sequence = infix "sequence" `Left SEMICOLON *) + let sequence = make_name "sequence" [ + `List (Separated_nene SEMICOLON , `Lower) + ] + + let match_clause = make_name "e_match_clause" [ + make_name "" [`Named pattern_name ; `Token ARROW ; `Named no_match_name] + ] + let match_with = make_name "match" [ + `Token MATCH ; `Current ; `Token WITH ; + `List (Lead_ne VBAR, `Named match_clause.name) ; + ] + let lt = infix "lt" `Left LT + let le = infix "le" `Left LE + let gt = infix "gt" `Left GT + let eq = infix "eq" `Left EQUAL + let neq = infix "neq" `Left UNEQUAL + + let cons = infix "cons" `Left DOUBLE_COLON + + let addition = infix "addition" `Left PLUS + let substraction = infix "substraction" `Left MINUS + + let multiplication = infix "multiplication" `Left TIMES + let division = infix "division" `Left DIV + + let arith_variable : O.n_operator = make_name "variable" [ `Named variable_name ] + let int : O.n_operator = make_name "int" [ `Named int_name ] + let tz : O.n_operator = make_name "tz" [ `Named tz_name ] + let unit : O.n_operator = make_name "unit" [ `Named unit_name ] + let string : O.n_operator = make_name "string" [ `Named string_name ] + let constructor : O.n_operator = make_name "constructor" [ `Named constructor_name ] + + let module_ident : O.n_operator = make_name "module_ident" [ + `List (Trail_force_ne DOT, `Named constructor_name) ; `Named variable_name ; + ] + let access : O.n_operator = infix "access" `Right DOT + let accessor : O.n_operator = make_name "accessor" [ + `Named variable_name ; `List (Lead_ne DOT, `Named variable_name) ; + ] + + let assignment : O.n_operator = infix "assign" `Left LEFT_ARROW + + let tuple = make_name "tuple" [ + `List (Separated_nene COMMA, `Lower) + ] + + let name = make_name "name" [`Token TILDE ; `Current] + + let main_hierarchy_name = "expression_main" + + let main_hierarchy = O.name_hierarchy main_hierarchy_name "Eh" [ + [tuple] ; + [type_annotation] ; + [lt ; le ; gt ; eq ; neq] ; + [assignment] ; + [cons] ; + [addition ; substraction] ; + [multiplication ; division] ; + [application] ; + [data_structure] ; + [name] ; + [arith_variable ; constructor ; module_ident ; accessor ; int ; unit ; string ; tz] ; + [paren "bottom" expression_name] ; + ] [] + + let no_sequence_expression = O.name_hierarchy no_seq_name "Es" [ + [let_in ; fun_ ; record ; ite ; it ; match_with] ; + [make_name "main" [`Named main_hierarchy_name]] ; + ] [] + + let no_match_expression = O.name_hierarchy no_match_name "Em" [ + [let_in ; fun_ ; record ; ite ; it ] ; + [make_name "main" [`Named main_hierarchy_name]] ; + ] [] + + let expression = O.name_hierarchy expression_name "E" [ + [sequence] ; + [let_in ; fun_ ; record ; ite ; it ; match_with] ; + [make_name "main" [`Named main_hierarchy_name]] ; + ] [] + + let singletons = List.map O.rule_singleton [record_element ; match_clause] +end + +module Type_expression = struct + + open Token + open O + + let record_element : O.rule = make_name "t_record_element" [ + make_name "" [`Named variable_name ; `Token COLON ; `Named type_expression_name] + ] + + let record : O.n_operator = make_name "record" [ + `Token LBRACKET ; + `List (Trail SEMICOLON, `Named record_element.name) ; + `Token RBRACKET ; + ] + + let application = empty_infix "application" `Right + + let tuple = make_name "tuple" [ + `List (Separated_nene COMMA, `Lower) + ] + + let type_variable : O.n_operator = make_name "variable" [ `Named variable_name ] + + let restricted_type_expression = O.name_hierarchy restricted_type_expression_name "Tr" [ + [application] ; + [type_variable] ; + [paren "paren" type_expression_name] ; + ] [] + + let type_expression = O.name_hierarchy type_expression_name "T" [ + [record] ; + [tuple] ; + [application] ; + [type_variable] ; + [paren "paren" type_expression_name] + ] [] + + let singletons = [O.rule_singleton record_element] + +end + +module Program = struct + + open Token + open O + + let statement_name = "statement" + + let program : O.rule = make_name program_name [make_name "" [ + `List (Trail_option DOUBLE_SEMICOLON, statement_name) + ]] + + let param_name = "param" + + let param : O.rule = make_name param_name [ + make_name "restricted_pattern" [ `Named Pattern.restricted_pattern_name ] ; + make_name "implicit_named_param" [ `Token TILDE ; `Named variable_name ] ; + ] + + let type_annotation_name = "type_annotation_" + let type_annotation : O.rule = make_name type_annotation_name [ + make_name "" [ `Token COLON ; `Named type_expression_name ] ; + ] + + let let_content_name = "let_content" + let let_content : O.rule = make_name let_content_name [ + make_name "" [ + `Named variable_name ; + `List (Naked, param_name) ; + `Option type_annotation_name ; + `Token EQUAL ; + `Named expression_name ; + ] ; + ] + + let statement : O.rule = make_name statement_name [ + make_name "variable_declaration" [`Token LET ; `Named let_content_name] ; + make_name "init_declaration" [`Token LET_INIT ; `Named let_content_name] ; + make_name "entry_declaration" [`Token LET_ENTRY ; `Named let_content_name] ; + make_name "type_declaration" [`Token TYPE ; `Named variable_name ; `Token EQUAL ; `Named type_expression_name] ; + ] + + let singletons = List.map O.rule_singleton [ + let_content ; + type_annotation ; + program ; + statement ; + param ; + ] + +end + +let language = O.language program_name ( + variable :: constructor :: int :: unit :: string :: tz :: + Program.singletons @ + Pattern.singletons @ + Expression.singletons @ + Type_expression.singletons + ) [ + Pattern.main ; + Pattern.restricted_pattern ; + Expression.main_hierarchy ; + Expression.no_sequence_expression ; + Expression.no_match_expression ; + Expression.expression ; + Type_expression.restricted_type_expression ; + Type_expression.type_expression ; + ] + +let () = + let argn = Array.length Sys.argv in + if argn = 1 then exit 1 ; + let arg = Sys.argv.(1) in + match arg with + | "parser" -> ( + Format.printf "%a@.%a\n" PP_helpers.comment "Full Grammar" Print_Grammar.language language + ) + | "ast" -> ( + Format.printf "%a@.%a\n" PP_helpers.comment "AST" Print_AST.language language + ) + | _ -> exit 1 + diff --git a/parser/camligo/lex/dune b/parser/camligo/lex/dune new file mode 100644 index 000000000..c174bd296 --- /dev/null +++ b/parser/camligo/lex/dune @@ -0,0 +1,54 @@ +(library + (name lex) + (public_name ligo.multifix.lex) + (libraries + simple-utils + tezos-utils + ) + (modules token token_type lexer) +) + +(executable + (name generator) + (libraries + str + simple-utils + ) + (modules generator) + (flags (:standard -w +1..62-4-9-44-40-42-48@39@33 )) +) + +(rule + (targets token.mly) + (deps generator.exe) + (action (system "./generator.exe mly > token.mly")) +) + +(rule + (targets token.ml) + (deps generator.exe) + (action (system "./generator.exe ml > token.ml")) +) + +(rule + (targets lexer.mll) + (deps generator.exe) + (action (system "./generator.exe mll > lexer.mll")) +) + +(rule + (targets token_type.ml token_type.mli) + (deps token.mly) + (action (system "menhir --only-tokens token.mly --base token_type")) +) + +(alias + (name lexer.mll) + (deps token.ml) +) + +(rule + (targets lexer.ml) + (deps token.ml lexer.mll) + (action (system "ocamllex lexer.mll")) +) diff --git a/parser/camligo/lex/generator.ml b/parser/camligo/lex/generator.ml new file mode 100644 index 000000000..8b10eeffc --- /dev/null +++ b/parser/camligo/lex/generator.ml @@ -0,0 +1,185 @@ +type pre_token = { + name : string ; + pattern : string ; +} + +let make name pattern = { name ; pattern } + +let keyword = fun k -> + let regexp = Str.regexp "[^0-9a-zA-Z]" in + let constructor_name = + Str.global_replace regexp "_" + @@ String.uppercase_ascii k + in + make constructor_name k +let symbol = fun sym name -> make name sym + +module Print_mly = struct + open Format + + let token = fun ppf pre_token -> + fprintf ppf "%%token %s" pre_token.name + + let tokens = fun ppf tokens -> + let open Simple_utils.PP_helpers in + fprintf ppf "%%token EOF\n" ; + fprintf ppf "%%token INT\n" ; + fprintf ppf "%%token NAT\n" ; + fprintf ppf "%%token TZ\n" ; + fprintf ppf "%%token STRING\n" ; + fprintf ppf "%%token NAME\n" ; + fprintf ppf "%%token CONSTRUCTOR_NAME\n" ; + fprintf ppf "\n%a\n\n" (list_sep token (const "\n")) tokens ; + fprintf ppf "%%%%\n" +end + +module Print_mll = struct + open Format + + let token = fun ppf {name;pattern} -> + fprintf ppf "| \"%s\" { %s }" pattern name + + let pre = + {pre|{ + open Token + + exception Error of string + exception Unexpected_character of string +} + +(* This rule analyzes a single line and turns it into a stream of + tokens. *) + +rule token = parse +(* + | "//" ([^ '\n']* ) (['\n' '\r']+) + { Lexing.new_line lexbuf ; token lexbuf } +*) +| ('\r'? '\n' '\r'?) + { Lexing.new_line lexbuf; token lexbuf } +| '"' { string "" lexbuf } +| [' ' '\t'] + { token lexbuf } +| (['0'-'9']+ as i) 'p' + { NAT (int_of_string i) } +| (['0'-'9']+ as n) '.' (['0'-'9']['0'-'9'] as d) "tz" { TZ ((int_of_string n) * 100 + (int_of_string d)) } +| (['0'-'9']+ as i) + { INT (int_of_string i) } +|pre} + let post = + {post| +| (['a'-'z''_']['a'-'z''A'-'Z''0'-'9''_']*) as v + { NAME v } +| (['A'-'Z']['a'-'z''A'-'Z''0'-'9''_']*) as v + { CONSTRUCTOR_NAME v } +| eof { EOF } +| "(*" { comment 1 lexbuf } +| _ + { raise (Unexpected_character (Printf.sprintf "At offset %d: unexpected character.\n" (Lexing.lexeme_start lexbuf))) } + +and string s = parse + | "\\\"" { string (s ^ "\"") lexbuf } + | "\\\\" { string (s ^ "\\") lexbuf } + | '"' { STRING s } + | eof { raise (Unexpected_character "missing string terminator") } + | _ as c { string (s ^ (String.make 1 c)) lexbuf } + + +and comment n = parse + | "*)" { if n = 1 then token lexbuf else comment (n - 1) lexbuf } + | "(*" { comment (n + 1) lexbuf } + | '"' ( [^ '"' '\\'] | ( '\\' [^ '"'] ) ) '"' { comment n lexbuf } + | eof { raise (Unexpected_character "missing comment terminator") } + | ('\r'? '\n' '\r'?) { Lexing.new_line lexbuf; comment n lexbuf } + | _ { comment n lexbuf } + +|post} + let tokens = fun ppf tokens -> + let open Simple_utils.PP_helpers in + fprintf ppf "%s%a\n%s" pre (list_sep token (const "\n")) tokens post +end + +module Print_ml = struct + open Format + + let token = fun ppf {name} -> + fprintf ppf " | %s -> \"%s\"" name name + + let pre = + {pre|include Token_type + +let to_string : token -> string = function + | STRING _ -> "STRING" + | NAME _ -> "NAME s" + | CONSTRUCTOR_NAME _ -> "CONSTRUCTOR_NAME s" + | INT _ -> "INT n" + | NAT _ -> "NAT n" + | TZ _ -> "TZ n" + | EOF -> "EOF" +|pre} + + let tokens = fun ppf tokens -> + let open Simple_utils.PP_helpers in + fprintf ppf "%s%a" pre (list_sep token (const "\n")) tokens +end + +let tokens = [ + keyword "let%init" ; + keyword "let%entry" ; + keyword "let" ; + keyword "type" ; + keyword "in" ; + keyword "if" ; + keyword "then" ; + keyword "else" ; + (* keyword "block" ; + * keyword "for" ; + * keyword "const" ; *) + keyword "fun" ; + keyword "match" ; + keyword "with" ; + symbol "()" "UNIT" ; + symbol "+" "PLUS" ; + symbol "~" "TILDE" ; + symbol "->" "ARROW" ; + symbol "<-" "LEFT_ARROW" ; + symbol "<=" "LE" ; + symbol "<>" "UNEQUAL" ; + symbol "<" "LT" ; + symbol ">" "GT" ; + symbol "-" "MINUS" ; + symbol "*" "TIMES" ; + symbol "/" "DIV" ; + symbol "=" "EQUAL" ; + symbol "|" "VBAR" ; + symbol "[" "LSQUARE" ; + symbol "]" "RSQUARE" ; + symbol "(" "LPAREN" ; + symbol ")" "RPAREN" ; + symbol "{" "LBRACKET" ; + symbol "}" "RBRACKET" ; + symbol ";;" "DOUBLE_SEMICOLON" ; + symbol ";" "SEMICOLON" ; + symbol "::" "DOUBLE_COLON" ; + symbol ":" "COLON" ; + symbol "," "COMMA" ; + symbol "." "DOT" ; +] + +let () = + let argn = Array.length Sys.argv in + if argn = 1 then exit 1 ; + let arg = Sys.argv.(1) in + let open Simple_utils.PP_helpers in + match arg with + | "mll" -> ( + Format.printf "%a@.%a\n" comment "Generated .mll" Print_mll.tokens tokens + ) + | "mly" -> ( + Format.printf "%a@.%a\n" comment "Generated .mly" Print_mly.tokens tokens + ) + | "ml" -> ( + Format.printf "%a@.%a\n" comment "Generated .ml" Print_ml.tokens tokens + ) + | _ -> exit 1 + diff --git a/parser/camligo/location.ml b/parser/camligo/location.ml new file mode 100644 index 000000000..cd160a125 --- /dev/null +++ b/parser/camligo/location.ml @@ -0,0 +1,25 @@ +type file_location = { + filename : string ; + start_line : int ; + start_column : int ; + end_line : int ; + end_column : int ; +} + +type virtual_location = string + +type t = + | File of file_location + | Virtual of virtual_location + +let make (start_pos:Lexing.position) (end_pos:Lexing.position) : t = + let filename = start_pos.pos_fname in + let start_line = start_pos.pos_lnum in + let end_line = end_pos.pos_lnum in + let start_column = start_pos.pos_cnum - start_pos.pos_bol in + let end_column = end_pos.pos_cnum - end_pos.pos_bol in + File { filename ; start_line ; start_column ; end_line ; end_column } + +let virtual_location s = Virtual s +let dummy = virtual_location "dummy" + diff --git a/parser/camligo/parser_camligo.ml b/parser/camligo/parser_camligo.ml new file mode 100644 index 000000000..9578d27b9 --- /dev/null +++ b/parser/camligo/parser_camligo.ml @@ -0,0 +1,3 @@ +module Ast = Ast +module Parser = Parser +module User = User diff --git a/parser/camligo/pre_parser.mly b/parser/camligo/pre_parser.mly new file mode 100644 index 000000000..159e13d5f --- /dev/null +++ b/parser/camligo/pre_parser.mly @@ -0,0 +1,72 @@ +%{ + open Ast +%} + +%start entry_point + +%% + +naked_list(X): + | { [] } + | x = X xs = naked_list(X) { x :: xs } + +naked_list_ne(X): + | x = X { [ x ] } + | x = X xs = naked_list_ne(X) { x :: xs } + +trail_list(separator, X): + | { [] } + | trail_list_content(separator, X) { $1 } + +trail_list_content(separator, X): + | x = trail_list_last(separator, X) { x } + | x = X separator xs = trail_list_content(separator, X) { x :: xs } + +trail_list_last(separator, X): + | x = X option(separator) { [ x ] } + +trail_force_list(separator, X): + | { [] } + | x = X separator xs = trail_force_list(separator, X) { x :: xs } + +trail_force_list_ne(separator, X): + | x = X separator { [ x ] } + | x = X separator xs = trail_force_list_ne(separator, X) { x :: xs } + +trail_option_list(separator, X): + | { [] } + | trail_option_list_content(separator, X) { $1 } + +trail_option_list_content(separator, X): + | x = trail_option_list_last(separator, X) { x } + | x = X option(separator) xs = trail_option_list_content(separator, X) { x :: xs } + +trail_option_list_last(separator, X): + | x = X option(separator) { [ x ] } + +lead_list_ne(separator, X): + | separator x = X { [x] } + | separator x = X xs = lead_list_ne(separator, X) { x :: xs } + +lead_list(separator, X): + | { [] } + | lead_list_content(separator, X) { $1 } + +lead_list_content(separator, X): + | x = lead_list_first(separator, X) { x } + | xs = lead_list_content(separator, X) separator x = X { xs @ [ x ] } + +lead_list_first (separator, X): + | option(separator) x = X { [ x ] } + +separated_list_ne(separator, X): + | x = X { [x] } + | x = X separator xs = separated_list_ne(separator, X) { x :: xs } + +separated_list_nene(separator, X): + | x = X separator y = X { [x ; y] } + | x = X separator xs = separated_list_nene(separator, X) { x :: xs } + + +%inline wrap(X): + | x = X { let loc = Location.make $startpos $endpos in Location.wrap ~loc x } diff --git a/parser/camligo/user.ml b/parser/camligo/user.ml new file mode 100644 index 000000000..b4fd537ac --- /dev/null +++ b/parser/camligo/user.ml @@ -0,0 +1,40 @@ +open! Trace + +let parse_file (source: string) : Ast.entry_point 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 > %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%bind channel = + generic_try (simple_error "error opening file") @@ + (fun () -> open_in source) in + let lexbuf = Lexing.from_channel channel in + let module Lexer = Lex.Lexer in + (specific_try (fun () -> fun e -> + let error s () = + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + let str () = Format.sprintf + "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 + error s str () in + match e with + | Parser.Error -> (fun () -> error (thunk "Parse") ()) + | Lexer.Error s -> (fun () -> error (fun () -> "Lexer " ^ s) ()) + | Lexer.Unexpected_character s -> error (fun () -> "Unexpected char " ^ s) (* TODO: this allows injection of ANSI escape codes in error messages, fix this. *) + | _ -> simple_error "unrecognized parse_ error" + )) @@ (fun () -> + let raw = Parser.entry_point Lexer.token lexbuf in + raw + ) >>? fun raw -> + ok raw diff --git a/parser/dune b/parser/dune new file mode 100644 index 000000000..32c7b34e4 --- /dev/null +++ b/parser/dune @@ -0,0 +1,14 @@ +(library + (name parser) + (public_name ligo.parser) + (libraries + simple-utils + tezos-utils + parser_pascaligo + parser_camligo + ) + (preprocess + (pps simple-utils.ppx_let_generalized) + ) + (flags (:standard -open Simple_utils )) +) diff --git a/parser/parser.ml b/parser/parser.ml new file mode 100644 index 000000000..854029d33 --- /dev/null +++ b/parser/parser.ml @@ -0,0 +1,116 @@ +open Trace + +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 = + let prefix = Filename.(source |> basename |> remove_extension) + and suffix = ".pp.ligo" + in prefix ^ suffix in + + let cpp_cmd = Printf.sprintf "cpp -traditional-cpp %s > %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 + ) + | exn -> + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + let str = Format.sprintf + "Unrecognized error (%s) at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n" + (Printexc.to_string exn) + (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 + ) + | exn -> + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + let str = Format.sprintf + "Unrecognized error (%s) at \"%s\" from (%d, %d) to (%d, %d). In expression \"%s|%s\"\n" + (Printexc.to_string exn) + (Lexing.lexeme lexbuf) + start.pos_lnum (start.pos_cnum - start.pos_bol) + end_.pos_lnum (end_.pos_cnum - end_.pos_bol) + start.pos_fname s + in + simple_error str + ) @@ (fun () -> + let raw = Parser.interactive_expr read lexbuf in + close () ; + raw + ) >>? fun raw -> + ok raw diff --git a/parser/pascaligo/.Lexer.ml.tag b/parser/pascaligo/.Lexer.ml.tag new file mode 100644 index 000000000..051eeceb0 --- /dev/null +++ b/parser/pascaligo/.Lexer.ml.tag @@ -0,0 +1 @@ +ocamlc: -w -42 diff --git a/parser/pascaligo/.LexerMain.tag b/parser/pascaligo/.LexerMain.tag new file mode 100644 index 000000000..e69de29bb diff --git a/parser/pascaligo/.Parser.mly.tag b/parser/pascaligo/.Parser.mly.tag new file mode 100644 index 000000000..100f7bb69 --- /dev/null +++ b/parser/pascaligo/.Parser.mly.tag @@ -0,0 +1 @@ +--explain --external-tokens LexToken --base Parser ParToken.mly diff --git a/parser/pascaligo/.ParserMain.tag b/parser/pascaligo/.ParserMain.tag new file mode 100644 index 000000000..e69de29bb diff --git a/parser/pascaligo/.gitignore b/parser/pascaligo/.gitignore new file mode 100644 index 000000000..5bb749771 --- /dev/null +++ b/parser/pascaligo/.gitignore @@ -0,0 +1,12 @@ +_build/* +*/_build +*~ +.merlin +*/.merlin +*.install +/Version.ml +/dune-project +/Parser.mli +/Parser.ml +/Lexer.ml +/LexToken.ml diff --git a/parser/pascaligo/.gitlab-ci.yml b/parser/pascaligo/.gitlab-ci.yml new file mode 100644 index 000000000..5c8b0d9af --- /dev/null +++ b/parser/pascaligo/.gitlab-ci.yml @@ -0,0 +1,21 @@ +before_script: + - apt-get update -qq + - apt-get -y -qq install libhidapi-dev libcap-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 + - export PATH="/usr/local/bin${PATH:+:}${PATH:-}" + - echo "$PATH" + - printf '' | opam init + - eval $(opam config env) + - opam repository add tezos-opam-repository https://gitlab.com/gabriel.alfour/tezos-opam-repository.git + - eval $(opam config env) + - opam --version + - printf '' | ocaml + +default-job: + script: + - opam install -y --working-dir . + artifacts: + paths: + - Parser.exe diff --git a/parser/pascaligo/.links b/parser/pascaligo/.links new file mode 100644 index 000000000..34a1424ad --- /dev/null +++ b/parser/pascaligo/.links @@ -0,0 +1,7 @@ +$HOME/git/OCaml-build/Makefile +$HOME/git/OCaml-build/Makefile.cfg +$HOME/git/tezos/src/lib_utils/pos.mli +$HOME/git/tezos/src/lib_utils/pos.ml +$HOME/git/tezos/src/lib_utils/region.mli +$HOME/git/tezos/src/lib_utils/region.ml +Stubs/Tezos_utils.ml diff --git a/parser/pascaligo/AST.ml b/parser/pascaligo/AST.ml new file mode 100644 index 000000000..0cd633ddf --- /dev/null +++ b/parser/pascaligo/AST.ml @@ -0,0 +1,805 @@ +(* Abstract Syntax Tree (AST) for LIGO *) + +(* To disable warning about multiply-defined record labels. *) + +[@@@warning "-30-42"] + +(* Utilities *) + +open Utils + +(* Regions + + The AST carries all the regions where tokens have been found by the + lexer, plus additional regions corresponding to whole subtrees + (like entire expressions, patterns etc.). These regions are needed + for error reporting and source-to-source transformations. To make + these pervasive regions more legible, we define singleton types for + the symbols, keywords etc. with suggestive names like "kwd_and" + denoting the _region_ of the occurrence of the keyword "and". +*) + +type 'a reg = 'a Region.reg + +let rec last to_region = function + [] -> Region.ghost +| [x] -> to_region x +| _::t -> last to_region t + +let nseq_to_region to_region (hd,tl) = + Region.cover (to_region hd) (last to_region tl) + +let nsepseq_to_region to_region (hd,tl) = + let reg (_, item) = to_region item in + Region.cover (to_region hd) (last reg tl) + +let sepseq_to_region to_region = function + None -> Region.ghost +| Some seq -> nsepseq_to_region to_region seq + +(* Keywords of LIGO *) + +type keyword = Region.t +type kwd_and = Region.t +type kwd_begin = Region.t +type kwd_block = Region.t +type kwd_case = Region.t +type kwd_const = Region.t +type kwd_contains = Region.t +type kwd_down = Region.t +type kwd_else = Region.t +type kwd_end = Region.t +type kwd_entrypoint = Region.t +type kwd_fail = Region.t +type kwd_for = Region.t +type kwd_from = Region.t +type kwd_function = Region.t +type kwd_if = Region.t +type kwd_in = Region.t +type kwd_is = Region.t +type kwd_list = Region.t +type kwd_map = Region.t +type kwd_mod = Region.t +type kwd_nil = Region.t +type kwd_not = Region.t +type kwd_of = Region.t +type kwd_or = Region.t +type kwd_patch = Region.t +type kwd_procedure = Region.t +type kwd_record = Region.t +type kwd_remove = Region.t +type kwd_set = Region.t +type kwd_skip = Region.t +type kwd_step = Region.t +type kwd_storage = Region.t +type kwd_then = Region.t +type kwd_to = Region.t +type kwd_type = Region.t +type kwd_var = Region.t +type kwd_while = Region.t +type kwd_with = Region.t + +(* Data constructors *) + +type c_False = Region.t +type c_None = Region.t +type c_Some = Region.t +type c_True = Region.t +type c_Unit = Region.t + +(* Symbols *) + +type semi = Region.t +type comma = Region.t +type lpar = Region.t +type rpar = Region.t +type lbrace = Region.t +type rbrace = Region.t +type lbracket = Region.t +type rbracket = Region.t +type cons = Region.t +type vbar = Region.t +type arrow = Region.t +type assign = Region.t +type equal = Region.t +type colon = Region.t +type lt = Region.t +type leq = Region.t +type gt = Region.t +type geq = Region.t +type neq = Region.t +type plus = Region.t +type minus = Region.t +type slash = Region.t +type times = Region.t +type dot = Region.t +type wild = Region.t +type cat = Region.t + +(* Virtual tokens *) + +type eof = Region.t + +(* Literals *) + +type variable = string reg +type fun_name = string reg +type type_name = string reg +type field_name = string reg +type map_name = string reg +type set_name = string reg +type constr = string reg + +(* Parentheses *) + +type 'a par = { + lpar : lpar; + inside : 'a; + rpar : rpar +} + +(* Brackets compounds *) + +type 'a brackets = { + lbracket : lbracket; + inside : 'a; + rbracket : rbracket +} + +(* Braced compounds *) + +type 'a braces = { + lbrace : lbrace; + inside : 'a; + rbrace : rbrace +} + +(* The Abstract Syntax Tree *) + +type t = { + decl : declaration nseq; + eof : eof +} + +and ast = t + +and declaration = + TypeDecl of type_decl reg +| ConstDecl of const_decl reg +| LambdaDecl of lambda_decl + +and const_decl = { + kwd_const : kwd_const; + name : variable; + colon : colon; + const_type : type_expr; + equal : equal; + init : expr; + terminator : semi option +} + +(* Type declarations *) + +and type_decl = { + kwd_type : kwd_type; + name : type_name; + kwd_is : kwd_is; + type_expr : type_expr; + terminator : semi option +} + +and type_expr = + TProd of cartesian +| TSum of (variant reg, vbar) nsepseq reg +| TRecord of record_type +| TApp of (type_name * type_tuple) reg +| TFun of (type_expr * arrow * type_expr) reg +| TPar of type_expr par reg +| TAlias of variable + +and cartesian = (type_expr, times) nsepseq reg + +and variant = { + constr : constr; + kwd_of : kwd_of; + product : cartesian +} + +and record_type = field_decl reg injection reg + +and field_decl = { + field_name : field_name; + colon : colon; + field_type : type_expr +} + +and type_tuple = (type_expr, comma) nsepseq par reg + +(* Function and procedure declarations *) + +and lambda_decl = + FunDecl of fun_decl reg +| ProcDecl of proc_decl reg +| EntryDecl of entry_decl reg + +and fun_decl = { + kwd_function : kwd_function; + name : variable; + param : parameters; + colon : colon; + ret_type : type_expr; + kwd_is : kwd_is; + local_decls : local_decl list; + block : block reg; + kwd_with : kwd_with; + return : expr; + terminator : semi option +} + +and proc_decl = { + kwd_procedure : kwd_procedure; + name : variable; + param : parameters; + kwd_is : kwd_is; + local_decls : local_decl list; + block : block reg; + terminator : semi option +} + +and entry_decl = { + kwd_entrypoint : kwd_entrypoint; + name : variable; + param : entry_params; + colon : colon; + ret_type : type_expr; + kwd_is : kwd_is; + local_decls : local_decl list; + block : block reg; + kwd_with : kwd_with; + return : expr; + terminator : semi option +} + +and parameters = (param_decl, semi) nsepseq par reg + +and entry_params = (entry_param_decl, semi) nsepseq par reg + +and entry_param_decl = + EntryConst of param_const reg +| EntryVar of param_var reg +| EntryStore of storage reg + +and storage = { + kwd_storage : kwd_storage; + var : variable; + colon : colon; + storage_type : type_expr +} + +and param_decl = + ParamConst of param_const reg +| ParamVar of param_var reg + +and param_const = { + kwd_const : kwd_const; + var : variable; + colon : colon; + param_type : type_expr +} + +and param_var = { + kwd_var : kwd_var; + var : variable; + colon : colon; + param_type : type_expr +} + +and block = { + opening : block_opening; + statements : statements; + terminator : semi option; + closing : block_closing +} + +and block_opening = + Block of kwd_block * lbrace +| Begin of kwd_begin + +and block_closing = + Block of rbrace +| End of kwd_end + +and statements = (statement, semi) nsepseq + +and statement = + Instr of instruction +| Data of data_decl + +and local_decl = + LocalLam of lambda_decl +| LocalData of data_decl + +and data_decl = + LocalConst of const_decl reg +| LocalVar of var_decl reg + +and var_decl = { + kwd_var : kwd_var; + name : variable; + colon : colon; + var_type : type_expr; + assign : assign; + init : expr; + terminator : semi option +} + +and instruction = + Single of single_instr +| Block of block reg + +and single_instr = + Cond of conditional reg +| CaseInstr of instruction case reg +| Assign of assignment reg +| Loop of loop +| ProcCall of fun_call +| Fail of fail_instr reg +| Skip of kwd_skip +| RecordPatch of record_patch reg +| MapPatch of map_patch reg +| SetPatch of set_patch reg +| MapRemove of map_remove reg +| SetRemove of set_remove reg + +and set_remove = { + kwd_remove : kwd_remove; + element : expr; + kwd_from : kwd_from; + kwd_set : kwd_set; + set : path +} + +and map_remove = { + kwd_remove : kwd_remove; + key : expr; + kwd_from : kwd_from; + kwd_map : kwd_map; + map : path +} + +and set_patch = { + kwd_patch : kwd_patch; + path : path; + kwd_with : kwd_with; + set_inj : expr injection reg +} + +and map_patch = { + kwd_patch : kwd_patch; + path : path; + kwd_with : kwd_with; + map_inj : binding reg injection reg +} + +and binding = { + source : expr; + arrow : arrow; + image : expr +} + +and record_patch = { + kwd_patch : kwd_patch; + path : path; + kwd_with : kwd_with; + record_inj : record_expr +} + +and fail_instr = { + kwd_fail : kwd_fail; + fail_expr : expr +} + +and conditional = { + kwd_if : kwd_if; + test : expr; + kwd_then : kwd_then; + ifso : if_clause; + terminator : semi option; + kwd_else : kwd_else; + ifnot : if_clause +} + +and if_clause = + ClauseInstr of instruction +| ClauseBlock of (statements * semi option) braces reg + +and set_membership = { + set : expr; + kwd_contains : kwd_contains; + element : expr +} + +and 'a case = { + kwd_case : kwd_case; + expr : expr; + opening : opening; + lead_vbar : vbar option; + cases : ('a case_clause reg, vbar) nsepseq reg; + closing : closing +} + +and 'a case_clause = { + pattern : pattern; + arrow : arrow; + rhs : 'a +} + +and assignment = { + lhs : lhs; + assign : assign; + rhs : rhs +} + +and lhs = + Path of path +| MapPath of map_lookup reg + +and rhs = + Expr of expr +| NoneExpr of c_None + +and loop = + While of while_loop reg +| For of for_loop + +and while_loop = { + kwd_while : kwd_while; + cond : expr; + block : block reg +} + +and for_loop = + ForInt of for_int reg +| ForCollect of for_collect reg + +and for_int = { + kwd_for : kwd_for; + assign : var_assign reg; + down : kwd_down option; + kwd_to : kwd_to; + bound : expr; + step : (kwd_step * expr) option; + block : block reg +} + +and var_assign = { + name : variable; + assign : assign; + expr : expr +} + +and for_collect = { + kwd_for : kwd_for; + var : variable; + bind_to : (arrow * variable) option; + kwd_in : kwd_in; + expr : expr; + block : block reg +} + +(* Expressions *) + +and expr = +| ECase of expr case reg +| EAnnot of annot_expr reg +| ELogic of logic_expr +| EArith of arith_expr +| EString of string_expr +| EList of list_expr +| ESet of set_expr +| EConstr of constr_expr +| ERecord of record_expr +| EProj of projection reg +| EMap of map_expr +| EVar of Lexer.lexeme reg +| ECall of fun_call +| EBytes of (Lexer.lexeme * Hex.t) reg +| EUnit of c_Unit +| ETuple of tuple_expr +| EPar of expr par reg + +and annot_expr = (expr * type_expr) + +and set_expr = + SetInj of expr injection reg +| SetMem of set_membership reg + +and 'a injection = { + opening : opening; + elements : ('a, semi) sepseq; + terminator : semi option; + closing : closing +} + +and opening = + Kwd of keyword +| KwdBracket of keyword * lbracket + +and closing = + End of kwd_end +| RBracket of rbracket + +and map_expr = + MapLookUp of map_lookup reg +| MapInj of binding reg injection reg + +and map_lookup = { + path : path; + index : expr brackets reg +} + +and path = + Name of variable +| Path of projection reg + +and logic_expr = + BoolExpr of bool_expr +| CompExpr of comp_expr + +and bool_expr = + Or of kwd_or bin_op reg +| And of kwd_and bin_op reg +| Not of kwd_not un_op reg +| False of c_False +| True of c_True + +and 'a bin_op = { + op : 'a; + arg1 : expr; + arg2 : expr +} + +and 'a un_op = { + op : 'a; + arg : expr +} + +and comp_expr = + Lt of lt bin_op reg +| Leq of leq bin_op reg +| Gt of gt bin_op reg +| Geq of geq bin_op reg +| Equal of equal bin_op reg +| Neq of neq bin_op reg + +and arith_expr = + Add of plus bin_op reg +| Sub of minus bin_op reg +| Mult of times bin_op reg +| Div of slash bin_op reg +| Mod of kwd_mod bin_op reg +| Neg of minus un_op reg +| Int of (Lexer.lexeme * Z.t) reg +| Nat of (Lexer.lexeme * Z.t) reg +| Mtz of (Lexer.lexeme * Z.t) reg + +and string_expr = + Cat of cat bin_op reg +| String of Lexer.lexeme reg + +and list_expr = + Cons of cons bin_op reg +| List of expr injection reg +| Nil of nil + +and nil = kwd_nil + +and constr_expr = + SomeApp of (c_Some * arguments) reg +| NoneExpr of none_expr +| ConstrApp of (constr * arguments) reg + +and record_expr = field_assign reg injection reg + +and field_assign = { + field_name : field_name; + equal : equal; + field_expr : expr +} + +and projection = { + struct_name : variable; + selector : dot; + field_path : (selection, dot) nsepseq +} + +and selection = + FieldName of field_name +| Component of (Lexer.lexeme * Z.t) reg + +and tuple_expr = + TupleInj of tuple_injection + +and tuple_injection = (expr, comma) nsepseq par reg + +and none_expr = c_None + +and fun_call = (fun_name * arguments) reg + +and arguments = tuple_injection + +(* Patterns *) + +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 +| PBytes of (Lexer.lexeme * Hex.t) reg +| PString of Lexer.lexeme reg +| PUnit of c_Unit +| PFalse of c_False +| PTrue of c_True +| PNone of c_None +| PSome of (c_Some * pattern par reg) reg +| PList of list_pattern +| PTuple of (pattern, comma) nsepseq par reg + +and list_pattern = + Sugar of pattern injection reg +| PNil of kwd_nil +| Raw of (pattern * cons * pattern) par reg + +(* Projecting regions *) + +open! Region + +let type_expr_to_region = function + TProd {region; _} +| TSum {region; _} +| TRecord {region; _} +| TApp {region; _} +| TFun {region; _} +| TPar {region; _} +| TAlias {region; _} -> region + +let rec expr_to_region = function +| ELogic e -> logic_expr_to_region e +| EArith e -> arith_expr_to_region e +| EString e -> string_expr_to_region e +| EAnnot e -> annot_expr_to_region e +| EList e -> list_expr_to_region e +| ESet e -> set_expr_to_region e +| EConstr e -> constr_expr_to_region e +| ERecord e -> record_expr_to_region e +| EMap e -> map_expr_to_region e +| ETuple e -> tuple_expr_to_region e +| EProj {region; _} +| EVar {region; _} +| ECall {region; _} +| EBytes {region; _} +| EUnit region +| ECase {region;_} +| EPar {region; _} -> region + +and tuple_expr_to_region = function + TupleInj {region; _} -> region + +and map_expr_to_region = function + MapLookUp {region; _} +| MapInj {region; _} -> region + +and set_expr_to_region = function + SetInj {region; _} +| SetMem {region; _} -> region + +and logic_expr_to_region = function + BoolExpr e -> bool_expr_to_region e +| CompExpr e -> comp_expr_to_region e + +and bool_expr_to_region = function + Or {region; _} +| And {region; _} +| Not {region; _} +| False region +| True region -> region + +and comp_expr_to_region = function + Lt {region; _} +| Leq {region; _} +| Gt {region; _} +| Geq {region; _} +| Equal {region; _} +| Neq {region; _} -> region + +and arith_expr_to_region = function +| Add {region; _} +| Sub {region; _} +| Mult {region; _} +| Div {region; _} +| Mod {region; _} +| Neg {region; _} +| Int {region; _} +| Nat {region; _} +| Mtz {region; _} -> region + +and string_expr_to_region = function + Cat {region; _} +| String {region; _} -> region + +and annot_expr_to_region ({region; _}) = region + +and list_expr_to_region = function + Cons {region; _} +| List {region; _} +| Nil region -> region + +and constr_expr_to_region = function + NoneExpr region +| ConstrApp {region; _} +| SomeApp {region; _} -> region + +and record_expr_to_region {region; _} = region + +let path_to_region = function + Name var -> var.region +| Path {region; _} -> region + +let instr_to_region = function + Single Cond {region; _} +| Single CaseInstr {region; _} +| Single Assign {region; _} +| Single Loop While {region; _} +| Single Loop For ForInt {region; _} +| Single Loop For ForCollect {region; _} +| Single ProcCall {region; _} +| Single Skip region +| Single Fail {region; _} +| Single RecordPatch {region; _} +| Single MapPatch {region; _} +| Single SetPatch {region; _} +| Single MapRemove {region; _} +| Single SetRemove {region; _} +| Block {region; _} -> region + +let if_clause_to_region = function + ClauseInstr instr -> instr_to_region instr +| ClauseBlock {region; _} -> region + +let pattern_to_region = function + PCons {region; _} +| PVar {region; _} +| PWild region +| PInt {region; _} +| PBytes {region; _} +| PString {region; _} +| PUnit region +| PFalse region +| PTrue region +| PNone region +| PSome {region; _} +| PList Sugar {region; _} +| PList PNil region +| PList Raw {region; _} +| PConstr {region; _} +| PTuple {region; _} -> region + +let local_decl_to_region = function + LocalLam FunDecl {region; _} +| LocalLam ProcDecl {region; _} +| LocalLam EntryDecl {region; _} +| LocalData LocalConst {region; _} +| LocalData LocalVar {region; _} -> region + +let lhs_to_region : lhs -> Region.t = function + Path path -> path_to_region path +| MapPath {region; _} -> region + +let rhs_to_region = function + Expr e -> expr_to_region e +| NoneExpr r -> r + +let selection_to_region = function + FieldName {region; _} +| Component {region; _} -> region diff --git a/parser/pascaligo/AST.mli b/parser/pascaligo/AST.mli new file mode 100644 index 000000000..5a8df626e --- /dev/null +++ b/parser/pascaligo/AST.mli @@ -0,0 +1,649 @@ +(* Abstract Syntax Tree (AST) for LIGO *) + +[@@@warning "-30"] + +open Utils + +(* Regions + + The AST carries all the regions where tokens have been found by the + lexer, plus additional regions corresponding to whole subtrees + (like entire expressions, patterns etc.). These regions are needed + for error reporting and source-to-source transformations. To make + these pervasive regions more legible, we define singleton types for + the symbols, keywords etc. with suggestive names like "kwd_and" + denoting the _region_ of the occurrence of the keyword "and". +*) + +type 'a reg = 'a Region.reg + +val nseq_to_region : ('a -> Region.t) -> 'a nseq -> Region.t +val nsepseq_to_region : ('a -> Region.t) -> ('a,'sep) nsepseq -> Region.t +val sepseq_to_region : ('a -> Region.t) -> ('a,'sep) sepseq -> Region.t + +(* Keywords of LIGO *) + +type keyword = Region.t +type kwd_and = Region.t +type kwd_begin = Region.t +type kwd_block = Region.t +type kwd_case = Region.t +type kwd_const = Region.t +type kwd_contains = Region.t +type kwd_down = Region.t +type kwd_else = Region.t +type kwd_end = Region.t +type kwd_entrypoint = Region.t +type kwd_fail = Region.t +type kwd_for = Region.t +type kwd_from = Region.t +type kwd_function = Region.t +type kwd_if = Region.t +type kwd_in = Region.t +type kwd_is = Region.t +type kwd_list = Region.t +type kwd_map = Region.t +type kwd_mod = Region.t +type kwd_nil = Region.t +type kwd_not = Region.t +type kwd_of = Region.t +type kwd_or = Region.t +type kwd_patch = Region.t +type kwd_procedure = Region.t +type kwd_record = Region.t +type kwd_remove = Region.t +type kwd_set = Region.t +type kwd_skip = Region.t +type kwd_step = Region.t +type kwd_storage = Region.t +type kwd_then = Region.t +type kwd_to = Region.t +type kwd_type = Region.t +type kwd_var = Region.t +type kwd_while = Region.t +type kwd_with = Region.t + +(* Data constructors *) + +type c_False = Region.t +type c_None = Region.t +type c_Some = Region.t +type c_True = Region.t +type c_Unit = Region.t + +(* Symbols *) + +type semi = Region.t (* ";" *) +type comma = Region.t (* "," *) +type lpar = Region.t (* "(" *) +type rpar = Region.t (* ")" *) +type lbrace = Region.t (* "{" *) +type rbrace = Region.t (* "}" *) +type lbracket = Region.t (* "[" *) +type rbracket = Region.t (* "]" *) +type cons = Region.t (* "#" *) +type vbar = Region.t (* "|" *) +type arrow = Region.t (* "->" *) +type assign = Region.t (* ":=" *) +type equal = Region.t (* "=" *) +type colon = Region.t (* ":" *) +type lt = Region.t (* "<" *) +type leq = Region.t (* "<=" *) +type gt = Region.t (* ">" *) +type geq = Region.t (* ">=" *) +type neq = Region.t (* "=/=" *) +type plus = Region.t (* "+" *) +type minus = Region.t (* "-" *) +type slash = Region.t (* "/" *) +type times = Region.t (* "*" *) +type dot = Region.t (* "." *) +type wild = Region.t (* "_" *) +type cat = Region.t (* "^" *) + +(* Virtual tokens *) + +type eof = Region.t + +(* Literals *) + +type variable = string reg +type fun_name = string reg +type type_name = string reg +type field_name = string reg +type map_name = string reg +type set_name = string reg +type constr = string reg + +(* Parentheses *) + +type 'a par = { + lpar : lpar; + inside : 'a; + rpar : rpar +} + +(* Brackets compounds *) + +type 'a brackets = { + lbracket : lbracket; + inside : 'a; + rbracket : rbracket +} + +(* Braced compounds *) + +type 'a braces = { + lbrace : lbrace; + inside : 'a; + rbrace : rbrace +} + +(* The Abstract Syntax Tree *) + +type t = { + decl : declaration nseq; + eof : eof +} + +and ast = t + +and declaration = + TypeDecl of type_decl reg +| ConstDecl of const_decl reg +| LambdaDecl of lambda_decl + +and const_decl = { + kwd_const : kwd_const; + name : variable; + colon : colon; + const_type : type_expr; + equal : equal; + init : expr; + terminator : semi option +} + +(* Type declarations *) + +and type_decl = { + kwd_type : kwd_type; + name : type_name; + kwd_is : kwd_is; + type_expr : type_expr; + terminator : semi option +} + +and type_expr = + TProd of cartesian +| TSum of (variant reg, vbar) nsepseq reg +| TRecord of record_type +| TApp of (type_name * type_tuple) reg +| TFun of (type_expr * arrow * type_expr) reg +| TPar of type_expr par reg +| TAlias of variable + +and cartesian = (type_expr, times) nsepseq reg + +and variant = { + constr : constr; + kwd_of : kwd_of; + product : cartesian +} + +and record_type = field_decl reg injection reg + +and field_decl = { + field_name : field_name; + colon : colon; + field_type : type_expr +} + +and type_tuple = (type_expr, comma) nsepseq par reg + +(* Function and procedure declarations *) + +and lambda_decl = + FunDecl of fun_decl reg +| ProcDecl of proc_decl reg +| EntryDecl of entry_decl reg + +and fun_decl = { + kwd_function : kwd_function; + name : variable; + param : parameters; + colon : colon; + ret_type : type_expr; + kwd_is : kwd_is; + local_decls : local_decl list; + block : block reg; + kwd_with : kwd_with; + return : expr; + terminator : semi option +} + +and proc_decl = { + kwd_procedure : kwd_procedure; + name : variable; + param : parameters; + kwd_is : kwd_is; + local_decls : local_decl list; + block : block reg; + terminator : semi option +} + +and entry_decl = { + kwd_entrypoint : kwd_entrypoint; + name : variable; + param : entry_params; + colon : colon; + ret_type : type_expr; + kwd_is : kwd_is; + local_decls : local_decl list; + block : block reg; + kwd_with : kwd_with; + return : expr; + terminator : semi option +} + +and parameters = (param_decl, semi) nsepseq par reg + +and entry_params = (entry_param_decl, semi) nsepseq par reg + +and entry_param_decl = + EntryConst of param_const reg +| EntryVar of param_var reg +| EntryStore of storage reg + +and storage = { + kwd_storage : kwd_storage; + var : variable; + colon : colon; + storage_type : type_expr +} + +and param_decl = + ParamConst of param_const reg +| ParamVar of param_var reg + +and param_const = { + kwd_const : kwd_const; + var : variable; + colon : colon; + param_type : type_expr +} + +and param_var = { + kwd_var : kwd_var; + var : variable; + colon : colon; + param_type : type_expr +} + +and block = { + opening : block_opening; + statements : statements; + terminator : semi option; + closing : block_closing +} + +and block_opening = + Block of kwd_block * lbrace +| Begin of kwd_begin + +and block_closing = + Block of rbrace +| End of kwd_end + +and statements = (statement, semi) nsepseq + +and statement = + Instr of instruction +| Data of data_decl + +and local_decl = + LocalLam of lambda_decl +| LocalData of data_decl + +and data_decl = + LocalConst of const_decl reg +| LocalVar of var_decl reg + +and var_decl = { + kwd_var : kwd_var; + name : variable; + colon : colon; + var_type : type_expr; + assign : assign; + init : expr; + terminator : semi option +} + +and instruction = + Single of single_instr +| Block of block reg + +and single_instr = + Cond of conditional reg +| CaseInstr of instruction case reg +| Assign of assignment reg +| Loop of loop +| ProcCall of fun_call +| Fail of fail_instr reg +| Skip of kwd_skip +| RecordPatch of record_patch reg +| MapPatch of map_patch reg +| SetPatch of set_patch reg +| MapRemove of map_remove reg +| SetRemove of set_remove reg + +and set_remove = { + kwd_remove : kwd_remove; + element : expr; + kwd_from : kwd_from; + kwd_set : kwd_set; + set : path +} + +and map_remove = { + kwd_remove : kwd_remove; + key : expr; + kwd_from : kwd_from; + kwd_map : kwd_map; + map : path +} + +and set_patch = { + kwd_patch : kwd_patch; + path : path; + kwd_with : kwd_with; + set_inj : expr injection reg +} + +and map_patch = { + kwd_patch : kwd_patch; + path : path; + kwd_with : kwd_with; + map_inj : binding reg injection reg +} + +and binding = { + source : expr; + arrow : arrow; + image : expr +} + +and record_patch = { + kwd_patch : kwd_patch; + path : path; + kwd_with : kwd_with; + record_inj : field_assign reg injection reg +} + +and fail_instr = { + kwd_fail : kwd_fail; + fail_expr : expr +} + +and conditional = { + kwd_if : kwd_if; + test : expr; + kwd_then : kwd_then; + ifso : if_clause; + terminator : semi option; + kwd_else : kwd_else; + ifnot : if_clause +} + +and if_clause = + ClauseInstr of instruction +| ClauseBlock of (statements * semi option) braces reg + +and set_membership = { + set : expr; + kwd_contains : kwd_contains; + element : expr +} + +and 'a case = { + kwd_case : kwd_case; + expr : expr; + opening : opening; + lead_vbar : vbar option; + cases : ('a case_clause reg, vbar) nsepseq reg; + closing : closing +} + +and 'a case_clause = { + pattern : pattern; + arrow : arrow; + rhs : 'a +} + +and assignment = { + lhs : lhs; + assign : assign; + rhs : rhs; +} + +and lhs = + Path of path +| MapPath of map_lookup reg + +and rhs = + Expr of expr +| NoneExpr of c_None + +and loop = + While of while_loop reg +| For of for_loop + +and while_loop = { + kwd_while : kwd_while; + cond : expr; + block : block reg +} + +and for_loop = + ForInt of for_int reg +| ForCollect of for_collect reg + +and for_int = { + kwd_for : kwd_for; + assign : var_assign reg; + down : kwd_down option; + kwd_to : kwd_to; + bound : expr; + step : (kwd_step * expr) option; + block : block reg +} + +and var_assign = { + name : variable; + assign : assign; + expr : expr +} + +and for_collect = { + kwd_for : kwd_for; + var : variable; + bind_to : (arrow * variable) option; + kwd_in : kwd_in; + expr : expr; + block : block reg +} + +(* Expressions *) + +and expr = +| ECase of expr case reg +| EAnnot of annot_expr reg +| ELogic of logic_expr +| EArith of arith_expr +| EString of string_expr +| EList of list_expr +| ESet of set_expr +| EConstr of constr_expr +| ERecord of record_expr +| EProj of projection reg +| EMap of map_expr +| EVar of Lexer.lexeme reg +| ECall of fun_call +| EBytes of (Lexer.lexeme * Hex.t) reg +| EUnit of c_Unit +| ETuple of tuple_expr +| EPar of expr par reg + +and annot_expr = (expr * type_expr) + +and set_expr = + SetInj of expr injection reg +| SetMem of set_membership reg + +and 'a injection = { + opening : opening; + elements : ('a, semi) sepseq; + terminator : semi option; + closing : closing +} + +and opening = + Kwd of keyword +| KwdBracket of keyword * lbracket + +and closing = + End of kwd_end +| RBracket of rbracket + +and map_expr = + MapLookUp of map_lookup reg +| MapInj of binding reg injection reg + +and map_lookup = { + path : path; + index : expr brackets reg +} + +and path = + Name of variable +| Path of projection reg + +and logic_expr = + BoolExpr of bool_expr +| CompExpr of comp_expr + +and bool_expr = + Or of kwd_or bin_op reg +| And of kwd_and bin_op reg +| Not of kwd_not un_op reg +| False of c_False +| True of c_True + +and 'a bin_op = { + op : 'a; + arg1 : expr; + arg2 : expr +} + +and 'a un_op = { + op : 'a; + arg : expr +} + +and comp_expr = + Lt of lt bin_op reg +| Leq of leq bin_op reg +| Gt of gt bin_op reg +| Geq of geq bin_op reg +| Equal of equal bin_op reg +| Neq of neq bin_op reg + +and arith_expr = + Add of plus bin_op reg +| Sub of minus bin_op reg +| Mult of times bin_op reg +| Div of slash bin_op reg +| Mod of kwd_mod bin_op reg +| Neg of minus un_op reg +| Int of (Lexer.lexeme * Z.t) reg +| Nat of (Lexer.lexeme * Z.t) reg +| Mtz of (Lexer.lexeme * Z.t) reg + +and string_expr = + Cat of cat bin_op reg +| String of Lexer.lexeme reg + +and list_expr = + Cons of cons bin_op reg +| List of expr injection reg +| Nil of nil + +and nil = kwd_nil + +and constr_expr = + SomeApp of (c_Some * arguments) reg +| NoneExpr of none_expr +| ConstrApp of (constr * arguments) reg + +and record_expr = field_assign reg injection reg + +and field_assign = { + field_name : field_name; + equal : equal; + field_expr : expr +} + +and projection = { + struct_name : variable; + selector : dot; + field_path : (selection, dot) nsepseq +} + +and selection = + FieldName of field_name +| Component of (Lexer.lexeme * Z.t) reg + +and tuple_expr = + TupleInj of tuple_injection + +and tuple_injection = (expr, comma) nsepseq par reg + +and none_expr = c_None + +and fun_call = (fun_name * arguments) reg + +and arguments = tuple_injection + +(* Patterns *) + +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 +| PBytes of (Lexer.lexeme * Hex.t) reg +| PString of Lexer.lexeme reg +| PUnit of c_Unit +| PFalse of c_False +| PTrue of c_True +| PNone of c_None +| PSome of (c_Some * pattern par reg) reg +| PList of list_pattern +| PTuple of (pattern, comma) nsepseq par reg + +and list_pattern = + Sugar of pattern injection reg +| PNil of kwd_nil +| Raw of (pattern * cons * pattern) par reg + +(* Projecting regions *) + +val type_expr_to_region : type_expr -> Region.t +val expr_to_region : expr -> Region.t +val instr_to_region : instruction -> Region.t +val pattern_to_region : pattern -> Region.t +val local_decl_to_region : local_decl -> Region.t +val path_to_region : path -> Region.t +val lhs_to_region : lhs -> Region.t +val rhs_to_region : rhs -> Region.t +val if_clause_to_region : if_clause -> Region.t +val selection_to_region : selection -> Region.t diff --git a/parser/pascaligo/Error.mli b/parser/pascaligo/Error.mli new file mode 100644 index 000000000..19c1ce4c9 --- /dev/null +++ b/parser/pascaligo/Error.mli @@ -0,0 +1,3 @@ +type t = .. + +type error = t diff --git a/parser/pascaligo/EvalOpt.ml b/parser/pascaligo/EvalOpt.ml new file mode 100644 index 000000000..20d039603 --- /dev/null +++ b/parser/pascaligo/EvalOpt.ml @@ -0,0 +1,161 @@ +(* Parsing the command-line option for testing the LIGO lexer and + parser *) + +let printf = Printf.printf +let sprintf = Printf.sprintf + +let abort msg = + Utils.highlight (sprintf "Command-line error: %s\n" msg); exit 1 + +(* Help *) + +let help () = + let file = Filename.basename Sys.argv.(0) in + printf "Usage: %s [