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

michelson_right_comb and michelson_left_comb type operators

Browse Source
This commit is contained in:
Lesenechal Remi 2020-04-24 21:47:19 +02:00
parent 3333742037
commit 9d200a1b56
16 changed files with 138 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
src/bin/expect_tests/michelson_converter.ml
View File

@ -42,4 +42,17 @@ let%expect_test _ =
( ( 2 , +3 ) , "q" ) |}] ;
run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter.mligo") ; "l4"] ;
[%expect {|
( ( ( 2 , +3 ) , "q" ) , true ) |}] ;
( ( ( 2 , +3 ) , "q" ) , true ) |}]
let%expect_test _ =
run_ligo_good [ "compile-contract" ; contract "michelson_comb_type_operators.mligo" ; "main_r"] ;
[%expect {|
{ parameter (pair (int %foo) (pair (nat %bar) (string %baz))) ;
storage unit ;
code { UNIT ; NIL operation ; PAIR ; DIP { DROP } } } |}] ;
run_ligo_good [ "compile-contract" ; contract "michelson_comb_type_operators.mligo" ; "main_l"] ;
[%expect {|
{ parameter (pair (pair (int %foo) (nat %bar)) (string %baz)) ;
storage unit ;
code { UNIT ; NIL operation ; PAIR ; DIP { DROP } } } |}]

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

@ -201,6 +201,12 @@ and compile_type_operator : I.type_operator -> O.type_operator result =
let%bind (k,v) = bind_map_pair compile_type_expression (k,v) in
ok @@ O.TC_big_map (k,v)
| TC_michelson_or _ | TC_michelson_pair _ -> fail @@ Errors.corner_case __LOC__
| TC_michelson_right_comb c ->
let%bind c = compile_type_expression c in
ok @@ O.TC_michelson_right_comb c
| TC_michelson_left_comb c ->
let%bind c = compile_type_expression c in
ok @@ O.TC_michelson_left_comb c
let rec compile_expression : I.expression -> O.expression result =
fun e ->
@ -640,6 +646,12 @@ and uncompile_type_operator : O.type_operator -> I.type_operator result =
| TC_big_map (k,v) ->
let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in
ok @@ I.TC_big_map (k,v)
| TC_michelson_right_comb c ->
let%bind c = uncompile_type_expression c in
ok @@ I.TC_michelson_right_comb c
| TC_michelson_left_comb c ->
let%bind c = uncompile_type_expression c in
ok @@ I.TC_michelson_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

@ -66,6 +66,12 @@ and idle_type_operator : I.type_operator -> O.type_operator result =
| TC_big_map (k,v) ->
let%bind (k,v) = bind_map_pair idle_type_expression (k,v) in
ok @@ O.TC_big_map (k,v)
| TC_michelson_right_comb c ->
let%bind c = idle_type_expression c in
ok @@ O.TC_michelson_right_comb c
| TC_michelson_left_comb c ->
let%bind c = idle_type_expression c in
ok @@ O.TC_michelson_left_comb c
let rec compile_expression : I.expression -> O.expression result =
fun e ->
@ -288,6 +294,12 @@ and uncompile_type_operator : O.type_operator -> I.type_operator result =
let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in
ok @@ I.TC_big_map (k,v)
| TC_map_or_big_map _ -> failwith "TC_map_or_big_map shouldn't be uncompiled"
| TC_michelson_right_comb c ->
let%bind c = uncompile_type_expression c in
ok @@ I.TC_michelson_right_comb c
| TC_michelson_left_comb c ->
let%bind c = uncompile_type_expression c in
ok @@ I.TC_michelson_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,6 +181,9 @@ 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_right_comb _c | TC_michelson_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
return (T_operator (opt))

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

@ -106,6 +106,8 @@ let rec type_expression_to_type_value_copypasted : I.type_expression -> O.type_v
| TC_big_map ( k , v ) -> (C_big_map, [k;v])
| TC_map_or_big_map ( k , v) -> (C_map, [k;v])
| TC_contract c -> (C_contract, [c])
| TC_michelson_right_comb c -> (C_record, [c])
| TC_michelson_left_comb c -> (C_record, [c])
)
in
p_constant csttag (List.map type_expression_to_type_value_copypasted args)

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

