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

'michelson_or_right_comb' and 'michelson_or_left_comb' type operators

Browse Source
This commit is contained in:
Lesenechal Remi 2020-04-30 15:12:26 +02:00
parent 8e3230bf29
commit 0a44a22cac
18 changed files with 145 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
src/passes/4-imperative_to_sugar/imperative_to_sugar.ml
View File

@ -207,6 +207,12 @@ and compile_type_operator : I.type_operator -> O.type_operator result =
| TC_michelson_pair_left_comb c ->
let%bind c = compile_type_expression c in
ok @@ O.TC_michelson_pair_left_comb c
| TC_michelson_or_right_comb c ->
let%bind c = compile_type_expression c in
ok @@ O.TC_michelson_or_right_comb c
| TC_michelson_or_left_comb c ->
let%bind c = compile_type_expression c in
ok @@ O.TC_michelson_or_left_comb c
let rec compile_expression : I.expression -> O.expression result =
fun e ->
@ -652,6 +658,12 @@ and uncompile_type_operator : O.type_operator -> I.type_operator result =
| TC_michelson_pair_left_comb c ->
let%bind c = uncompile_type_expression c in
ok @@ I.TC_michelson_pair_left_comb c
| TC_michelson_or_right_comb c ->
let%bind c = uncompile_type_expression c in
ok @@ I.TC_michelson_or_right_comb c
| TC_michelson_or_left_comb c ->
let%bind c = uncompile_type_expression c in
ok @@ I.TC_michelson_or_left_comb c
let rec uncompile_expression' : O.expression -> I.expression result =
fun e ->

12
src/passes/6-sugar_to_core/sugar_to_core.ml
View File

@ -72,6 +72,12 @@ and idle_type_operator : I.type_operator -> O.type_operator result =
| TC_michelson_pair_left_comb c ->
let%bind c = idle_type_expression c in
ok @@ O.TC_michelson_pair_left_comb c
| TC_michelson_or_right_comb c ->
let%bind c = idle_type_expression c in
ok @@ O.TC_michelson_or_right_comb c
| TC_michelson_or_left_comb c ->
let%bind c = idle_type_expression c in
ok @@ O.TC_michelson_or_left_comb c
let rec compile_expression : I.expression -> O.expression result =
fun e ->
@ -300,6 +306,12 @@ and uncompile_type_operator : O.type_operator -> I.type_operator result =
| TC_michelson_pair_left_comb c ->
let%bind c = uncompile_type_expression c in
ok @@ I.TC_michelson_pair_left_comb c
| TC_michelson_or_right_comb c ->
let%bind c = uncompile_type_expression c in
ok @@ I.TC_michelson_or_right_comb c
| TC_michelson_or_left_comb c ->
let%bind c = uncompile_type_expression c in
ok @@ I.TC_michelson_or_left_comb c
let rec uncompile_expression : O.expression -> I.expression result =
fun e ->

3
src/passes/8-typer-new/typer.ml
View File

@ -181,7 +181,8 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
| TC_contract c ->
let%bind c = evaluate_type e c in
ok @@ O.TC_contract c
| TC_michelson_pair_right_comb _c | TC_michelson_pair_left_comb _c ->
| TC_michelson_pair_right_comb _c | TC_michelson_pair_left_comb _c
| TC_michelson_or_right_comb _c | TC_michelson_or_left_comb _c ->
(* not really sure what to do in the new typer, should be converted to a pair using functions defined in Helpers.Typer.Converter *)
simple_fail "to be implemented"
in

2
src/passes/8-typer-new/wrap.ml
View File

@ -108,6 +108,8 @@ let rec type_expression_to_type_value_copypasted : I.type_expression -> O.type_v
| TC_contract c -> (C_contract, [c])
| TC_michelson_pair_right_comb c -> (C_record, [c])
| TC_michelson_pair_left_comb c -> (C_record, [c])
| TC_michelson_or_right_comb c -> (C_record, [c])
| TC_michelson_or_left_comb c -> (C_record, [c])
)
in
p_constant csttag (List.map type_expression_to_type_value_copypasted args)

22
src/passes/8-typer-old/typer.ml
View File

