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

Converters for michelson types

Browse Source
This commit is contained in:
Lesenechal Remi 2020-04-22 19:44:21 +02:00
parent 82b3d634c1
commit 3333742037
35 changed files with 321 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
src/bin/expect_tests/michelson_converter.ml Normal file
View File

@ -0,0 +1,45 @@
open Cli_expect
let contract basename =
"../../test/contracts/" ^ basename
let bad_contract basename =
"../../test/contracts/negative/" ^ basename
let%expect_test _ =
run_ligo_bad [ "interpret" ; "--init-file="^(bad_contract "michelson_converter_no_annotation.mligo") ; "l4"] ;
[%expect {|
ligo: in file "michelson_converter_no_annotation.mligo", line 4, characters 9-39. can't retrieve declaration order in the converted record, you need to annotate it
If you're not sure how to fix this error, you can
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt
* Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new
* Check the changelog by running 'ligo changelog' |}] ;
run_ligo_bad [ "interpret" ; "--init-file="^(bad_contract "michelson_converter_short_record.mligo") ; "l1"] ;
[%expect {|
ligo: in file "michelson_converter_short_record.mligo", line 4, characters 9-44. converted record must have at least two elements
If you're not sure how to fix this error, you can
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt
* Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new
* Check the changelog by running 'ligo changelog' |}]
let%expect_test _ =
run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter.mligo") ; "r3"] ;
[%expect {|
( 2 , ( +3 , "q" ) ) |}] ;
run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter.mligo") ; "r4"] ;
[%expect {|
( 2 , ( +3 , ( "q" , true ) ) ) |}] ;
run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter.mligo") ; "l3"] ;
[%expect {|
( ( 2 , +3 ) , "q" ) |}] ;
run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter.mligo") ; "l4"] ;
[%expect {|
( ( ( 2 , +3 ) , "q" ) , true ) |}] ;

2
src/passes/10-transpiler/transpiler.ml
View File

@ -228,6 +228,8 @@ let transpile_constant' : AST.constant' -> constant' = function
| C_IMPLICIT_ACCOUNT -> C_IMPLICIT_ACCOUNT
| C_SET_DELEGATE -> C_SET_DELEGATE
| C_CREATE_CONTRACT -> C_CREATE_CONTRACT
| C_CONVERT_TO_LEFT_COMB -> C_CONVERT_TO_LEFT_COMB
| C_CONVERT_TO_RIGHT_COMB -> C_CONVERT_TO_RIGHT_COMB
let rec transpile_type (t:AST.type_expression) : type_value result =
match t.type_content with

2
src/passes/10-transpiler/untranspiler.ml
View File

@ -236,6 +236,8 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul
| Empty -> fail @@ corner_case ~loc:__LOC__ "empty record"
| Full t -> ok t in
let%bind lst =
(* let () = Format.printf "\n%a\n" Ast_typed.PP.type_expression t in
let () = Format.printf "\n%a\n" Mini_c.PP.value v in *)
trace_strong (corner_case ~loc:__LOC__ "record extract") @@
extract_record v node in
let%bind lst = bind_list

4
src/passes/2-concrete_to_imperative/cameligo.ml
View File

@ -294,14 +294,16 @@ and compile_type_expression : Raw.type_expr -> type_expression result = fun te -
| TRecord r ->
let (r, loc) = r_split r in
let aux = fun (x, y) -> let%bind y = compile_type_expression y in ok (x, y) in
let order = fun i (x,y) -> ((x,i),y) in
let apply (x:Raw.field_decl Raw.reg) =
(x.value.field_name.value, x.value.field_type) in
let%bind lst =
bind_list
@@ List.map aux
@@ List.mapi order
@@ List.map apply
@@ npseq_to_list r.ne_elements in
let m = List.fold_left (fun m (x, y) -> LMap.add (Label x) y m) LMap.empty lst in
let m = List.fold_left (fun m ((x,i), y) -> LMap.add (Label x) {field_type=y;decl_position=i} m) LMap.empty lst in
ok @@ make_t ~loc @@ T_record m
| TSum s ->
let (s,loc) = r_split s in

6
src/passes/2-concrete_to_imperative/pascaligo.ml
View File

@ -224,13 +224,17 @@ let rec compile_type_expression (t:Raw.type_expr) : type_expression result =
let%bind y = compile_type_expression y in
ok (x, y)
in
let order = fun i (x,y) ->
((x,i),y)
in
let apply =
fun (x:Raw.field_decl Raw.reg) -> (x.value.field_name.value, x.value.field_type) in
let%bind lst = bind_list
@@ List.map aux
@@ List.mapi order
@@ List.map apply
@@ npseq_to_list r.ne_elements in
let m = List.fold_left (fun m (x, y) -> LMap.add (Label x) y m) LMap.empty lst in
let m = List.fold_left (fun m ((x,i), y) -> LMap.add (Label x) {field_type=y;decl_position=i} m) LMap.empty lst in
ok @@ make_t ~loc @@ T_record m
| TSum s ->
let (s,loc) = r_split s in

