balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Generate field annotations for sum/record

Browse Source
This commit is contained in:
Tom Jack 2019-08-26 18:34:00 -07:00
parent 43e75e186b
commit 09496ce4ca
9 changed files with 71 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
src/main/compile/of_mini_c.ml
View File

@ -48,7 +48,8 @@ let compile_contract_entry = fun program name ->
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.body in
let body = Michelson.strip_annots compiled.body in
let contract = Michelson.contract param_michelson storage_michelson body in
ok contract

2
src/main/run/of_michelson.ml
View File

@ -24,7 +24,7 @@ let run ?options (* ?(is_input_value = false) *) (program:compiled_program) (inp
Trace.trace_tzresult_lwt (simple_error "error parsing input") @@
Memory_proto_alpha.parse_michelson_data input_michelson input_ty
in
let body = Michelson.(strip_nops @@ strip_annots body) in
let body = Michelson.strip_annots body in
let%bind descr =
Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@
Memory_proto_alpha.parse_michelson body

41
src/passes/6-transpiler/transpiler.ml
View File

@ -131,28 +131,39 @@ let rec transpile_type (t:AST.type_value) : type_value result =
let%bind o' = transpile_type o in
ok (T_option o')
| T_constant (name , _lst) -> fail @@ unrecognized_type_constant name
(* TODO hmm *)
| T_sum m ->
let node = Append_tree.of_list @@ list_of_map m in
let aux a b : type_value result =
let node = Append_tree.of_list @@ kv_list_of_map m in
let aux a b : type_value annotated result =
let%bind a = a in
let%bind b = b in
ok (T_or (a, b))
ok (None, T_or (a, b))
in
Append_tree.fold_ne transpile_type aux node
let%bind m' = Append_tree.fold_ne
(fun (ann, a) ->
let%bind a = transpile_type a in
ok (Some (String.uncapitalize_ascii ann), a))
aux node in
ok @@ snd m'
| T_record m ->
let node = Append_tree.of_list @@ list_of_map m in
let aux a b : type_value result =
let node = Append_tree.of_list @@ kv_list_of_map m in
let aux a b : type_value annotated result =
let%bind a = a in
let%bind b = b in
ok (T_pair (a, b))
ok (None, T_pair (a, b))
in
Append_tree.fold_ne transpile_type aux node
let%bind m' = Append_tree.fold_ne
(fun (ann, a) ->
let%bind a = transpile_type a in
ok (Some ann, a))
aux node in
ok @@ snd m'
| T_tuple lst ->
let node = Append_tree.of_list lst in
let aux a b : type_value result =
let%bind a = a in
let%bind b = b in
ok (T_pair (a, b))
ok (T_pair ((None, a), (None, b)))
in
Append_tree.fold_ne transpile_type aux node
| T_function (param, result) -> (
@ -289,10 +300,10 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
let%bind a = a in
let%bind b = b in
match (a, b) with
| (None, a), (None, b) -> ok (None, T_or (a, b))
| (None, a), (None, b) -> ok (None, T_or ((None, a), (None, b)))
| (Some _, _), (Some _, _) -> fail @@ corner_case ~loc:__LOC__ "multiple identical constructors in the same variant"
| (Some v, a), (None, b) -> ok (Some (E_constant ("LEFT", [Combinators.Expression.make_tpl (v, a)])), T_or (a, b))
| (None, a), (Some v, b) -> ok (Some (E_constant ("RIGHT", [Combinators.Expression.make_tpl (v, b)])), T_or (a, b))
| (Some v, a), (None, b) -> ok (Some (E_constant ("LEFT", [Combinators.Expression.make_tpl (v, a)])), T_or ((None, a), (None, b)))
| (None, a), (Some v, b) -> ok (Some (E_constant ("RIGHT", [Combinators.Expression.make_tpl (v, b)])), T_or ((None, a), (None, b)))
in
let%bind (ae_opt, tv) = Append_tree.fold_ne leaf node node_tv in
let%bind ae =
@ -307,7 +318,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
let%bind b = b in
let a_ty = Combinators.Expression.get_type a in
let b_ty = Combinators.Expression.get_type b in
let tv = T_pair (a_ty , b_ty) in
let tv = T_pair ((None, a_ty) , (None, b_ty)) in
return ~tv @@ E_constant ("PAIR", [a; b])
in
Append_tree.fold_ne (transpile_annotated_expression) aux node
@ -337,7 +348,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
let%bind b = b in
let a_ty = Combinators.Expression.get_type a in
let b_ty = Combinators.Expression.get_type b in
let tv = T_pair (a_ty , b_ty) in
let tv = T_pair ((None, a_ty) , (None, b_ty)) in
return ~tv @@ E_constant ("PAIR", [a; b])
in
trace_strong (corner_case ~loc:__LOC__ "record build") @@
@ -555,7 +566,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
| Node {a ; b} ->
let%bind a' = aux a in
let%bind b' = aux b in
let tv' = Mini_c.t_union (snd a') (snd b') in
let tv' = Mini_c.t_union (None, snd a') (None, snd b') in
ok (`Node (a' , b') , tv')
in aux tree'
in

38
src/passes/8-compiler/compiler_type.ml
View File

@ -43,6 +43,13 @@ module Ty = struct
let pair a b = Pair_t ((a, None, None), (b, None, None), None)
let union a b = Union_t ((a, None), (b, None), None)
let field_annot = Option.map (fun ann -> `Field_annot ann)
let union_ann (anna, a) (annb, b) =
Union_t ((a, field_annot anna), (b, field_annot annb), None)
let pair_ann (anna, a) (annb, b) =
Pair_t ((a, field_annot anna, None), (b, field_annot annb, None), None)
let not_comparable name () = error (thunk "not a comparable type") (fun () -> name) ()
let not_compilable_type name () = error (thunk "not a compilable type") (fun () -> name) ()
@ -95,14 +102,14 @@ module Ty = struct
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 (pair t t')
annotated t >>? fun (ann, Ex_ty t) ->
annotated t' >>? fun (ann', Ex_ty t') ->
ok @@ Ex_ty (pair_ann (ann, t) (ann', t'))
)
| T_or (t, t') -> (
type_ t >>? fun (Ex_ty t) ->
type_ t' >>? fun (Ex_ty t') ->
ok @@ Ex_ty (union t t')
annotated t >>? fun (ann, Ex_ty t) ->
annotated t' >>? fun (ann', Ex_ty t') ->
ok @@ Ex_ty (union_ann (ann, t) (ann', t'))
)
| T_function (arg, ret) ->
let%bind (Ex_ty arg) = type_ arg in
@ -135,6 +142,10 @@ module Ty = struct
let%bind (Ex_ty t') = type_ t in
ok @@ Ex_ty (contract t')
and annotated : type_value annotated -> ex_ty annotated result =
fun (ann, a) -> let%bind a = type_ a in
ok @@ (ann, a)
and environment_representation = fun e ->
match List.rev_uncons_opt e with
| None -> ok @@ Ex_ty unit
@ -177,13 +188,13 @@ 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' ->
annotated t >>? fun t ->
annotated t' >>? fun t' ->
ok @@ O.prim ~children:[t;t'] O.T_pair
)
| T_or (t, t') -> (
type_ t >>? fun t ->
type_ t' >>? fun t' ->
annotated t >>? fun t ->
annotated t' >>? fun t' ->
ok @@ O.prim ~children:[t;t'] O.T_or
)
| T_map kv ->
@ -213,6 +224,13 @@ let rec type_ : type_value -> O.michelson result =
let%bind lambda = lambda_closure (c , arg , ret) in
ok @@ O.t_pair lambda capture
and annotated : type_value annotated -> O.michelson result =
function
| (Some ann, o) ->
let%bind o' = type_ o in
ok (O.annotate ("%" ^ ann) o')
| (None, o) -> type_ o
and environment_element (name, tyv) =
let%bind michelson_type = type_ tyv in
ok @@ O.annotate ("@" ^ name) michelson_type

8
src/stages/mini_c/PP.ml
View File

@ -22,8 +22,8 @@ let type_base ppf : type_base -> _ = function
| 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_or(a, b) -> fprintf ppf "(%a) | (%a)" annotated a annotated b
| T_pair(a, b) -> fprintf ppf "(%a) & (%a)" annotated a annotated 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
@ -37,6 +37,10 @@ let rec type_ ppf : type_value -> _ = function
environment c
type_ arg type_ ret
and annotated ppf : type_value annotated -> _ = function
| (Some ann, a) -> fprintf ppf "(%a %%%s)" type_ a ann
| (None, a) -> type_ ppf a
and environment_element ppf ((s, tv) : environment_element) =
Format.fprintf ppf "%s : %a" s type_ tv

8
src/stages/mini_c/combinators.ml
View File

@ -102,11 +102,11 @@ let get_pair (v:value) = match v with
| _ -> simple_fail "not a pair"
let get_t_pair (t:type_value) = match t with
| T_pair (a, b) -> ok (a, b)
| T_pair ((_, a), (_, b)) -> ok (a, b)
| _ -> simple_fail "not a type pair"
let get_t_or (t:type_value) = match t with
| T_or (a, b) -> ok (a, b)
| T_or ((_, a), (_, b)) -> ok (a, b)
| _ -> simple_fail "not a type or"
let get_t_map (t:type_value) = match t with
@ -144,11 +144,11 @@ let wrong_type name t =
error title content
let get_t_left t = match t with
| T_or (a , _) -> ok a
| T_or ((_, a) , _) -> ok a
| _ -> fail @@ wrong_type "union" t
let get_t_right t = match t with
| T_or (_ , b) -> ok b
| T_or (_ , (_, b)) -> ok b
| _ -> fail @@ wrong_type "union" t
let get_t_contract t = match t with

6
src/stages/mini_c/types.ml
View File

@ -8,9 +8,11 @@ type type_base =
| Base_string | Base_bytes | Base_address
| Base_operation
type 'a annotated = string option * 'a
type type_value =
| T_pair of (type_value * type_value)
| T_or of type_value * type_value
| T_pair of (type_value annotated * type_value annotated)
| T_or of (type_value annotated * type_value annotated)
| T_function of (type_value * type_value)
| T_deep_closure of (environment * type_value * type_value)
| T_base of type_base

8
vendors/ligo-utils/proto-alpha-utils/x_memory_proto_alpha.ml vendored
View File

@ -953,8 +953,6 @@ let parse_michelson (type aft)
?type_logger
(bef:'a Script_typed_ir.stack_ty) (aft:aft Script_typed_ir.stack_ty)
=
let michelson = Michelson.strip_annots michelson in
let michelson = Michelson.strip_nops michelson in
parse_instr
?type_logger
top_level tezos_context
@ -975,8 +973,6 @@ let parse_michelson_fail (type aft)
?type_logger
(bef:'a Script_typed_ir.stack_ty) (aft:aft Script_typed_ir.stack_ty)
=
let michelson = Michelson.strip_annots michelson in
let michelson = Michelson.strip_nops michelson in
parse_instr
?type_logger
top_level tezos_context
@ -995,8 +991,6 @@ let parse_michelson_fail (type aft)
let parse_michelson_data
?(tezos_context = dummy_environment.tezos_context)
michelson ty =
let michelson = Michelson.strip_annots michelson in
let michelson = Michelson.strip_nops michelson in
parse_data tezos_context ty michelson >>=?? fun (data, _) ->
return data
@ -1004,8 +998,6 @@ let parse_michelson_ty
?(tezos_context = dummy_environment.tezos_context)
?(allow_big_map = true) ?(allow_operation = true)
michelson =
let michelson = Michelson.strip_annots michelson in
let michelson = Michelson.strip_nops michelson in
Lwt.return @@ parse_ty tezos_context ~allow_big_map ~allow_operation michelson >>=?? fun (ty, _) ->
return ty

18
vendors/ligo-utils/tezos-utils/x_michelson.ml vendored
View File

@ -75,12 +75,6 @@ let rec strip_annots : michelson -> michelson = function
| Prim (l, p, lst, _) -> Prim (l, p, List.map strip_annots lst, [])
| x -> x
let rec strip_nops : michelson -> michelson = function
| Seq(l, [Prim (_, I_UNIT, _, _) ; Prim(_, I_DROP, _, _)]) -> Seq (l, [])
| Seq(l, s) -> Seq(l, List.map strip_nops s)
| Prim (l, p, lst, a) -> Prim (l, p, List.map strip_nops lst, a)
| x -> x
let pp ppf (michelson:michelson) =
let open Micheline_printer in
let canonical = strip_locations michelson in
@ -98,15 +92,3 @@ let pp_json ppf (michelson : michelson) =
)
in
Format.fprintf ppf "%a" Tezos_data_encoding.Json.pp json
let pp_stripped ppf (michelson:michelson) =
let open Micheline_printer in
let michelson' = strip_nops @@ strip_annots michelson in
let canonical = strip_locations michelson' in
let node = printable string_of_prim canonical in
print_expr ppf node
let pp_naked ppf m =
let naked = strip_annots m in
pp ppf naked