@ -20,6 +20,14 @@ module Errors = struct
] in
error ~data title message ()
let michelson_comb_no_variant (loc:Location.t) () =
let title = (thunk "bad michelson_or_right_comb type parameter") in
let message () = "michelson_or_right_comb type operator must be used on a variant type" in
let data = [
("location" , fun () -> Format.asprintf "%a" Location.pp loc) ;
] in
error ~data title message ()
let unbound_type_variable (e:environment) (tv:I.type_variable) (loc:Location.t) () =
let name = Var.to_name tv in
let suggestion = match name with
@ -674,6 +682,20 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
| _ -> fail (michelson_comb_no_record t.location) in
let record = Operators.Typer.Converter.convert_pair_to_left_comb (Ast_typed.LMap.to_kv_list lmap) in
return @@ record
| TC_michelson_or_right_comb c ->
let%bind c' = evaluate_type e c in
let%bind cmap = match c'.type_content with
| T_sum cmap -> ok cmap
| _ -> fail (michelson_comb_no_variant t.location) in
let pair = Operators.Typer.Converter.convert_variant_to_right_comb (Ast_typed.CMap.to_kv_list cmap) in
return @@ pair
| TC_michelson_or_left_comb c ->
let%bind c' = evaluate_type e c in
let%bind cmap = match c'.type_content with
| T_sum cmap -> ok cmap
| _ -> fail (michelson_comb_no_variant t.location) in
let pair = Operators.Typer.Converter.convert_variant_to_left_comb(Ast_typed.CMap.to_kv_list cmap) in
return @@ pair
)
and type_expression : environment -> O.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O.typer_state) result

34
src/passes/operators/helpers.ml
View File