@ -12,6 +12,14 @@ module Solver = Typer_new.Solver
type environment = Environment.t
module Errors = struct
let michelson_comb_no_record (loc:Location.t) () =
let title = (thunk "bad michelson_right_comb type parameter") in
let message () = "michelson_right_comb type operator must be used on a record 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
@ -623,34 +631,46 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
ok tv
| T_constant cst ->
return (T_constant (convert_type_constant cst))
| T_operator opt ->
let%bind opt = match opt with
| T_operator opt -> ( match opt with
| TC_set s ->
let%bind s = evaluate_type e s in
ok @@ O.TC_set (s)
return @@ T_operator (O.TC_set (s))
| TC_option o ->
let%bind o = evaluate_type e o in
ok @@ O.TC_option (o)
return @@ T_operator (O.TC_option (o))
| TC_list l ->
let%bind l = evaluate_type e l in
ok @@ O.TC_list (l)
return @@ T_operator (O.TC_list (l))
| TC_map (k,v) ->
let%bind k = evaluate_type e k in
let%bind v = evaluate_type e v in
ok @@ O.TC_map {k;v}
return @@ T_operator (O.TC_map {k;v})
| TC_big_map (k,v) ->
let%bind k = evaluate_type e k in
let%bind v = evaluate_type e v in
ok @@ O.TC_big_map {k;v}
return @@ T_operator (O.TC_big_map {k;v})
| TC_map_or_big_map (k,v) ->
let%bind k = evaluate_type e k in
let%bind v = evaluate_type e v in
ok @@ O.TC_map_or_big_map {k;v}
return @@ T_operator (O.TC_map_or_big_map {k;v})
| TC_contract c ->
let%bind c = evaluate_type e c in
ok @@ O.TC_contract c
in
return (T_operator (opt))
return @@ T_operator (O.TC_contract c)
| TC_michelson_right_comb c ->
let%bind c' = evaluate_type e c in
let%bind lmap = match c'.type_content with
| T_record lmap when (not (Ast_typed.Helpers.is_tuple_lmap lmap)) -> ok lmap
| _ -> fail (michelson_comb_no_record t.location) in
let record = Operators.Typer.Converter.convert_type_to_right_comb (Ast_typed.LMap.to_kv_list lmap) in
return @@ record
| TC_michelson_left_comb c ->
let%bind c' = evaluate_type e c in
let%bind lmap = match c'.type_content with
| T_record lmap when (not (Ast_typed.Helpers.is_tuple_lmap lmap)) -> ok lmap
| _ -> fail (michelson_comb_no_record t.location) in
let record = Operators.Typer.Converter.convert_type_to_left_comb (Ast_typed.LMap.to_kv_list lmap) in
return @@ record
)
and type_expression : environment -> O.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O.typer_state) result
= fun e _placeholder_for_state_of_new_typer ?tv_opt ae ->

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

@ -58,8 +58,9 @@ module Concrete_to_imperative = struct
| "set" -> Some (TC_set unit_expr)
| "map" -> Some (TC_map (unit_expr,unit_expr))
| "big_map" -> Some (TC_big_map (unit_expr,unit_expr))
| "michelson_or" -> Some (TC_michelson_or (unit_expr,"",unit_expr,""))
| "contract" -> Some (TC_contract unit_expr)
| "michelson_right_comb" -> Some (TC_michelson_right_comb unit_expr)
| "michelson_left_comb" -> Some (TC_michelson_left_comb unit_expr)
| _ -> None
let pseudo_modules = function
@ -425,6 +426,8 @@ module Typer = struct
open Helpers.Typer
open Ast_typed
module Converter = Converter
module Operators_types = struct
open Typesystem.Shorthands

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

@ -171,6 +171,15 @@ module Typer : sig
val cons : typer
val constant_typers : constant' -> typer result
module Converter : sig
open Ast_typed
val record_checks : (label * field_content) list -> unit result
val convert_type_to_right_comb : (label * field_content) list -> type_content
val convert_type_to_left_comb : (label * field_content) list -> type_content
end
end
module Compiler : sig

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

@ -61,6 +61,8 @@ and type_operator :
| TC_big_map (k, v) -> Format.asprintf "Big Map (%a,%a)" f k f v
| TC_michelson_or (l,_, r,_) -> Format.asprintf "Michelson_or (%a,%a)" f l f r
| TC_michelson_pair (l,_, r,_) -> Format.asprintf "Michelson_pair (%a,%a)" f l f r
| TC_michelson_right_comb e -> Format.asprintf "Michelson_right_comb (%a)" f e
| TC_michelson_left_comb e -> Format.asprintf "Michelson_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

