diff --git a/src/ligo/.old.transpiler.ml b/src/ligo/.old.transpiler.ml deleted file mode 100644 index 8beb2b30f..000000000 --- a/src/ligo/.old.transpiler.ml +++ /dev/null @@ -1,196 +0,0 @@ -open Mini_c -module AST = Ligo_parser.Typed.O -module SMap = Ligo_parser.Typed.SMap - -module Rename = struct - open! AST - - let rec rename_expr_case (src:string) (dst:string) : expr_case -> expr_case = function - | App {operator;arguments} -> App {operator = rename_operator src dst operator ; arguments = rename_exprs src dst arguments} - | Var n when n.name.name = src -> Var {n with name = {n.name with name = dst}} - | Var n -> Var n - | Constant c -> Constant c - | Record r -> Record (List.map (fun (key, expr) -> key, rename_expr src dst expr) r) - | Lambda {parameter} as l when parameter.name.name = src -> l - | Lambda ({instructions;declarations} as l) -> - Lambda {l with instructions = rename_instrs src dst instructions ; declarations = rename_declarations src dst declarations} - - and rename_expr (src:string) (dst:string) (e : expr) : expr = - { e with expr = rename_expr_case src dst e.expr } - - and rename_exprs src dst exprs = List.map (rename_expr src dst) exprs - - and rename_operator_case (src:string) (dst:string) : operator_case -> operator_case = function - | Function n when n.name = src -> Function {n with name = dst} - | x -> x - - and rename_operator src dst (o:operator) : operator = {o with operator = rename_operator_case src dst o.operator} - - and rename_var src dst (v:var_name) : var_name = - if v.name = src - then {v with name = dst} - else v - - and rename_instr (src:string) (dst:string) : instr -> instr = function - | Assignment {name;value;orig} when name.name = src -> Assignment {name = {name with name = dst};value;orig} - | Assignment {name;value;orig} -> Assignment {value = rename_expr src dst value;name;orig} - | While {condition;body;orig} -> While {condition = rename_expr src dst condition;body=rename_instrs src dst body;orig} - | ForCollection {list;var;body;orig} -> ForCollection {list = rename_expr src dst list;var = rename_var src dst var; - body = rename_instrs src dst body;orig} - | Match ({expr;cases} as a) -> Match {a with expr = rename_expr src dst expr ; cases = rename_match_cases src dst cases} - | ProcedureCall {expr;orig} -> ProcedureCall {expr = rename_expr src dst expr;orig} - | Fail {expr;orig} -> Fail {expr = rename_expr src dst expr;orig} - - and rename_instrs src dst : instr list -> instr list = List.map (rename_instr src dst) - - and rename_match_cases (src:string) (dst:string) (m:(_ * instr list) list) = - List.map (fun (x, y) -> x, rename_instrs src dst y) m - - and rename_declaration (src:string) (dst:string) ({var} as d: decl) : decl = - if var.name.name = src - then {d with var = {var with name = {var.name with name = dst}}} - else d - - and rename_declarations (src:string) (dst:string) (decls:decl list) = - List.map (rename_declaration src dst) decls -end - -let list_of_map m = List.rev @@ SMap.fold (fun _ v prev -> v :: prev) m [] - -let rec translate_type : AST.type_expr -> type_value result = fun {type_expr} -> - match type_expr with - | Unit -> ok (`Base Unit) - | Int -> ok (`Base Int) - | String -> ok (`Base String) - | Bool -> ok (`Base Bool) - | Sum m -> - let node = Append_tree.of_list @@ List.map snd @@ list_of_map m in - let aux a b : type_value result = - let%bind a = a in - let%bind b = b in - ok (`Or (a, b)) - in - Append_tree.fold_ne translate_type aux node - | Record r -> - let node = Append_tree.of_list @@ List.map snd @@ list_of_map r in - let aux a b : type_value result = - let%bind a = a in - let%bind b = b in - ok (`Pair (a, b)) - in - Append_tree.fold_ne translate_type aux node - | Ref t -> translate_type t - | Function {arg;ret} -> - let%bind arg = translate_type arg in - let%bind ret = translate_type ret in - ok (`Function(arg, ret)) - | TypeApp _ -> simple_fail "No type application" - -let translate_constant : AST.constant -> value result = function - | Unit -> ok `Unit - | String s -> ok (`String s) - | Int n -> ok (`Int (Z.to_int n)) - | False -> ok (`Bool false) - | True -> ok (`Bool true) - | _ -> simple_fail "" - -let rec translate_lambda : AST.lambda -> anon_function result = - fun {declarations;parameter;instructions;result} -> - let ({name;ty}:AST.typed_var) = parameter in - let%bind input_ty = translate_type ty in - let%bind output_ty = translate_type result.ty in - let%bind result = translate_expr result in - let%bind (declaration_statements : statement list) = translate_declarations declarations in - let%bind (instruction_statements : statement list) = translate_instructions instructions in - let body = declaration_statements @ instruction_statements in - ok {content={binder=name.name;input=input_ty;output=output_ty;body;result} ; capture = No_capture} - -and translate_expr' : AST.expr_case -> expression' result = function - | Var {name} -> ok (Var name.name) - | Constant cst -> - let%bind value = translate_constant cst in - ok (Literal value) - | Lambda _ -> simple_fail "Mini_c doesn't deal with lambda in expressions yet" - | _ -> simple_fail "" - -and translate_expr env : AST.expr -> expression result = fun {expr;ty} -> - let%bind expr = translate_expr' expr in - let%bind ty = translate_type ty in - ok (expr, ty, env) - -and translate_declaration : AST.decl -> statement result = fun {var;value} -> - let%bind expr = translate_expr value in - ok (Assignment(Variable(var.name.name, expr))) - -and translate_declarations : AST.decl list -> statement list result = fun declarations -> - bind_list @@ List.map translate_declaration declarations - -and translate_match (expr:AST.expr) (cases: (AST.pattern * AST.instr list) list) : statement result = - match cases with - | [(AST.PTrue, instrs_true) ; (AST.PFalse, instrs_false) ] -> - let%bind cond = translate_expr expr in - let%bind b_true = translate_instructions instrs_true in - let%bind b_false = translate_instructions instrs_false in - ok (Cond (cond, b_true, b_false)) - | [(AST.PFalse, instrs_false) ; (AST.PTrue, instrs_true) ] -> - let%bind cond = translate_expr expr in - let%bind b_true = translate_instructions instrs_true in - let%bind b_false = translate_instructions instrs_false in - ok (Cond (cond, b_true, b_false)) - | _ -> simple_fail "unrecognized pattern" - -and translate_instruction : AST.instr -> statement result = function - | Assignment {name ; value} -> - let%bind expr = translate_expr value in - ok (Assignment (Variable(name.name, expr))) - | While {condition ; body} -> - let%bind block = translate_instructions body in - let%bind cond = translate_expr condition in - ok (While (cond, block)) - | ForCollection _ -> simple_fail "We don't deal with for collection yet" - | Match {expr;cases} -> translate_match expr cases - | Fail _ -> simple_fail "Fail have to be added in Mini_C" - | ProcedureCall _ -> simple_fail "Drop Unit have to be added in Mini_C" - -and translate_instructions : AST.instr list -> statement list result = fun instrs -> - bind_list @@ List.map translate_instruction instrs - -let translate_program : AST.ast -> block result = fun {declarations} -> - translate_declarations declarations - -let rec to_mini_c_value' : (AST.expr_case * AST.type_expr) -> value result = function - | Constant c, _ -> translate_constant c - | App {arguments;operator = {operator = Constructor c ; ty = {type_expr = Sum lst}}}, _ -> - let node = Append_tree.of_list @@ List.map fst @@ list_of_map lst in - let%bind lst = - trace_option (simple_error "Not constructor of variant type") @@ - Append_tree.exists_path (fun (x:AST.name_and_region) -> x.name = c.name) node in - let arg = List.hd arguments in - let%bind arg = to_mini_c_value arg in - let ors = List.fold_left (fun b a -> if a then `Right b else `Left b) arg (List.rev lst) in - ok ors - | App _, _ -> simple_fail "Applications aren't value" - | Record lst, _ -> - let node = Append_tree.of_list @@ List.map snd lst in - let aux a b = - let%bind a = a in - let%bind b = b in - ok (`Pair (a, b)) - in - Append_tree.fold_ne to_mini_c_value aux node - | Lambda _, _-> simple_fail "Lambda aren't value yet" - | Var _, _-> simple_fail "Var aren't value yet" - -and to_mini_c_value : AST.expr -> value result = fun {expr;ty} -> - to_mini_c_value' (expr, ty) - -let ghost expr ty : AST.expr = {expr;ty;orig=`TODO} - -let of_mini_c_value ({type_expr} as ty, v : AST.type_expr * value) : AST.expr result = match (type_expr, v) with - | String, `String s -> ok @@ ghost (Constant (String s)) ty - | Bool, `Bool b -> ok @@ ghost (Constant (if b then True else False)) ty - | Unit, `Unit -> ok @@ ghost (Constant (Unit)) ty - | Int, `Int n -> ok @@ ghost (Constant (Int (Z.of_int n))) ty - | Function _, _ -> simple_fail "Functions aren't retrieved from Mini_C yet" - | _ -> simple_fail "of_mini_c_value error" - diff --git a/src/ligo/README_INSTALL b/src/ligo/README_INSTALL deleted file mode 100644 index e5dbde280..000000000 --- a/src/ligo/README_INSTALL +++ /dev/null @@ -1,20 +0,0 @@ -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/src/ligo/TODO.txt b/src/ligo/TODO.txt deleted file mode 100644 index 210cb0637..000000000 --- a/src/ligo/TODO.txt +++ /dev/null @@ -1,21 +0,0 @@ -# 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/src/ligo/ast_simplified/PP.ml b/src/ligo/ast_simplified/PP.ml deleted file mode 100644 index 6eed2f798..000000000 --- a/src/ligo/ast_simplified/PP.ml +++ /dev/null @@ -1,119 +0,0 @@ -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/src/ligo/ast_simplified/ast_simplified.ml b/src/ligo/ast_simplified/ast_simplified.ml deleted file mode 100644 index 566e95155..000000000 --- a/src/ligo/ast_simplified/ast_simplified.ml +++ /dev/null @@ -1,8 +0,0 @@ -include Types -include Misc -include Combinators - -module Types = Types -module Misc = Misc -module PP = PP -module Combinators = Combinators diff --git a/src/ligo/ast_simplified/combinators.ml b/src/ligo/ast_simplified/combinators.ml deleted file mode 100644 index 15c76ec3e..000000000 --- a/src/ligo/ast_simplified/combinators.ml +++ /dev/null @@ -1,185 +0,0 @@ -open Types -open Trace - -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/src/ligo/ast_simplified/dune b/src/ligo/ast_simplified/dune deleted file mode 100644 index c9e2fcfed..000000000 --- a/src/ligo/ast_simplified/dune +++ /dev/null @@ -1,10 +0,0 @@ -(library - (name ast_simplified) - (public_name ligo.ast_simplified) - (libraries - tezos-utils - ) - (preprocess - (pps tezos-utils.ppx_let_generalized) - ) -) diff --git a/src/ligo/ast_simplified/misc.ml b/src/ligo/ast_simplified/misc.ml deleted file mode 100644 index 843307eed..000000000 --- a/src/ligo/ast_simplified/misc.ml +++ /dev/null @@ -1,258 +0,0 @@ -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/src/ligo/ast_simplified/types.ml b/src/ligo/ast_simplified/types.ml deleted file mode 100644 index adaf10689..000000000 --- a/src/ligo/ast_simplified/types.ml +++ /dev/null @@ -1,123 +0,0 @@ -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/src/ligo/ast_typed/PP.ml b/src/ligo/ast_typed/PP.ml deleted file mode 100644 index 35bc1101e..000000000 --- a/src/ligo/ast_typed/PP.ml +++ /dev/null @@ -1,115 +0,0 @@ -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/src/ligo/ast_typed/ast_typed.ml b/src/ligo/ast_typed/ast_typed.ml deleted file mode 100644 index f01780254..000000000 --- a/src/ligo/ast_typed/ast_typed.ml +++ /dev/null @@ -1,12 +0,0 @@ -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/src/ligo/ast_typed/combinators.ml b/src/ligo/ast_typed/combinators.ml deleted file mode 100644 index 0aa3cfcd8..000000000 --- a/src/ligo/ast_typed/combinators.ml +++ /dev/null @@ -1,213 +0,0 @@ -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/src/ligo/ast_typed/combinators_environment.ml b/src/ligo/ast_typed/combinators_environment.ml deleted file mode 100644 index e8ca37530..000000000 --- a/src/ligo/ast_typed/combinators_environment.ml +++ /dev/null @@ -1,28 +0,0 @@ -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/src/ligo/ast_typed/dune b/src/ligo/ast_typed/dune deleted file mode 100644 index 237e4114f..000000000 --- a/src/ligo/ast_typed/dune +++ /dev/null @@ -1,11 +0,0 @@ -(library - (name ast_typed) - (public_name ligo.ast_typed) - (libraries - tezos-utils - ast_simplified ; Is that a good idea? - ) - (preprocess - (pps tezos-utils.ppx_let_generalized) - ) -) diff --git a/src/ligo/ast_typed/environment.ml b/src/ligo/ast_typed/environment.ml deleted file mode 100644 index de0798c91..000000000 --- a/src/ligo/ast_typed/environment.ml +++ /dev/null @@ -1,79 +0,0 @@ -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/src/ligo/ast_typed/misc.ml b/src/ligo/ast_typed/misc.ml deleted file mode 100644 index b562be0ff..000000000 --- a/src/ligo/ast_typed/misc.ml +++ /dev/null @@ -1,417 +0,0 @@ -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/src/ligo/ast_typed/types.ml b/src/ligo/ast_typed/types.ml deleted file mode 100644 index ab6cee065..000000000 --- a/src/ligo/ast_typed/types.ml +++ /dev/null @@ -1,169 +0,0 @@ -[@@@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") @@ - Tezos_utils.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/src/ligo/bin/cli.ml b/src/ligo/bin/cli.ml deleted file mode 100644 index a37d5ffcd..000000000 --- a/src/ligo/bin/cli.ml +++ /dev/null @@ -1,107 +0,0 @@ -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/src/ligo/bin/dune b/src/ligo/bin/dune deleted file mode 100644 index 66ec132b7..000000000 --- a/src/ligo/bin/dune +++ /dev/null @@ -1,13 +0,0 @@ -(executable - (name cli) - (public_name ligo) - (libraries - tezos-utils - cmdliner - ligo - ) - (package ligo) - (preprocess - (pps tezos-utils.ppx_let_generalized) - ) -) diff --git a/src/ligo/compiler/compiler.ml b/src/ligo/compiler/compiler.ml deleted file mode 100644 index fbdd8942a..000000000 --- a/src/ligo/compiler/compiler.ml +++ /dev/null @@ -1,6 +0,0 @@ -module Uncompiler = Uncompiler -module Program = Compiler_program -module Type = Compiler_type -module Environment = Compiler_environment - -include Program diff --git a/src/ligo/compiler/compiler_environment.ml b/src/ligo/compiler/compiler_environment.ml deleted file mode 100644 index c6980ee06..000000000 --- a/src/ligo/compiler/compiler_environment.ml +++ /dev/null @@ -1,277 +0,0 @@ -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/src/ligo/compiler/compiler_program.ml b/src/ligo/compiler/compiler_program.ml deleted file mode 100644 index 585d4d314..000000000 --- a/src/ligo/compiler/compiler_program.ml +++ /dev/null @@ -1,540 +0,0 @@ -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") @@ - Tezos_utils.List.find_map is_main p - in - ok main - -let translate_program (p:program) (entry:string) : compiled_program result = - let%bind main = get_main p entry in - let {input;output} : anon_function = 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/src/ligo/compiler/compiler_type.ml b/src/ligo/compiler/compiler_type.ml deleted file mode 100644 index bfa6cd12f..000000000 --- a/src/ligo/compiler/compiler_type.ml +++ /dev/null @@ -1,173 +0,0 @@ -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/src/ligo/compiler/dune b/src/ligo/compiler/dune deleted file mode 100644 index e5cb4a5a9..000000000 --- a/src/ligo/compiler/dune +++ /dev/null @@ -1,14 +0,0 @@ -(library - (name compiler) - (public_name ligo.compiler) - (libraries - tezos-utils - meta_michelson - mini_c - operators - ) - (preprocess - (pps tezos-utils.ppx_let_generalized) - ) - (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Tezos_utils )) -) diff --git a/src/ligo/compiler/uncompiler.ml b/src/ligo/compiler/uncompiler.ml deleted file mode 100644 index 4f4b24cfb..000000000 --- a/src/ligo/compiler/uncompiler.ml +++ /dev/null @@ -1,91 +0,0 @@ -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/src/ligo/contracts/annotation.ligo b/src/ligo/contracts/annotation.ligo deleted file mode 100644 index 1cae3ffe9..000000000 --- a/src/ligo/contracts/annotation.ligo +++ /dev/null @@ -1,5 +0,0 @@ -const lst : list(int) = list [] ; - -const address : address = "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" ; - -const address_2 : address = ("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address) ; diff --git a/src/ligo/contracts/arithmetic.ligo b/src/ligo/contracts/arithmetic.ligo deleted file mode 100644 index 25b756b04..000000000 --- a/src/ligo/contracts/arithmetic.ligo +++ /dev/null @@ -1,17 +0,0 @@ -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/src/ligo/contracts/basic.mligo b/src/ligo/contracts/basic.mligo deleted file mode 100644 index 34be829e0..000000000 --- a/src/ligo/contracts/basic.mligo +++ /dev/null @@ -1,3 +0,0 @@ -type toto = int - -let foo : toto = 42 + 127 diff --git a/src/ligo/contracts/boolean_operators.ligo b/src/ligo/contracts/boolean_operators.ligo deleted file mode 100644 index 38b94ba02..000000000 --- a/src/ligo/contracts/boolean_operators.ligo +++ /dev/null @@ -1,11 +0,0 @@ -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/src/ligo/contracts/closure.ligo b/src/ligo/contracts/closure.ligo deleted file mode 100644 index d43d5400f..000000000 --- a/src/ligo/contracts/closure.ligo +++ /dev/null @@ -1,11 +0,0 @@ -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/src/ligo/contracts/coase.ligo b/src/ligo/contracts/coase.ligo deleted file mode 100644 index 8d5ad912f..000000000 --- a/src/ligo/contracts/coase.ligo +++ /dev/null @@ -1,98 +0,0 @@ -// 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/src/ligo/contracts/condition.ligo b/src/ligo/contracts/condition.ligo deleted file mode 100644 index 68c949640..000000000 --- a/src/ligo/contracts/condition.ligo +++ /dev/null @@ -1,8 +0,0 @@ -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/src/ligo/contracts/counter.ligo b/src/ligo/contracts/counter.ligo deleted file mode 100644 index 469681a4c..000000000 --- a/src/ligo/contracts/counter.ligo +++ /dev/null @@ -1,6 +0,0 @@ -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/src/ligo/contracts/counter.mligo b/src/ligo/contracts/counter.mligo deleted file mode 100644 index 0cfa95bdf..000000000 --- a/src/ligo/contracts/counter.mligo +++ /dev/null @@ -1,4 +0,0 @@ -type storage = int - -let%entry main (p:int) storage = - (list [] : operation list , p + storage) diff --git a/src/ligo/contracts/declarations.ligo b/src/ligo/contracts/declarations.ligo deleted file mode 100644 index c153b0c57..000000000 --- a/src/ligo/contracts/declarations.ligo +++ /dev/null @@ -1,6 +0,0 @@ -const foo : int = 42 - -function main (const i : int) : int is - begin - skip - end with i + foo diff --git a/src/ligo/contracts/dispatch-counter.ligo b/src/ligo/contracts/dispatch-counter.ligo deleted file mode 100644 index c8c59250a..000000000 --- a/src/ligo/contracts/dispatch-counter.ligo +++ /dev/null @@ -1,16 +0,0 @@ -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/src/ligo/contracts/function-complex.ligo b/src/ligo/contracts/function-complex.ligo deleted file mode 100644 index ec34cab7e..000000000 --- a/src/ligo/contracts/function-complex.ligo +++ /dev/null @@ -1,7 +0,0 @@ -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/src/ligo/contracts/function-shared.ligo b/src/ligo/contracts/function-shared.ligo deleted file mode 100644 index c84fec402..000000000 --- a/src/ligo/contracts/function-shared.ligo +++ /dev/null @@ -1,8 +0,0 @@ -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/src/ligo/contracts/function.ligo b/src/ligo/contracts/function.ligo deleted file mode 100644 index 8149b2e15..000000000 --- a/src/ligo/contracts/function.ligo +++ /dev/null @@ -1,4 +0,0 @@ -function main (const i : int) : int is - begin - skip - end with i diff --git a/src/ligo/contracts/heap-instance.ligo b/src/ligo/contracts/heap-instance.ligo deleted file mode 100644 index b214f0fab..000000000 --- a/src/ligo/contracts/heap-instance.ligo +++ /dev/null @@ -1,6 +0,0 @@ -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/src/ligo/contracts/heap.ligo b/src/ligo/contracts/heap.ligo deleted file mode 100644 index 23d7425b7..000000000 --- a/src/ligo/contracts/heap.ligo +++ /dev/null @@ -1,90 +0,0 @@ -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/src/ligo/contracts/high-order.ligo b/src/ligo/contracts/high-order.ligo deleted file mode 100644 index 8dc7f3e4b..000000000 --- a/src/ligo/contracts/high-order.ligo +++ /dev/null @@ -1,6 +0,0 @@ -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/src/ligo/contracts/included.ligo b/src/ligo/contracts/included.ligo deleted file mode 100644 index 3f0a2d1ca..000000000 --- a/src/ligo/contracts/included.ligo +++ /dev/null @@ -1 +0,0 @@ -const foo : int = 144 diff --git a/src/ligo/contracts/includer.ligo b/src/ligo/contracts/includer.ligo deleted file mode 100644 index e68975796..000000000 --- a/src/ligo/contracts/includer.ligo +++ /dev/null @@ -1,3 +0,0 @@ -#include "included.ligo" - -const bar : int = foo diff --git a/src/ligo/contracts/list.ligo b/src/ligo/contracts/list.ligo deleted file mode 100644 index 60af05003..000000000 --- a/src/ligo/contracts/list.ligo +++ /dev/null @@ -1,19 +0,0 @@ -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/src/ligo/contracts/loop.ligo b/src/ligo/contracts/loop.ligo deleted file mode 100644 index 0408f85ef..000000000 --- a/src/ligo/contracts/loop.ligo +++ /dev/null @@ -1,19 +0,0 @@ -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/src/ligo/contracts/map.ligo b/src/ligo/contracts/map.ligo deleted file mode 100644 index bcc2a8005..000000000 --- a/src/ligo/contracts/map.ligo +++ /dev/null @@ -1,33 +0,0 @@ -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/src/ligo/contracts/match.ligo b/src/ligo/contracts/match.ligo deleted file mode 100644 index 57a74d7dd..000000000 --- a/src/ligo/contracts/match.ligo +++ /dev/null @@ -1,31 +0,0 @@ -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/src/ligo/contracts/multiple-parameters.ligo b/src/ligo/contracts/multiple-parameters.ligo deleted file mode 100644 index fe2373076..000000000 --- a/src/ligo/contracts/multiple-parameters.ligo +++ /dev/null @@ -1,8 +0,0 @@ -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/src/ligo/contracts/new-syntax.mligo b/src/ligo/contracts/new-syntax.mligo deleted file mode 100644 index f2fed5396..000000000 --- a/src/ligo/contracts/new-syntax.mligo +++ /dev/null @@ -1,21 +0,0 @@ -(** 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/src/ligo/contracts/option.ligo b/src/ligo/contracts/option.ligo deleted file mode 100644 index 85e3396e0..000000000 --- a/src/ligo/contracts/option.ligo +++ /dev/null @@ -1,4 +0,0 @@ -type foobar is option(int) - -const s : foobar = Some(42) -const n : foobar = None diff --git a/src/ligo/contracts/quote-declaration.ligo b/src/ligo/contracts/quote-declaration.ligo deleted file mode 100644 index 4c5547d4c..000000000 --- a/src/ligo/contracts/quote-declaration.ligo +++ /dev/null @@ -1,8 +0,0 @@ -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/src/ligo/contracts/quote-declarations.ligo b/src/ligo/contracts/quote-declarations.ligo deleted file mode 100644 index 1b783066d..000000000 --- a/src/ligo/contracts/quote-declarations.ligo +++ /dev/null @@ -1,13 +0,0 @@ -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/src/ligo/contracts/record.ligo b/src/ligo/contracts/record.ligo deleted file mode 100644 index e0fbb5d04..000000000 --- a/src/ligo/contracts/record.ligo +++ /dev/null @@ -1,56 +0,0 @@ -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/src/ligo/contracts/shadow.ligo b/src/ligo/contracts/shadow.ligo deleted file mode 100644 index 4232cb0a6..000000000 --- a/src/ligo/contracts/shadow.ligo +++ /dev/null @@ -1,4 +0,0 @@ -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/src/ligo/contracts/string.ligo b/src/ligo/contracts/string.ligo deleted file mode 100644 index ae54f8c09..000000000 --- a/src/ligo/contracts/string.ligo +++ /dev/null @@ -1 +0,0 @@ -const s : string = "toto" diff --git a/src/ligo/contracts/super-counter.ligo b/src/ligo/contracts/super-counter.ligo deleted file mode 100644 index 45ce7462a..000000000 --- a/src/ligo/contracts/super-counter.ligo +++ /dev/null @@ -1,10 +0,0 @@ -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/src/ligo/contracts/toto.ligo b/src/ligo/contracts/toto.ligo deleted file mode 100644 index 785655b4a..000000000 --- a/src/ligo/contracts/toto.ligo +++ /dev/null @@ -1,6 +0,0 @@ -type toto is record - a : nat ; - b : nat -end - -const foo : int = 3 diff --git a/src/ligo/contracts/tuple.ligo b/src/ligo/contracts/tuple.ligo deleted file mode 100644 index 9a39cde03..000000000 --- a/src/ligo/contracts/tuple.ligo +++ /dev/null @@ -1,22 +0,0 @@ -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/src/ligo/contracts/unit.ligo b/src/ligo/contracts/unit.ligo deleted file mode 100644 index 5b05cb2b7..000000000 --- a/src/ligo/contracts/unit.ligo +++ /dev/null @@ -1 +0,0 @@ -const u : unit = unit diff --git a/src/ligo/contracts/variant-matching.ligo b/src/ligo/contracts/variant-matching.ligo deleted file mode 100644 index 5c13a5053..000000000 --- a/src/ligo/contracts/variant-matching.ligo +++ /dev/null @@ -1,11 +0,0 @@ -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/src/ligo/contracts/variant.ligo b/src/ligo/contracts/variant.ligo deleted file mode 100644 index b98001a02..000000000 --- a/src/ligo/contracts/variant.ligo +++ /dev/null @@ -1,10 +0,0 @@ -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/src/ligo/dune b/src/ligo/dune deleted file mode 100644 index f077868b2..000000000 --- a/src/ligo/dune +++ /dev/null @@ -1,33 +0,0 @@ -(env - (dev - (flags (:standard -w +1..62-4-9-44-40-42-48@39@33 -open Tezos_utils )) - ) - (release - (flags (:standard -w +1..62-4-9-44-40-42-48@39@33 -open Tezos_utils )) - ) -) - -(library - (name ligo) - (public_name ligo) - (libraries - tezos-utils - tezos-micheline - meta_michelson - main - ) - (preprocess - (pps tezos-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/src/ligo/ligo.ml b/src/ligo/ligo.ml deleted file mode 100644 index 1e27a74ab..000000000 --- a/src/ligo/ligo.ml +++ /dev/null @@ -1 +0,0 @@ -include Main diff --git a/src/ligo/ligo.opam b/src/ligo/ligo.opam deleted file mode 100644 index 9294b375f..000000000 --- a/src/ligo/ligo.opam +++ /dev/null @@ -1,28 +0,0 @@ -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/src/ligo/main/contract.ml b/src/ligo/main/contract.ml deleted file mode 100644 index ff3f8a98b..000000000 --- a/src/ligo/main/contract.ml +++ /dev/null @@ -1,178 +0,0 @@ -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/src/ligo/main/dune b/src/ligo/main/dune deleted file mode 100644 index 5446f4ebf..000000000 --- a/src/ligo/main/dune +++ /dev/null @@ -1,20 +0,0 @@ -(library - (name main) - (public_name ligo.main) - (libraries - tezos-utils - parser - simplify - ast_simplified - typer - ast_typed - transpiler - mini_c - operators - compiler - ) - (preprocess - (pps tezos-utils.ppx_let_generalized) - ) - (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Tezos_utils )) -) diff --git a/src/ligo/main/main.ml b/src/ligo/main/main.ml deleted file mode 100644 index 34bd70fe1..000000000 --- a/src/ligo/main/main.ml +++ /dev/null @@ -1,197 +0,0 @@ -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/src/ligo/main/run_mini_c.ml b/src/ligo/main/run_mini_c.ml deleted file mode 100644 index 5fb8d908f..000000000 --- a/src/ligo/main/run_mini_c.ml +++ /dev/null @@ -1,60 +0,0 @@ -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/src/ligo/meta_michelson/alpha_wrap.ml b/src/ligo/meta_michelson/alpha_wrap.ml deleted file mode 100644 index 196f6a9c4..000000000 --- a/src/ligo/meta_michelson/alpha_wrap.ml +++ /dev/null @@ -1,30 +0,0 @@ -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/src/ligo/meta_michelson/contract.ml b/src/ligo/meta_michelson/contract.ml deleted file mode 100644 index 056de705b..000000000 --- a/src/ligo/meta_michelson/contract.ml +++ /dev/null @@ -1,316 +0,0 @@ -open Misc - -open Tezos_utils.Error_monad -open Memory_proto_alpha -open Alpha_context - -open Script_ir_translator -open Script_typed_ir - -module Option = Tezos_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 (Failure "nat_to_int") @@ Script_int.to_int n - - let tez n = Option.unopt_exn (Failure "Values.tez") @@ Tez.of_mutez @@ Int64.of_int n - - let left a = L a - - let right b = R b -end diff --git a/src/ligo/meta_michelson/dune b/src/ligo/meta_michelson/dune deleted file mode 100644 index 0187cb121..000000000 --- a/src/ligo/meta_michelson/dune +++ /dev/null @@ -1,9 +0,0 @@ -(library - (name meta_michelson) - (public_name ligo.meta_michelson) - (libraries - tezos-utils - michelson-parser - tezos-micheline - ) -) diff --git a/src/ligo/meta_michelson/json.ml b/src/ligo/meta_michelson/json.ml deleted file mode 100644 index 9ed070d0c..000000000 --- a/src/ligo/meta_michelson/json.ml +++ /dev/null @@ -1,7 +0,0 @@ -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/src/ligo/meta_michelson/meta_michelson.ml b/src/ligo/meta_michelson/meta_michelson.ml deleted file mode 100644 index 7e80979ed..000000000 --- a/src/ligo/meta_michelson/meta_michelson.ml +++ /dev/null @@ -1,12 +0,0 @@ -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/src/ligo/meta_michelson/michelson_wrap.ml b/src/ligo/meta_michelson/michelson_wrap.ml deleted file mode 100644 index c465209e1..000000000 --- a/src/ligo/meta_michelson/michelson_wrap.ml +++ /dev/null @@ -1,514 +0,0 @@ -open Tezos_utils.Memory_proto_alpha -module AC = Alpha_context - -module Types = Contract.Types -module Option = Tezos_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/src/ligo/meta_michelson/misc.ml b/src/ligo/meta_michelson/misc.ml deleted file mode 100644 index 9ee94effe..000000000 --- a/src/ligo/meta_michelson/misc.ml +++ /dev/null @@ -1,302 +0,0 @@ -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) - (Tezos_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/src/ligo/meta_michelson/streams.ml b/src/ligo/meta_michelson/streams.ml deleted file mode 100644 index b45176516..000000000 --- a/src/ligo/meta_michelson/streams.ml +++ /dev/null @@ -1,18 +0,0 @@ -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/src/ligo/mini_c/PP.ml b/src/ligo/mini_c/PP.ml deleted file mode 100644 index 6e03017fd..000000000 --- a/src/ligo/mini_c/PP.ml +++ /dev/null @@ -1,120 +0,0 @@ -open 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)" PP_helpers.(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/src/ligo/mini_c/combinators.ml b/src/ligo/mini_c/combinators.ml deleted file mode 100644 index 5f5a061fb..000000000 --- a/src/ligo/mini_c/combinators.ml +++ /dev/null @@ -1,161 +0,0 @@ -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/src/ligo/mini_c/combinators_smart.ml b/src/ligo/mini_c/combinators_smart.ml deleted file mode 100644 index 4e0126f35..000000000 --- a/src/ligo/mini_c/combinators_smart.ml +++ /dev/null @@ -1,52 +0,0 @@ -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/src/ligo/mini_c/dune b/src/ligo/mini_c/dune deleted file mode 100644 index f03d8346c..000000000 --- a/src/ligo/mini_c/dune +++ /dev/null @@ -1,12 +0,0 @@ -(library - (name mini_c) - (public_name ligo.mini_c) - (libraries - tezos-utils - meta_michelson - ) - (preprocess - (pps tezos-utils.ppx_let_generalized) - ) - (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Tezos_utils )) -) diff --git a/src/ligo/mini_c/environment.ml b/src/ligo/mini_c/environment.ml deleted file mode 100644 index 8b06cfa67..000000000 --- a/src/ligo/mini_c/environment.ml +++ /dev/null @@ -1,61 +0,0 @@ -(* 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/src/ligo/mini_c/mini_c.ml b/src/ligo/mini_c/mini_c.ml deleted file mode 100644 index 5f4e9f5a2..000000000 --- a/src/ligo/mini_c/mini_c.ml +++ /dev/null @@ -1,10 +0,0 @@ -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/src/ligo/mini_c/types.ml b/src/ligo/mini_c/types.ml deleted file mode 100644 index d37fb4daf..000000000 --- a/src/ligo/mini_c/types.ml +++ /dev/null @@ -1,109 +0,0 @@ -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/src/ligo/operators/dune b/src/ligo/operators/dune deleted file mode 100644 index 102c47e45..000000000 --- a/src/ligo/operators/dune +++ /dev/null @@ -1,12 +0,0 @@ -(library - (name operators) - (public_name ligo.operators) - (libraries - tezos-utils - ast_typed - mini_c - ) - (preprocess - (pps tezos-utils.ppx_let_generalized) - ) -) diff --git a/src/ligo/operators/operators.ml b/src/ligo/operators/operators.ml deleted file mode 100644 index 89feeb0e0..000000000 --- a/src/ligo/operators/operators.ml +++ /dev/null @@ -1,407 +0,0 @@ -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 = 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/src/ligo/parser/camligo/.gitignore b/src/ligo/parser/camligo/.gitignore deleted file mode 100644 index 5d2e66768..000000000 --- a/src/ligo/parser/camligo/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -ast_generated.ml -parser_generated.mly diff --git a/src/ligo/parser/camligo/ast.ml b/src/ligo/parser/camligo/ast.ml deleted file mode 100644 index 00523c894..000000000 --- a/src/ligo/parser/camligo/ast.ml +++ /dev/null @@ -1 +0,0 @@ -include Ast_generated diff --git a/src/ligo/parser/camligo/dune b/src/ligo/parser/camligo/dune deleted file mode 100644 index a54a56ae3..000000000 --- a/src/ligo/parser/camligo/dune +++ /dev/null @@ -1,58 +0,0 @@ -(library - (name parser_camligo) - (public_name ligo.parser.camligo) - (libraries - tezos-utils - lex - ) - (modules ast ast_generated parser user) - (flags (:standard -w +1..62-4-9-44-40-42-48@39@33 -open Tezos_utils )) - (preprocess - (pps - tezos-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 - tezos-utils - lex - ) - (modules generator) -) diff --git a/src/ligo/parser/camligo/generator.ml b/src/ligo/parser/camligo/generator.ml deleted file mode 100644 index 1cd1b46db..000000000 --- a/src/ligo/parser/camligo/generator.ml +++ /dev/null @@ -1,737 +0,0 @@ -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/src/ligo/parser/camligo/lex/dune b/src/ligo/parser/camligo/lex/dune deleted file mode 100644 index 49af0da92..000000000 --- a/src/ligo/parser/camligo/lex/dune +++ /dev/null @@ -1,51 +0,0 @@ -(library - (name lex) - (public_name ligo.multifix.lex) - (libraries - tezos-utils - ) - (modules token token_type lexer) -) - -(executable - (name generator) - (libraries - tezos-utils - ) - (modules generator) -) - -(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/src/ligo/parser/camligo/lex/generator.ml b/src/ligo/parser/camligo/lex/generator.ml deleted file mode 100644 index 0bc669729..000000000 --- a/src/ligo/parser/camligo/lex/generator.ml +++ /dev/null @@ -1,181 +0,0 @@ -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 -> - 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" (PP_helpers.list_sep token (PP_helpers.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 -> - fprintf ppf "%s%a\n%s" pre (PP_helpers.list_sep token (PP_helpers.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 -> - fprintf ppf "%s%a" pre (PP_helpers.list_sep token (PP_helpers.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 - match arg with - | "mll" -> ( - Format.printf "%a@.%a\n" PP_helpers.comment "Generated .mll" Print_mll.tokens tokens - ) - | "mly" -> ( - Format.printf "%a@.%a\n" PP_helpers.comment "Generated .mly" Print_mly.tokens tokens - ) - | "ml" -> ( - Format.printf "%a@.%a\n" PP_helpers.comment "Generated .ml" Print_ml.tokens tokens - ) - | _ -> exit 1 - diff --git a/src/ligo/parser/camligo/location.ml b/src/ligo/parser/camligo/location.ml deleted file mode 100644 index cd160a125..000000000 --- a/src/ligo/parser/camligo/location.ml +++ /dev/null @@ -1,25 +0,0 @@ -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/src/ligo/parser/camligo/parser_camligo.ml b/src/ligo/parser/camligo/parser_camligo.ml deleted file mode 100644 index 9578d27b9..000000000 --- a/src/ligo/parser/camligo/parser_camligo.ml +++ /dev/null @@ -1,3 +0,0 @@ -module Ast = Ast -module Parser = Parser -module User = User diff --git a/src/ligo/parser/camligo/pre_parser.mly b/src/ligo/parser/camligo/pre_parser.mly deleted file mode 100644 index 159e13d5f..000000000 --- a/src/ligo/parser/camligo/pre_parser.mly +++ /dev/null @@ -1,72 +0,0 @@ -%{ - 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/src/ligo/parser/camligo/user.ml b/src/ligo/parser/camligo/user.ml deleted file mode 100644 index 3c00ae6dd..000000000 --- a/src/ligo/parser/camligo/user.ml +++ /dev/null @@ -1,40 +0,0 @@ -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/src/ligo/parser/dune b/src/ligo/parser/dune deleted file mode 100644 index f1f8f646b..000000000 --- a/src/ligo/parser/dune +++ /dev/null @@ -1,12 +0,0 @@ -(library - (name parser) - (public_name ligo.parser) - (libraries - tezos-utils - parser_pascaligo - parser_camligo - ) - (preprocess - (pps tezos-utils.ppx_let_generalized) - ) -) diff --git a/src/ligo/parser/parser.ml b/src/ligo/parser/parser.ml deleted file mode 100644 index 854029d33..000000000 --- a/src/ligo/parser/parser.ml +++ /dev/null @@ -1,116 +0,0 @@ -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/src/ligo/parser/pascaligo/.Lexer.ml.tag b/src/ligo/parser/pascaligo/.Lexer.ml.tag deleted file mode 100644 index 051eeceb0..000000000 --- a/src/ligo/parser/pascaligo/.Lexer.ml.tag +++ /dev/null @@ -1 +0,0 @@ -ocamlc: -w -42 diff --git a/src/ligo/parser/pascaligo/.LexerMain.tag b/src/ligo/parser/pascaligo/.LexerMain.tag deleted file mode 100644 index e69de29bb..000000000 diff --git a/src/ligo/parser/pascaligo/.Parser.mly.tag b/src/ligo/parser/pascaligo/.Parser.mly.tag deleted file mode 100644 index 100f7bb69..000000000 --- a/src/ligo/parser/pascaligo/.Parser.mly.tag +++ /dev/null @@ -1 +0,0 @@ ---explain --external-tokens LexToken --base Parser ParToken.mly diff --git a/src/ligo/parser/pascaligo/.ParserMain.tag b/src/ligo/parser/pascaligo/.ParserMain.tag deleted file mode 100644 index e69de29bb..000000000 diff --git a/src/ligo/parser/pascaligo/.gitignore b/src/ligo/parser/pascaligo/.gitignore deleted file mode 100644 index 5bb749771..000000000 --- a/src/ligo/parser/pascaligo/.gitignore +++ /dev/null @@ -1,12 +0,0 @@ -_build/* -*/_build -*~ -.merlin -*/.merlin -*.install -/Version.ml -/dune-project -/Parser.mli -/Parser.ml -/Lexer.ml -/LexToken.ml diff --git a/src/ligo/parser/pascaligo/.gitlab-ci.yml b/src/ligo/parser/pascaligo/.gitlab-ci.yml deleted file mode 100644 index 5c8b0d9af..000000000 --- a/src/ligo/parser/pascaligo/.gitlab-ci.yml +++ /dev/null @@ -1,21 +0,0 @@ -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/src/ligo/parser/pascaligo/.links b/src/ligo/parser/pascaligo/.links deleted file mode 100644 index 34a1424ad..000000000 --- a/src/ligo/parser/pascaligo/.links +++ /dev/null @@ -1,7 +0,0 @@ -$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/src/ligo/parser/pascaligo/AST.ml b/src/ligo/parser/pascaligo/AST.ml deleted file mode 100644 index 0cd633ddf..000000000 --- a/src/ligo/parser/pascaligo/AST.ml +++ /dev/null @@ -1,805 +0,0 @@ -(* 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/src/ligo/parser/pascaligo/AST.mli b/src/ligo/parser/pascaligo/AST.mli deleted file mode 100644 index 5a8df626e..000000000 --- a/src/ligo/parser/pascaligo/AST.mli +++ /dev/null @@ -1,649 +0,0 @@ -(* 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/src/ligo/parser/pascaligo/Error.mli b/src/ligo/parser/pascaligo/Error.mli deleted file mode 100644 index 19c1ce4c9..000000000 --- a/src/ligo/parser/pascaligo/Error.mli +++ /dev/null @@ -1,3 +0,0 @@ -type t = .. - -type error = t diff --git a/src/ligo/parser/pascaligo/EvalOpt.ml b/src/ligo/parser/pascaligo/EvalOpt.ml deleted file mode 100644 index 20d039603..000000000 --- a/src/ligo/parser/pascaligo/EvalOpt.ml +++ /dev/null @@ -1,161 +0,0 @@ -(* 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 [