@ -249,6 +249,26 @@ module Typer = struct
ok (List.append next [r])
| _ -> simple_fail "Could not convert michelson_pair_left_comb pair to a record"
let rec from_right_comb_variant (l:ctor_content constructor_map) (size:int) : (ctor_content list) result =
let l' = List.rev @@ CMap.to_kv_list l in
match l' , size with
| [ (_,l) ; (_,r) ] , 2 -> ok [ l ; r ]
| [ (_,l) ; (_,{ctor_type=tr;_}) ], _ ->
let%bind comb_cmap = get_t_sum tr in
let%bind next = from_right_comb_variant comb_cmap (size-1) in
ok (l :: next)
| _ -> simple_fail "Could not convert michelson_or right comb to a variant"
let rec from_left_comb_variant (l:ctor_content constructor_map) (size:int) : (ctor_content list) result =
let l' = List.rev @@ CMap.to_kv_list l in
match l' , size with
| [ (_,l) ; (_,r) ] , 2 -> ok [ l ; r ]
| [ (_,{ctor_type=tl;_}) ; (_,r) ], _ ->
let%bind comb_cmap = get_t_sum tl in
let%bind next = from_left_comb_variant comb_cmap (size-1) in
ok (List.append next [r])
| _ -> simple_fail "Could not convert michelson_or left comb to a record"
let convert_pair_to_right_comb l =
let l' = List.sort (fun (_,{field_decl_pos=a;_}) (_,{field_decl_pos=b;_}) -> Int.compare a b) l in
T_record (to_right_comb_pair l' LMap.empty)
@ -279,6 +299,20 @@ module Typer = struct
let l' = List.sort (fun (_,{ctor_decl_pos=a;_}) (_,{ctor_decl_pos=b;_}) -> Int.compare a b) l in
T_sum (to_left_comb_variant l' CMap.empty)
let convert_variant_from_right_comb (src: ctor_content constructor_map) (dst: ctor_content constructor_map) : type_content result =
let%bind ctors = from_right_comb_variant src (CMap.cardinal dst) in
let ctors_name = List.map (fun (l,_) -> l) @@
List.sort (fun (_,{ctor_decl_pos=a;_}) (_,{ctor_decl_pos=b;_}) -> Int.compare a b ) @@
CMap.to_kv_list dst in
ok @@ (T_sum (CMap.of_list @@ List.combine ctors_name ctors))
let convert_variant_from_left_comb (src: ctor_content constructor_map) (dst: ctor_content constructor_map) : type_content result =
let%bind ctors = from_left_comb_variant src (CMap.cardinal dst) in
let ctors_name = List.map (fun (l,_) -> l) @@
List.sort (fun (_,{ctor_decl_pos=a;_}) (_,{ctor_decl_pos=b;_}) -> Int.compare a b ) @@
CMap.to_kv_list dst in
ok @@ (T_sum (CMap.of_list @@ List.combine ctors_name ctors))
end
end

2
src/passes/operators/helpers.mli
View File

@ -67,6 +67,8 @@ module Typer : sig
val convert_variant_to_right_comb : (constructor' * ctor_content) list -> type_content
val convert_variant_to_left_comb : (constructor' * ctor_content) list -> type_content
val convert_variant_from_right_comb : ctor_content constructor_map -> ctor_content constructor_map -> type_content result
val convert_variant_from_left_comb : ctor_content constructor_map -> ctor_content constructor_map -> type_content result
end
end

15
src/passes/operators/operators.ml
View File

@ -61,6 +61,8 @@ module Concrete_to_imperative = struct
| "contract" -> Some (TC_contract unit_expr)
| "michelson_pair_right_comb" -> Some (TC_michelson_pair_right_comb unit_expr)
| "michelson_pair_left_comb" -> Some (TC_michelson_pair_left_comb unit_expr)
| "michelson_or_right_comb" -> Some (TC_michelson_or_right_comb unit_expr)
| "michelson_or_left_comb" -> Some (TC_michelson_or_left_comb unit_expr)
| _ -> None
let pseudo_modules = function
@ -1196,12 +1198,19 @@ module Typer = struct
ok {t with type_content = michelson_or}
| _ -> simple_fail "converter can only be used on record or variants"
let convert_from_right_comb = typer_1_opt "CONVERT_FROM_RIGHT_COMB" @@ fun pair opt ->
let convert_from_right_comb = typer_1_opt "CONVERT_FROM_RIGHT_COMB" @@ fun t opt ->
match t.type_content with
| T_record src_lmap ->
let%bind dst_t = trace_option (simple_error "convert_from_right_comb must be annotated") opt in
let%bind dst_lmap = get_t_record dst_t in
let%bind src_lmap = get_t_record pair in
let%bind record = Converter.convert_pair_from_right_comb src_lmap dst_lmap in
ok {pair with type_content = record}
ok {t with type_content = record}
| T_sum src_cmap ->
let%bind dst_t = trace_option (simple_error "convert_from_right_comb must be annotated") opt in
let%bind dst_cmap = get_t_sum dst_t in
let%bind variant = Converter.convert_variant_from_right_comb src_cmap dst_cmap in
ok {t with type_content = variant}
| _ -> simple_fail "converter can only be used on record or variants"
let convert_from_left_comb = typer_1_opt "CONVERT_FROM_LEFT_COMB" @@ fun pair opt ->
let%bind dst_t = trace_option (simple_error "convert_from_left_comb must be annotated") opt in

2
src/passes/operators/operators.mli
View File

@ -178,6 +178,8 @@ module Typer : sig
val record_checks : (label * field_content) list -> unit result
val convert_pair_to_right_comb : (label * field_content) list -> type_content
val convert_pair_to_left_comb : (label * field_content) list -> type_content
val convert_variant_to_right_comb : (constructor' * ctor_content) list -> type_content
val convert_variant_to_left_comb : (constructor' * ctor_content) list -> type_content
end
end

2
src/stages/1-ast_imperative/PP.ml
View File

@ -63,6 +63,8 @@ and type_operator :
| TC_michelson_pair (l,_, r,_) -> Format.asprintf "Michelson_pair (%a,%a)" f l f r
| TC_michelson_pair_right_comb e -> Format.asprintf "michelson_pair_right_comb (%a)" f e
| TC_michelson_pair_left_comb e -> Format.asprintf "michelson_pair_left_comb (%a)" f e
| TC_michelson_or_right_comb e -> Format.asprintf "michelson_or_right_comb (%a)" f e
| TC_michelson_or_left_comb e -> Format.asprintf "michelson_or_left_comb (%a)" f e
| TC_contract te -> Format.asprintf "Contract (%a)" f te
in
fprintf ppf "(TO_%s)" s

4
src/stages/1-ast_imperative/combinators.ml
View File

@ -65,6 +65,8 @@ let t_michelson_or ?loc l l_ann r r_ann : type_expression = make_t ?loc @@ T_ope
let t_michelson_pair ?loc l l_ann r r_ann : type_expression = make_t ?loc @@ T_operator (TC_michelson_pair (l, l_ann, r, r_ann))
let t_michelson_pair_right_comb ?loc c : type_expression = make_t ?loc @@ T_operator (TC_michelson_pair_right_comb c)
let t_michelson_pair_left_comb ?loc c : type_expression = make_t ?loc @@ T_operator (TC_michelson_pair_left_comb c)
let t_michelson_or_right_comb ?loc c : type_expression = make_t ?loc @@ T_operator (TC_michelson_or_right_comb c)
let t_michelson_or_left_comb ?loc c : type_expression = make_t ?loc @@ T_operator (TC_michelson_or_left_comb c)
(* TODO find a better way than using list*)
let t_operator ?loc op lst: type_expression result =
@ -78,6 +80,8 @@ let t_operator ?loc op lst: type_expression result =
| TC_contract _ , [t] -> ok @@ t_contract t
| TC_michelson_pair_right_comb _ , [c] -> ok @@ t_michelson_pair_right_comb c
| TC_michelson_pair_left_comb _ , [c] -> ok @@ t_michelson_pair_left_comb c
| TC_michelson_or_right_comb _ , [c] -> ok @@ t_michelson_or_right_comb c
| TC_michelson_or_left_comb _ , [c] -> ok @@ t_michelson_or_left_comb c
| _ , _ -> fail @@ bad_type_operator op
let make_e ?(loc = Location.generated) expression_content =

2
src/stages/1-ast_imperative/types.ml
View File

@ -30,6 +30,8 @@ and type_operator =
| TC_big_map of type_expression * type_expression
| TC_michelson_or of type_expression * michelson_prct_annotation * type_expression * michelson_prct_annotation
| TC_michelson_pair of type_expression * michelson_prct_annotation * type_expression * michelson_prct_annotation
| TC_michelson_or_right_comb of type_expression
| TC_michelson_or_left_comb of type_expression
| TC_michelson_pair_right_comb of type_expression
| TC_michelson_pair_left_comb of type_expression

2
src/stages/2-ast_sugar/PP.ml
View File

@ -54,6 +54,8 @@ and type_operator : (formatter -> type_expression -> unit) -> formatter -> type_
| TC_contract te -> Format.asprintf "Contract (%a)" f te
| TC_michelson_pair_right_comb c -> Format.asprintf "michelson_pair_right_comb (%a)" f c
| TC_michelson_pair_left_comb c -> Format.asprintf "michelson_pair_left_comb (%a)" f c
| TC_michelson_or_right_comb c -> Format.asprintf "michelson_or_right_comb (%a)" f c
| TC_michelson_or_left_comb c -> Format.asprintf "michelson_or_left_comb (%a)" f c
in
fprintf ppf "(TO_%s)" s

2
src/stages/2-ast_sugar/types.ml
View File

@ -32,6 +32,8 @@ and type_operator =
| TC_big_map of type_expression * type_expression
| TC_michelson_pair_right_comb of type_expression
| TC_michelson_pair_left_comb of type_expression
| TC_michelson_or_right_comb of type_expression
| TC_michelson_or_left_comb of type_expression
and type_expression = {type_content: type_content; location: Location.t}

2
src/stages/4-ast_typed/combinators.ml
View File

@ -76,7 +76,7 @@ let make_t_ez_sum ?loc ?s (lst:(constructor' * ctor_content) list) : type_expres
make_t ?loc (T_sum map) s
let t_bool ?loc ?s () : type_expression = make_t_ez_sum ?loc ?s
[(Constructor "true", {ctor_type=t_unit ();michelson_annotation=None});(Constructor "false", {ctor_type=t_unit ();michelson_annotation=None})]
[(Constructor "true", {ctor_type=t_unit ();michelson_annotation=None;ctor_decl_pos=0});(Constructor "false", {ctor_type=t_unit ();michelson_annotation=None;ctor_decl_pos=1})]
let t_function param result ?loc ?s () : type_expression = make_t ?loc (T_arrow {type1=param; type2=result}) s
let t_shallow_closure param result ?loc ?s () : type_expression = make_t ?loc (T_arrow {type1=param; type2=result}) s

2
src/stages/common/PP.ml
View File

@ -256,6 +256,8 @@ module Ast_PP_type (PARAMETER : AST_PARAMETER_TYPE) = struct
| TC_contract te -> Format.asprintf "Contract (%a)" f te
| TC_michelson_pair_right_comb c -> Format.asprintf "michelson_pair_right_comb (%a)" f c
| TC_michelson_pair_left_comb c -> Format.asprintf "michelson_pair_left_comb (%a)" f c
| TC_michelson_or_right_comb c -> Format.asprintf "michelson_or_right_comb (%a)" f c
| TC_michelson_or_left_comb c -> Format.asprintf "michelson_or_left_comb (%a)" f c
in
fprintf ppf "(type_operator: %s)" s
end

10
src/stages/common/types.ml
View File

@ -61,6 +61,8 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
| TC_map_or_big_map of type_expression * type_expression
| TC_michelson_pair_right_comb of type_expression
| TC_michelson_pair_left_comb of type_expression
| TC_michelson_or_right_comb of type_expression
| TC_michelson_or_left_comb of type_expression
and type_expression = {type_content: type_content; location: Location.t; type_meta: type_meta}
@ -76,6 +78,8 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
| TC_map_or_big_map (x , y)-> TC_map_or_big_map (f x , f y)
| TC_michelson_pair_right_comb c -> TC_michelson_pair_right_comb (f c)
| TC_michelson_pair_left_comb c -> TC_michelson_pair_left_comb (f c)
| TC_michelson_or_right_comb c -> TC_michelson_or_right_comb (f c)
| TC_michelson_or_left_comb c -> TC_michelson_or_left_comb (f c)
let bind_map_type_operator f = function
TC_contract x -> let%bind x = f x in ok @@ TC_contract x
@ -87,6 +91,8 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
| TC_map_or_big_map (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_map_or_big_map (x , y)
| TC_michelson_pair_right_comb c -> let%bind c = f c in ok @@ TC_michelson_pair_right_comb c
| TC_michelson_pair_left_comb c -> let%bind c = f c in ok @@ TC_michelson_pair_left_comb c
| TC_michelson_or_right_comb c -> let%bind c = f c in ok @@ TC_michelson_or_right_comb c
| TC_michelson_or_left_comb c -> let%bind c = f c in ok @@ TC_michelson_or_left_comb c
let type_operator_name = function
TC_contract _ -> "TC_contract"
@ -98,6 +104,8 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
| TC_map_or_big_map _ -> "TC_map_or_big_map"
| TC_michelson_pair_right_comb _ -> "TC_michelson_pair_right_comb"
| TC_michelson_pair_left_comb _ -> "TC_michelson_pair_left_comb"
| TC_michelson_or_right_comb _ -> "TC_michelson_or_right_comb"
| TC_michelson_or_left_comb _ -> "TC_michelson_or_left_comb"
let type_expression'_of_string = function
| "TC_contract" , [x] -> ok @@ T_operator(TC_contract x)
@ -137,6 +145,8 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
| TC_map_or_big_map (x , y) -> "TC_map_or_big_map" , [x ; y]
| TC_michelson_pair_right_comb c -> "TC_michelson_pair_right_comb" , [c]
| TC_michelson_pair_left_comb c -> "TC_michelson_pair_left_comb" , [c]
| TC_michelson_or_right_comb c -> "TC_michelson_or_right_comb" , [c]
| TC_michelson_or_left_comb c -> "TC_michelson_or_left_comb" , [c]
let string_of_type_constant = function
| TC_unit -> "TC_unit", []

16
src/test/contracts/michelson_converter_or.mligo
View File

@ -19,3 +19,19 @@ let str4 = Layout.convert_to_right_comb (vst4:st4)
let stl3 = Layout.convert_to_left_comb (vst3:st3)
let stl4 = Layout.convert_to_left_comb (vst4:st4)
(*convert from*)
// let s = "eq"
// let test_input_pair_r = (1,(2n,(s,true)))
// let test_input_pair_l = (((1,2n), s), true)
type param_r = st4 michelson_or_right_comb
let main_r (p, s : param_r * string) : (operation list * string) =
// let r4 : t4 = Layout.convert_from_right_comb p in
([] : operation list), "hey"
type param_l = st4 michelson_or_left_comb
let main_l (p, s : param_l * string) : (operation list * string) =
// let r4 : t4 = Layout.convert_from_left_comb p in
([] : operation list), "hey"