@ -63,6 +63,8 @@ let t_set ?loc key : type_expression = make_t ?loc @@ T_operator (
let t_contract ?loc contract : type_expression = make_t ?loc @@ T_operator (TC_contract contract)
let t_michelson_or ?loc l l_ann r r_ann : type_expression = make_t ?loc @@ T_operator (TC_michelson_or (l, l_ann, r, r_ann))
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_right_comb ?loc c : type_expression = make_t ?loc @@ T_operator (TC_michelson_right_comb c)
let t_michelson_left_comb ?loc c : type_expression = make_t ?loc @@ T_operator (TC_michelson_left_comb c)
(* TODO find a better way than using list*)
let t_operator ?loc op lst: type_expression result =
@ -74,6 +76,8 @@ let t_operator ?loc op lst: type_expression result =
| TC_big_map (_,_) , [kt;vt] -> ok @@ t_big_map ?loc kt vt
| TC_michelson_or (_,l_ann,_,r_ann) , [l;r] -> ok @@ t_michelson_or ?loc l l_ann r r_ann
| TC_contract _ , [t] -> ok @@ t_contract t
| TC_michelson_right_comb _ , [c] -> ok @@ t_michelson_right_comb c
| TC_michelson_left_comb _ , [c] -> ok @@ t_michelson_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

@ -28,6 +28,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_right_comb of type_expression
| TC_michelson_left_comb of type_expression
and type_expression = {type_content: type_content; location: Location.t}

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

@ -52,6 +52,8 @@ and type_operator : (formatter -> type_expression -> unit) -> formatter -> type_
| TC_map (k, v) -> Format.asprintf "Map (%a,%a)" f k f v
| TC_big_map (k, v) -> Format.asprintf "Big Map (%a,%a)" f k f v
| TC_contract te -> Format.asprintf "Contract (%a)" f te
| TC_michelson_right_comb c -> Format.asprintf "michelson_right_comb (%a)" f c
| TC_michelson_left_comb c -> Format.asprintf "michelson_left_comb (%a)" f c
in
fprintf ppf "(TO_%s)" s

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

@ -30,6 +30,8 @@ and type_operator =
| TC_set of type_expression
| TC_map of type_expression * type_expression
| TC_big_map of type_expression * type_expression
| TC_michelson_right_comb of type_expression
| TC_michelson_left_comb of type_expression
and type_expression = {type_content: type_content; location: Location.t}

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

@ -252,6 +252,8 @@ module Ast_PP_type (PARAMETER : AST_PARAMETER_TYPE) = struct
| TC_big_map (k, v) -> Format.asprintf "Big Map (%a,%a)" f k f v
| TC_map_or_big_map (k, v) -> Format.asprintf "Map Or Big Map (%a,%a)" f k f v
| TC_contract te -> Format.asprintf "Contract (%a)" f te
| TC_michelson_right_comb c -> Format.asprintf "Michelson_right_comb (%a)" f c
| TC_michelson_left_comb c -> Format.asprintf "Michelson_left_comb (%a)" f c
in
fprintf ppf "(type_operator: %s)" s
end

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

@ -59,6 +59,8 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
| TC_map of type_expression * type_expression
| TC_big_map of type_expression * type_expression
| TC_map_or_big_map of type_expression * type_expression
| TC_michelson_right_comb of type_expression
| TC_michelson_left_comb of type_expression
and type_expression = {type_content: type_content; location: Location.t; type_meta: type_meta}
@ -72,6 +74,8 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
| TC_map (x , y) -> TC_map (f x , f y)
| TC_big_map (x , y)-> TC_big_map (f x , f y)
| TC_map_or_big_map (x , y)-> TC_map_or_big_map (f x , f y)
| TC_michelson_right_comb c -> TC_michelson_right_comb (f c)
| TC_michelson_left_comb c -> TC_michelson_left_comb (f c)
let bind_map_type_operator f = function
TC_contract x -> let%bind x = f x in ok @@ TC_contract x
@ -81,6 +85,8 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
| TC_map (x , y) -> let%bind x = f x in let%bind y = f y in ok @@ TC_map (x , y)
| TC_big_map (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_big_map (x , y)
| 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_right_comb c -> let%bind c = f c in ok @@ TC_michelson_right_comb c
| TC_michelson_left_comb c -> let%bind c = f c in ok @@ TC_michelson_left_comb c
let type_operator_name = function
TC_contract _ -> "TC_contract"
@ -90,6 +96,8 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
| TC_map _ -> "TC_map"
| TC_big_map _ -> "TC_big_map"
| TC_map_or_big_map _ -> "TC_map_or_big_map"
| TC_michelson_right_comb _ -> "TC_michelson_right_comb"
| TC_michelson_left_comb _ -> "TC_michelson_left_comb"
let type_expression'_of_string = function
| "TC_contract" , [x] -> ok @@ T_operator(TC_contract x)
@ -127,6 +135,8 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
| TC_map (x , y) -> "TC_map" , [x ; y]
| TC_big_map (x , y) -> "TC_big_map" , [x ; y]
| TC_map_or_big_map (x , y) -> "TC_map_or_big_map" , [x ; y]
| TC_michelson_right_comb c -> "TC_michelson_right_comb" , [c]
| TC_michelson_left_comb c -> "TC_michelson_left_comb" , [c]
let string_of_type_constant = function
| TC_unit -> "TC_unit", []

10
src/test/contracts/michelson_comb_type_operators.mligo Normal file
View File

@ -0,0 +1,10 @@
type t3 = { foo : int ; bar : nat ; baz : string}
type param_r = t3 michelson_right_comb
type param_l = t3 michelson_left_comb
let main_r (action, store : param_r * unit) : (operation list * unit) =
([] : operation list), unit
let main_l (action, store : param_l * unit) : (operation list * unit) =
([] : operation list), unit