9
src/passes/3-self_ast_imperative/helpers.ml
View File

@ -2,6 +2,13 @@ open Ast_imperative
open Trace
open Stage_common.Helpers
let bind_map_lmap_t f map = bind_lmap (
LMap.map
(fun ({field_type;_} as field) ->
let%bind field_type = f field_type in
ok {field with field_type })
map)
type 'a folder = 'a -> expression -> 'a result
let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f init e ->
let self = fold_expression f in
@ -253,7 +260,7 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re
let%bind temap' = bind_map_cmap self temap in
return @@ (T_sum temap')
| T_record temap ->
let%bind temap' = bind_map_lmap self temap in
let%bind temap' = bind_map_lmap_t self temap in
return @@ (T_record temap')
| T_tuple telst ->
let%bind telst' = bind_map_list self telst in

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

@ -145,9 +145,9 @@ let rec compile_type_expression : I.type_expression -> O.type_expression result
| I.T_record record ->
let record = I.LMap.to_kv_list record in
let%bind record =
bind_map_list (fun (k,v) ->
bind_map_list (fun (k, ({field_type = v; decl_position ; _}:I.field_content)) ->
let%bind v = compile_type_expression v in
let content : O.field_content = {field_type = v ; michelson_annotation = None} in
let content : O.field_content = {field_type = v; michelson_annotation = None ; decl_position} in
ok @@ (k,content)
) record
in
@ -171,8 +171,8 @@ let rec compile_type_expression : I.type_expression -> O.type_expression result
| I.T_operator (TC_michelson_pair (l,l_ann,r,r_ann)) ->
let%bind (l,r) = bind_map_pair compile_type_expression (l,r) in
let sum : (O.label * O.field_content) list = [
(O.Label "0" , {field_type = l ; michelson_annotation = Some l_ann});
(O.Label "1", {field_type = r ; michelson_annotation = Some r_ann}); ]
(O.Label "0" , {field_type = l ; michelson_annotation = Some l_ann ; decl_position = 0});
(O.Label "1", {field_type = r ; michelson_annotation = Some r_ann ; decl_position = 0}); ]
in
return @@ O.T_record (O.LMap.of_list sum)
| I.T_operator type_operator ->
@ -600,9 +600,9 @@ let rec uncompile_type_expression : O.type_expression -> I.type_expression resul
let record = I.LMap.to_kv_list record in
let%bind record =
bind_map_list (fun (k,v) ->
let {field_type;_} : O.field_content = v in
let {field_type;decl_position} : O.field_content = v in
let%bind v = uncompile_type_expression field_type in
ok @@ (k,v)
ok @@ (k,({field_type=v;decl_position}:I.field_content))
) record
in
return @@ I.T_record (O.LMap.of_list record)

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

@ -21,9 +21,9 @@ let rec idle_type_expression : I.type_expression -> O.type_expression result =
let record = I.LMap.to_kv_list record in
let%bind record =
bind_map_list (fun (k,v) ->
let {field_type ; michelson_annotation} : I.field_content = v in
let {field_type ; michelson_annotation ; decl_position} : I.field_content = v in
let%bind field_type = idle_type_expression field_type in
let v' : O.field_content = {field_type ; field_annotation=michelson_annotation} in
let v' : O.field_content = {field_type ; field_annotation=michelson_annotation ; decl_position} in
ok @@ (k,v')
) record
in
@ -31,7 +31,7 @@ let rec idle_type_expression : I.type_expression -> O.type_expression result =
| I.T_tuple tuple ->
let aux (i,acc) el =
let%bind el = idle_type_expression el in
ok @@ (i+1,(O.Label (string_of_int i), ({field_type=el;field_annotation=None}:O.field_content))::acc) in
ok @@ (i+1,(O.Label (string_of_int i), ({field_type=el;field_annotation=None;decl_position=0}:O.field_content))::acc) in
let%bind (_, lst ) = bind_fold_list aux (0,[]) tuple in
let record = O.LMap.of_list lst in
return @@ O.T_record record
@ -249,9 +249,9 @@ let rec uncompile_type_expression : O.type_expression -> I.type_expression resul
let record = I.LMap.to_kv_list record in
let%bind record =
bind_map_list (fun (k,v) ->
let {field_type;field_annotation} : O.field_content = v in
let {field_type;field_annotation;decl_position} : O.field_content = v in
let%bind field_type = uncompile_type_expression field_type in
let v' : I.field_content = {field_type;michelson_annotation=field_annotation} in
let v' : I.field_content = {field_type ; michelson_annotation=field_annotation ; decl_position} in
ok @@ (k,v')
) record
in

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

@ -133,3 +133,5 @@ let convert_constant' : I.constant' -> O.constant' = function
| C_IMPLICIT_ACCOUNT -> C_IMPLICIT_ACCOUNT
| C_SET_DELEGATE -> C_SET_DELEGATE
| C_CREATE_CONTRACT -> C_CREATE_CONTRACT
| C_CONVERT_TO_LEFT_COMB -> C_CONVERT_TO_LEFT_COMB
| C_CONVERT_TO_RIGHT_COMB -> C_CONVERT_TO_RIGHT_COMB

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

@ -142,9 +142,9 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
| T_record m ->
let aux k v prev =
let%bind prev' = prev in
let {field_type ; field_annotation} : I.field_content = v in
let {field_type ; field_annotation ; decl_position} : I.field_content = v in
let%bind field_type = evaluate_type e field_type in
ok @@ O.LMap.add (convert_label k) ({field_type ; michelson_annotation=field_annotation}:O.field_content) prev'
ok @@ O.LMap.add (convert_label k) ({field_type ; michelson_annotation=field_annotation ; decl_position}:O.field_content) prev'
in
let%bind m = I.LMap.fold aux m (ok O.LMap.empty) in
return (T_record m)
@ -300,7 +300,7 @@ and type_expression : environment -> O.typer_state -> ?tv_opt:O.type_expression
ok (O.LMap.add (convert_label k) expr' acc , state')
in
let%bind (m' , state') = Stage_common.Helpers.bind_fold_lmap aux (ok (O.LMap.empty , state)) m in
let wrapped = Wrap.record (O.LMap.map (fun e -> ({field_type = get_type_expression e ; michelson_annotation = None}: O.field_content)) m') in
let wrapped = Wrap.record (O.LMap.map (fun e -> ({field_type = get_type_expression e ; michelson_annotation = None ; decl_position = 0}: O.field_content)) m') in
return_wrapped (E_record m') state' wrapped
| E_record_update {record; path; update} ->
let%bind (record, state) = type_expression e state record in

6
src/passes/8-typer-new/untyper.ml
View File

@ -135,6 +135,8 @@ let unconvert_constant' : O.constant' -> I.constant' = function
| C_IMPLICIT_ACCOUNT -> C_IMPLICIT_ACCOUNT
| C_SET_DELEGATE -> C_SET_DELEGATE
| C_CREATE_CONTRACT -> C_CREATE_CONTRACT
| C_CONVERT_TO_LEFT_COMB -> C_CONVERT_TO_LEFT_COMB
| C_CONVERT_TO_RIGHT_COMB -> C_CONVERT_TO_RIGHT_COMB
let untype_type_value (t:O.type_expression) : (I.type_expression) result =
match t.type_meta with
@ -156,10 +158,10 @@ let rec untype_type_expression (t:O.type_expression) : (I.type_expression) resul
let%bind x' = O.CMap.fold aux x (ok I.CMap.empty) in
ok @@ I.T_sum x'
| O.T_record x ->
let aux k ({field_type ; michelson_annotation} : O.field_content) acc =
let aux k ({field_type ; michelson_annotation ; decl_position} : O.field_content) acc =
let%bind acc = acc in
let%bind field_type = untype_type_expression field_type in
let v' = ({field_type ; field_annotation=michelson_annotation} : I.field_content) in
let v' = ({field_type ; field_annotation=michelson_annotation ; decl_position} : I.field_content) in
ok @@ I.LMap.add (unconvert_label k) v' acc in
let%bind x' = O.LMap.fold aux x (ok I.LMap.empty) in
ok @@ I.T_record x'

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

@ -350,6 +350,8 @@ let convert_constant' : I.constant' -> O.constant' = function
| C_IMPLICIT_ACCOUNT -> C_IMPLICIT_ACCOUNT
| C_SET_DELEGATE -> C_SET_DELEGATE
| C_CREATE_CONTRACT -> C_CREATE_CONTRACT
| C_CONVERT_TO_LEFT_COMB -> C_CONVERT_TO_LEFT_COMB
| C_CONVERT_TO_RIGHT_COMB -> C_CONVERT_TO_RIGHT_COMB
let unconvert_constant' : O.constant' -> I.constant' = function
| C_INT -> C_INT
@ -465,6 +467,8 @@ let unconvert_constant' : O.constant' -> I.constant' = function
| C_IMPLICIT_ACCOUNT -> C_IMPLICIT_ACCOUNT
| C_SET_DELEGATE -> C_SET_DELEGATE
| C_CREATE_CONTRACT -> C_CREATE_CONTRACT
| C_CONVERT_TO_LEFT_COMB -> C_CONVERT_TO_LEFT_COMB
| C_CONVERT_TO_RIGHT_COMB -> C_CONVERT_TO_RIGHT_COMB
let rec type_program (p:I.program) : (O.program * O.typer_state) result =
let aux (e, acc:(environment * O.declaration Location.wrap list)) (d:I.declaration Location.wrap) =
@ -604,10 +608,10 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
let%bind m = I.CMap.fold aux m (ok O.CMap.empty) in
return (T_sum m)
| T_record m ->
let aux k ({field_type;field_annotation}: I.field_content) prev =
let aux k ({field_type;field_annotation;decl_position}: I.field_content) prev =
let%bind prev' = prev in
let%bind field_type = evaluate_type e field_type in
let v' = ({field_type;michelson_annotation=field_annotation} : O.field_content) in
let v' = ({field_type;michelson_annotation=field_annotation;decl_position} : O.field_content) in
ok @@ O.LMap.add (convert_label k) v' prev'
in
let%bind m = I.LMap.fold aux m (ok O.LMap.empty) in
@ -759,7 +763,10 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
ok (O.LMap.add (convert_label k) expr' prev)
in
let%bind m' = Stage_common.Helpers.bind_fold_lmap aux (ok O.LMap.empty) m in
let lmap = O.LMap.map (fun e -> ({field_type = get_type_expression e; michelson_annotation = None}:O.field_content)) m' in
(* let () = match tv_opt with
Some _ -> Format.printf "YES"
| None -> Format.printf "NO" in *)
let lmap = O.LMap.map (fun e -> ({field_type = get_type_expression e; michelson_annotation = None; decl_position=0}:O.field_content)) m' in
return (E_record m') (t_record lmap ())
| E_record_update {record; path; update} ->
let path = convert_label path in

62
src/passes/9-self_ast_typed/michelson_layout.ml Normal file
View File

@ -0,0 +1,62 @@
open Ast_typed
open Trace
let get_label_map_from_env (v:expression_variable) (env: full_environment) : expression_label_map result =
let%bind a = trace_option (simple_error "corner case") @@
Environment.get_opt v env in
( match a.definition with
| ED_declaration { expr = {expression_content = E_record lmap_e;_} ; _} -> ok lmap_e
| _ -> simple_fail "corner case" )
let rec to_right_comb_e l new_map =
match l with
| [] -> new_map
| [ (_, expl) ; (_ , expr) ] ->
LMap.add_bindings [ (Label "0" , expl) ; (Label "1" , expr) ] new_map
| (_, exp)::tl ->
let new_map' = LMap.add (Label "0") exp new_map in
LMap.add (Label "1") ({exp with expression_content = E_record (to_right_comb_e tl new_map')}) new_map'
let rec to_left_comb_e_ first l new_map =
match l with
| [] -> new_map
| (_, expl) :: (_, expr) ::tl when first ->
let new_map' = LMap.add_bindings [ (Label "0" , expl) ; (Label "1" , expr) ] LMap.empty in
to_left_comb_e_ false tl new_map'
| (_,exp)::tl ->
let new_map' = LMap.add_bindings [
(Label "0" , {exp with expression_content = E_record new_map});
(Label "1" , exp ) ;] LMap.empty in
to_left_comb_e_ first tl new_map'
let to_left_comb_e = to_left_comb_e_ true
let to_sorted_kv_list (l_e:expression_label_map) (l_t:te_lmap) : (label * expression) list =
let l = List.combine (LMap.to_kv_list l_e) (LMap.to_kv_list l_t) in
let sorted' = List.sort
(fun (_,(_,{decl_position=a;_})) (_,(_,{decl_position=b;_})) -> Int.compare a b) l in
List.map (fun (e,_t) -> e) sorted'
let peephole_expression : expression -> expression result = fun e ->
let return expression_content = ok { e with expression_content } in
match e.expression_content with
| E_constant {cons_name= (C_CONVERT_TO_RIGHT_COMB | C_CONVERT_TO_LEFT_COMB ) as converter;
arguments= [ {
expression_content = record_exp;
type_expression = {type_content = T_record lmap_t} }
] } ->
let%bind lmap_e = match record_exp with
| E_record lmap_e -> ok lmap_e
| E_variable v -> get_label_map_from_env v e.environment
| _ -> simple_fail "corner case" in
let kvl = to_sorted_kv_list lmap_e lmap_t in
let converted_exp = match converter with
| C_CONVERT_TO_RIGHT_COMB -> E_record (to_right_comb_e kvl LMap.empty)
| C_CONVERT_TO_LEFT_COMB -> E_record (to_left_comb_e kvl LMap.empty)
| _ -> e.expression_content
in
return converted_exp
| _ as e -> return e

3
src/passes/9-self_ast_typed/self_ast_typed.ml
View File

@ -1,7 +1,8 @@
open Trace
let all_passes = [
Tail_recursion.peephole_expression
Tail_recursion.peephole_expression ;
Michelson_layout.peephole_expression ;
]
let contract_passes = [

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

@ -133,6 +133,65 @@ module Typer = struct
type_expression_eq (t_bool () , b) in
ok @@ t_bool ()
module Converter = struct
open Ast_typed
let record_checks kvl =
let%bind () = Assert.assert_true_err
(simple_error "converted record must have at least two elements")
(List.length kvl >=2) in
let all_undefined = List.for_all (fun (_,{decl_position;_}) -> decl_position = 0) kvl in
let%bind () = Assert.assert_true_err
(simple_error "can't retrieve declaration order in the converted record, you need to annotate it")
(not all_undefined) in
ok ()
let annotate_field (field:field_content) (ann:string) : field_content =
{field with michelson_annotation=Some ann}
let comb (t:type_content) : field_content =
let field_type = {
type_content = t ;
type_meta = None ;
location = Location.generated ; } in
{field_type ; michelson_annotation = Some "" ; decl_position = 0}
let rec to_right_comb_t l new_map =
match l with
| [] -> new_map
| [ (Label ann_l, field_content_l) ; (Label ann_r, field_content_r) ] ->
LMap.add_bindings [
(Label "0" , annotate_field field_content_l ann_l) ;
(Label "1" , annotate_field field_content_r ann_r) ] new_map
| (Label ann, field)::tl ->
let new_map' = LMap.add (Label "0") (annotate_field field ann) new_map in
LMap.add (Label "1") (comb (T_record (to_right_comb_t tl new_map'))) new_map'
let rec to_left_comb_t_ first l new_map =
match l with
| [] -> new_map
| (Label ann_l, field_content_l) :: (Label ann_r, field_content_r) ::tl when first ->
let new_map' = LMap.add_bindings [
(Label "0" , annotate_field field_content_l ann_l) ;
(Label "1" , annotate_field field_content_r ann_r) ] LMap.empty in
to_left_comb_t_ false tl new_map'
| (Label ann, field)::tl ->
let new_map' = LMap.add_bindings [
(Label "0" , comb (T_record new_map)) ;
(Label "1" , annotate_field field ann ) ;] LMap.empty in
to_left_comb_t_ first tl new_map'
let to_left_comb_t = to_left_comb_t_ true
let convert_type_to_right_comb l =
let l' = List.sort (fun (_,{decl_position=a;_}) (_,{decl_position=b;_}) -> Int.compare a b) l in
T_record (to_right_comb_t l' LMap.empty)
let convert_type_to_left_comb l =
let l' = List.sort (fun (_,{decl_position=a;_}) (_,{decl_position=b;_}) -> Int.compare a b) l in
T_record (to_left_comb_t l' LMap.empty)
end
end
module Compiler = struct

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

@ -53,6 +53,15 @@ module Typer : sig
val comparator : string -> typer
val boolean_operator_2 : string -> typer
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

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

@ -156,6 +156,12 @@ module Concrete_to_imperative = struct
| "String.sub" -> Some C_SLICE
| "String.concat" -> Some C_CONCAT
(* michelson pair/or type converter module *)
| "Layout.convert_to_right_comb" -> Some C_CONVERT_TO_RIGHT_COMB
| "Layout.convert_to_left_comb" -> Some C_CONVERT_TO_LEFT_COMB
(* | "Layout.convert_from" -> Some C_CONVERT_FROM *)
| _ -> None
@ -271,6 +277,9 @@ module Concrete_to_imperative = struct
| "assert" -> Some C_ASSERTION
| "size" -> Some C_SIZE (* Deprecated *)
| "Layout.convert_to_right_comb" -> Some C_CONVERT_TO_RIGHT_COMB
| "Layout.convert_to_left_comb" -> Some C_CONVERT_TO_LEFT_COMB
| _ as c -> pseudo_modules c
@ -1155,6 +1164,20 @@ module Typer = struct
let%bind () = assert_eq_1 hd elt in
ok tl
let convert_to_right_comb = typer_1 "CONVERT_TO_RIGHT_COMB" @@ fun record ->
let%bind lmap = get_t_record record in
let kvl = LMap.to_kv_list lmap in
let%bind () = Converter.record_checks kvl in
let pair = Converter.convert_type_to_right_comb kvl in
ok {record with type_content = pair}
let convert_to_left_comb = typer_1 "CONVERT_TO_LEFT_COMB" @@ fun record ->
let%bind lmap = get_t_record record in
let kvl = LMap.to_kv_list lmap in
let%bind () = Converter.record_checks kvl in
let pair = Converter.convert_type_to_left_comb kvl in
ok {record with type_content = pair}
let constant_typers c : typer result = match c with
| C_INT -> ok @@ int ;
| C_UNIT -> ok @@ unit ;
@ -1247,6 +1270,8 @@ module Typer = struct
| C_IMPLICIT_ACCOUNT -> ok @@ implicit_account;
| C_SET_DELEGATE -> ok @@ set_delegate ;
| C_CREATE_CONTRACT -> ok @@ create_contract ;
| C_CONVERT_TO_RIGHT_COMB -> ok @@ convert_to_right_comb ;
| C_CONVERT_TO_LEFT_COMB -> ok @@ convert_to_left_comb ;
| _ -> simple_fail @@ Format.asprintf "Typer not implemented for consant %a" PP.constant c

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

@ -13,6 +13,12 @@ let cmap_sep value sep ppf m =
let cmap_sep_d x = cmap_sep x (tag " ,@ ")
let record_sep_t value sep ppf (m : 'a label_map) =
let lst = LMap.to_kv_list m in
let lst = List.sort_uniq (fun (Label a,_) (Label b,_) -> String.compare a b) lst in
let new_pp ppf (k, {field_type=v;_}) = fprintf ppf "@[<h>%a -> %a@]" label k value v in
fprintf ppf "%a" (list_sep new_pp sep) lst
let record_sep value sep ppf (m : 'a label_map) =
let lst = LMap.to_kv_list m in
let lst = List.sort_uniq (fun (Label a,_) (Label b,_) -> String.compare a b) lst in
@ -30,7 +36,7 @@ let rec type_expression' :
fun f ppf te ->
match te.type_content with
| T_sum m -> fprintf ppf "sum[%a]" (cmap_sep_d f) m
| T_record m -> fprintf ppf "{%a}" (record_sep f (const ";")) m
| T_record m -> fprintf ppf "{%a}" (record_sep_t f (const ";")) m
| T_tuple t -> fprintf ppf "(%a)" (list_sep_d f) t
| T_arrow a -> fprintf ppf "%a -> %a" f a.type1 f a.type2
| T_variable tv -> type_variable ppf tv

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

@ -38,7 +38,7 @@ let t_option ?loc o : type_expression = make_t ?loc @@ T_operator (TC_opti
let t_list ?loc t : type_expression = make_t ?loc @@ T_operator (TC_list t)
let t_variable ?loc n : type_expression = make_t ?loc @@ T_variable (Var.of_name n)
let t_record_ez ?loc lst =
let lst = List.map (fun (k, v) -> (Label k, v)) lst in
let lst = List.mapi (fun i (k, v) -> (Label k, {field_type=v;decl_position=i})) lst in
let m = LMap.of_list lst in
make_t ?loc @@ T_record m
let t_record ?loc m : type_expression =

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

@ -6,7 +6,7 @@ include Stage_common.Types
type type_content =
| T_sum of type_expression constructor_map
| T_record of type_expression label_map
| T_record of field_content label_map
| T_tuple of type_expression list
| T_arrow of arrow
| T_variable of type_variable
@ -15,6 +15,8 @@ type type_content =
and arrow = {type1: type_expression; type2: type_expression}
and field_content = {field_type :type_expression ; decl_position : int}
and michelson_prct_annotation = string
and type_operator =

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

@ -52,8 +52,8 @@ let t_record ?loc m : type_expression =
t_record_ez ?loc lst
let t_pair ?loc (a , b) : type_expression = t_record_ez ?loc [
("0",{field_type=a;michelson_annotation=None}) ;
("1",{field_type=b;michelson_annotation=None})]
("0",{field_type=a ; michelson_annotation=None ; decl_position=0}) ;
("1",{field_type=b ; michelson_annotation=None ; decl_position=0})]
let t_tuple ?loc lst : type_expression = t_record_ez ?loc (tuple_to_record lst)
let ez_t_sum ?loc (lst:((string * ctor_content) list)) : type_expression =

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

@ -21,7 +21,7 @@ and arrow = {type1: type_expression; type2: type_expression}
and ctor_content = {ctor_type : type_expression ; michelson_annotation : string option}
and field_content = {field_type : type_expression ; michelson_annotation : string option}
and field_content = {field_type : type_expression ; michelson_annotation : string option ; decl_position : int}
and type_operator =
| TC_contract of type_expression

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

@ -175,6 +175,8 @@ let constant ppf : constant' -> unit = function
| C_IMPLICIT_ACCOUNT -> fprintf ppf "IMPLICIT_ACCOUNT"
| C_SET_DELEGATE -> fprintf ppf "SET_DELEGATE"
| C_CREATE_CONTRACT -> fprintf ppf "CREATE_CONTRACT"
| C_CONVERT_TO_RIGHT_COMB -> fprintf ppf "CONVERT_TO_RIGHT_COMB"
| C_CONVERT_TO_LEFT_COMB -> fprintf ppf "CONVERT_TO_LEFT_COMB"
let literal ppf (l : literal) =
match l with

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

@ -51,15 +51,19 @@ let t_list t ?loc ?s () : type_expression = make_t ?loc (T_operator (TC_list
let t_set t ?loc ?s () : type_expression = make_t ?loc (T_operator (TC_set t)) s
let t_contract t ?loc ?s () : type_expression = make_t ?loc (T_operator (TC_contract t)) s
let t_record m ?loc ?s () : type_expression = make_t ?loc (T_record m) s
let make_t_ez_record ?loc (lst:(string * type_expression) list) : type_expression =
let lst = List.map (fun (x,y) -> (Label x, {field_type=y;michelson_annotation=None}) ) lst in
let lst = List.mapi (fun i (x,y) -> (Label x, {field_type=y;michelson_annotation=None;decl_position=i}) ) lst in
let map = LMap.of_list lst in
make_t ?loc (T_record map) None
let ez_t_record lst ?loc ?s () : type_expression =
let m = LMap.of_list lst in
t_record m ?loc ?s ()
let t_pair a b ?loc ?s () : type_expression = ez_t_record [(Label "0",{field_type=a;michelson_annotation=None}) ; (Label "1",{field_type=b;michelson_annotation=None})] ?loc ?s ()
let t_pair a b ?loc ?s () : type_expression =
ez_t_record [
(Label "0",{field_type=a;michelson_annotation=None ; decl_position = 0}) ;
(Label "1",{field_type=b;michelson_annotation=None ; decl_position = 0}) ] ?loc ?s ()
let t_map ?loc k v ?s () = make_t ?loc (T_operator (TC_map { k ; v })) s
let t_big_map ?loc k v ?s () = make_t ?loc (T_operator (TC_big_map { k ; v })) s
@ -183,7 +187,7 @@ let get_t_function_full (t:type_expression) : (type_expression * type_expression
| _ -> ([],t)
in
let (input,output) = aux 0 t in
let input = List.map (fun (l,t) -> (l,{field_type = t ; michelson_annotation = None})) input in
let input = List.map (fun (l,t) -> (l,{field_type = t ; michelson_annotation = None ; decl_position = 0})) input in
ok @@ (t_record (LMap.of_list input) (),output)
let get_t_sum (t:type_expression) : ctor_content constructor_map result = match t.type_content with
@ -242,6 +246,10 @@ let assert_t_list t =
let%bind _ = get_t_list t in
ok ()
let assert_t_record t =
let%bind _ = get_t_record t in
ok ()
let is_t_list = Function.compose to_bool get_t_list
let is_t_set = Function.compose to_bool get_t_set
let is_t_nat = Function.compose to_bool get_t_nat
@ -324,11 +332,11 @@ let e_a_record r = make_e (e_record r) (t_record
(LMap.map
(fun t ->
let field_type = get_type_expression t in
{field_type ; michelson_annotation=None} )
{field_type ; michelson_annotation=None ; decl_position = 0} )
r ) () )
let e_a_application a b = make_e (e_application a b) (get_type_expression b)
let e_a_variable v ty = make_e (e_variable v) ty
let ez_e_a_record r = make_e (ez_e_record r) (ez_t_record (List.map (fun (x, y) -> x, {field_type = y.type_expression ; michelson_annotation = None}) r) ())
let ez_e_a_record r = make_e (ez_e_record r) (ez_t_record (List.mapi (fun i (x, y) -> x, {field_type = y.type_expression ; michelson_annotation = None ; decl_position = i}) r) ())
let e_a_let_in binder expr body attributes = make_e (e_let_in binder expr body attributes) (get_type_expression body)

1
src/stages/4-ast_typed/combinators.mli
View File

@ -103,6 +103,7 @@ val assert_t_nat : type_expression -> unit result
val assert_t_bool : type_expression -> unit result
val assert_t_unit : type_expression -> unit result
val assert_t_contract : type_expression -> unit result
val assert_t_record : type_expression -> unit result
(*
val e_record : ae_map -> expression
val ez_e_record : ( string * expression ) list -> expression

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

@ -174,7 +174,7 @@ let is_michelson_pair (t: _ label_map) =
LMap.cardinal t = 2 &&
let l = LMap.to_list t in
List.fold_left
(fun prev {field_type=_;michelson_annotation} -> match michelson_annotation with
(fun prev {michelson_annotation;_} -> match michelson_annotation with
| Some _ -> true
| None -> prev)
false

3
src/stages/4-ast_typed/types.ml
View File

@ -45,6 +45,7 @@ and ctor_content = {
and field_content = {
field_type : type_expression;
michelson_annotation : annot_option;
decl_position : int;
}
and type_map_args = {
@ -254,6 +255,8 @@ and constant' =
| C_IMPLICIT_ACCOUNT
| C_SET_DELEGATE
| C_CREATE_CONTRACT
| C_CONVERT_TO_LEFT_COMB
| C_CONVERT_TO_RIGHT_COMB
and declaration_loc = declaration location_wrap

2
src/stages/5-mini_c/PP.ml
View File

@ -248,6 +248,8 @@ and constant ppf : constant' -> unit = function
| C_IMPLICIT_ACCOUNT -> fprintf ppf "IMPLICIT_ACCOUNT"
| C_SET_DELEGATE -> fprintf ppf "SET_DELEGATE"
| C_CREATE_CONTRACT -> fprintf ppf "CREATE_CONTRACT"
| C_CONVERT_TO_RIGHT_COMB -> fprintf ppf "CONVERT_TO_RIGHT_COMB"
| C_CONVERT_TO_LEFT_COMB -> fprintf ppf "CONVERT_TO_LEFT_COMB"
let%expect_test _ =
Format.printf "%a" value (D_bytes (Bytes.of_string "foo")) ;

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

@ -125,6 +125,8 @@ let constant ppf : constant' -> unit = function
| C_IMPLICIT_ACCOUNT -> fprintf ppf "IMPLICIT_ACCOUNT"
| C_SET_DELEGATE -> fprintf ppf "SET_DELEGATE"
| C_CREATE_CONTRACT -> fprintf ppf "CREATE_CONTRACT"
| C_CONVERT_TO_RIGHT_COMB -> fprintf ppf "CONVERT_TO_RIGHT_COMB"
| C_CONVERT_TO_LEFT_COMB -> fprintf ppf "CONVERT_TO_LEFT_COMB"
let literal ppf (l : literal) =
match l with

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

@ -49,7 +49,7 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
and ctor_content = {ctor_type : type_expression ; michelson_annotation : string option}
and field_content = {field_type : type_expression ; field_annotation : string option}
and field_content = {field_type : type_expression ; field_annotation : string option ; decl_position : int}
and type_operator =
| TC_contract of type_expression
@ -294,3 +294,5 @@ and constant' =
| C_IMPLICIT_ACCOUNT
| C_SET_DELEGATE
| C_CREATE_CONTRACT
| C_CONVERT_TO_LEFT_COMB
| C_CONVERT_TO_RIGHT_COMB

11
src/test/contracts/michelson_converter.mligo Normal file
View File

@ -0,0 +1,11 @@
type t3 = { foo : int ; bar : nat ; baz : string}
let v3 = { foo = 2 ; bar = 3n ; baz = "q" }
type t4 = { one: int ; two : nat ; three : string ; four : bool}
let v4 = { one = 2 ; two = 3n ; three = "q" ; four = true }
let r3 = Layout.convert_to_right_comb (v3:t3)
let r4 = Layout.convert_to_right_comb (v4:t4)
let l3 = Layout.convert_to_left_comb (v3:t3)
let l4 = Layout.convert_to_left_comb (v4:t4)

4
src/test/contracts/negative/michelson_converter_no_annotation.mligo Normal file
View File

@ -0,0 +1,4 @@
type t4 = { one: int ; two : nat ; three : string ; four : bool}
let v4 = { one = 2 ; two = 3n ; three = "q" ; four = true }
let l4 = Layout.convert_to_left_comb v4

4
src/test/contracts/negative/michelson_converter_short_record.mligo Normal file
View File

@ -0,0 +1,4 @@
type t1 = { foo : int }
let v1 = { foo = 2 }
let l1 = Layout.convert_to_left_comb (v1:t1)

4
vendors/ligo-utils/simple-utils/trace.ml vendored
View File

@ -752,6 +752,10 @@ module Assert = struct
true -> ok ()
| false -> simple_fail msg
let assert_true_err err = function
| true -> ok ()
| false -> fail err
let assert_equal ?msg expected actual =
assert_true ?msg (expected = actual)

5
vendors/ligo-utils/simple-utils/x_map.ml vendored
View File

@ -6,6 +6,7 @@ module type S = sig
val of_list : (key * 'a) list -> 'a t
val to_list : 'a t -> 'a list
val to_kv_list : 'a t -> (key * 'a) list
val add_bindings : (key * 'a) list -> 'a t -> 'a t
end
module Make(Ord : Map.OrderedType) : S with type key = Ord.t = struct
@ -22,6 +23,10 @@ module Make(Ord : Map.OrderedType) : S with type key = Ord.t = struct
let to_kv_list (t: 'a t) : (key * 'a) list =
let aux k v prev = (k, v) :: prev in
fold aux t []
let add_bindings (kvl:(key * 'a) list) (m:'a t) =
let aux prev (k, v) = add k v prev in
List.fold_left aux m kvl
end
module String = Make(String)