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

Change type_operator

Browse Source
This commit is contained in:
Pierre-Emmanuel Wulfman 2020-06-02 16:43:46 +02:00
parent b29c667901
commit cc615f1c9f
25 changed files with 244 additions and 439 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/bin/expect_tests/contract_tests.ml
View File

@ -1321,7 +1321,7 @@ let%expect_test _ =
let%expect_test _ =
run_ligo_bad [ "compile-contract" ; contract "bad_type_operator.ligo" ; "main" ] ;
[%expect {|
ligo: bad type operator (TO_Map (unit,unit)):
ligo: bad type operator (type_operator: Map (binding)):
If you're not sure how to fix this error, you can
do one of the following:

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

@ -286,7 +286,7 @@ and compile_type_expression : Raw.type_expr -> type_expression result = fun te -
let%bind cst =
trace_option (unknown_predefined_type name) @@
type_operators name.value in
t_operator ~loc cst lst' )
ok @@ t_operator ~loc cst lst' )
)
| TProd p -> (
let%bind tpl = compile_list_type_expression @@ npseq_to_list p.value in

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

@ -213,7 +213,7 @@ let rec compile_type_expression (t:Raw.type_expr) : type_expression result =
let%bind cst =
trace_option (unknown_predefined_type name) @@
type_operators name.value in
t_operator ~loc cst lst)
ok @@ t_operator ~loc cst lst)
| TProd p ->
let%bind tpl = compile_list_type_expression
@@ npseq_to_list p.value in

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

@ -276,6 +276,9 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re
let%bind type1' = self type1 in
let%bind type2' = self type2 in
return @@ (T_arrow {type1=type1' ; type2=type2'})
| T_annoted (ty, str) ->
let%bind ty = self ty in
return @@ T_annoted (ty, str)
| T_operator _
| T_variable _ | T_constant _ -> ok te'

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

@ -161,58 +161,28 @@ let rec compile_type_expression : I.type_expression -> O.type_expression result
return @@ T_arrow {type1;type2}
| I.T_variable type_variable -> return @@ T_variable type_variable
| I.T_constant type_constant -> return @@ T_constant type_constant
| I.T_operator (TC_michelson_or (l,l_ann,r,r_ann)) ->
| I.T_operator (TC_michelson_or, [l;r]) ->
let%bind (l, l_ann) = I.get_t_annoted l in
let%bind (r, r_ann) = I.get_t_annoted r in
let%bind (l,r) = bind_map_pair compile_type_expression (l,r) in
let sum : (O.constructor' * O.ctor_content) list = [
(O.Constructor "M_left" , {ctor_type = l ; michelson_annotation = Some l_ann ; ctor_decl_pos = 0});
(O.Constructor "M_right", {ctor_type = r ; michelson_annotation = Some r_ann ; ctor_decl_pos = 1}); ]
in
return @@ O.T_sum (O.CMap.of_list sum)
| I.T_operator (TC_michelson_pair (l,l_ann,r,r_ann)) ->
| I.T_operator (TC_michelson_pair, [l;r]) ->
let%bind (l, l_ann) = I.get_t_annoted l in
let%bind (r, r_ann) = I.get_t_annoted r in
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 ; field_decl_pos = 0});
(O.Label "1", {field_type = r ; michelson_annotation = Some r_ann ; field_decl_pos = 0}); ]
in
return @@ O.T_record (O.LMap.of_list sum)
| I.T_operator type_operator ->
let%bind type_operator = compile_type_operator type_operator in
return @@ T_operator type_operator
and compile_type_operator : I.type_operator -> O.type_operator result =
fun t_o ->
match t_o with
| TC_contract c ->
let%bind c = compile_type_expression c in
ok @@ O.TC_contract c
| TC_option o ->
let%bind o = compile_type_expression o in
ok @@ O.TC_option o
| TC_list l ->
let%bind l = compile_type_expression l in
ok @@ O.TC_list l
| TC_set s ->
let%bind s = compile_type_expression s in
ok @@ O.TC_set s
| TC_map (k,v) ->
let%bind (k,v) = bind_map_pair compile_type_expression (k,v) in
ok @@ O.TC_map (k,v)
| TC_big_map (k,v) ->
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_pair_right_comb c ->
let%bind c = compile_type_expression c in
ok @@ O.TC_michelson_pair_right_comb c
| 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
| I.T_operator (type_operator, lst) ->
let%bind lst = bind_map_list compile_type_expression lst in
return @@ T_operator (type_operator, lst)
| I.T_annoted (ty, _) -> compile_type_expression ty
let rec compile_expression : I.expression -> O.expression result =
fun e ->
@ -627,43 +597,9 @@ let rec uncompile_type_expression : O.type_expression -> I.type_expression resul
return @@ T_arrow {type1;type2}
| O.T_variable type_variable -> return @@ T_variable type_variable
| O.T_constant type_constant -> return @@ T_constant type_constant
| O.T_operator type_operator ->
let%bind type_operator = uncompile_type_operator type_operator in
return @@ T_operator type_operator
and uncompile_type_operator : O.type_operator -> I.type_operator result =
fun t_o ->
match t_o with
| TC_contract c ->
let%bind c = uncompile_type_expression c in
ok @@ I.TC_contract c
| TC_option o ->
let%bind o = uncompile_type_expression o in
ok @@ I.TC_option o
| TC_list l ->
let%bind l = uncompile_type_expression l in
ok @@ I.TC_list l
| TC_set s ->
let%bind s = uncompile_type_expression s in
ok @@ I.TC_set s
| TC_map (k,v) ->
let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in
ok @@ I.TC_map (k,v)
| 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_pair_right_comb c ->
let%bind c = uncompile_type_expression c in
ok @@ I.TC_michelson_pair_right_comb c
| 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
| O.T_operator (type_operator, lst) ->
let%bind lst = bind_map_list uncompile_type_expression lst in
return @@ T_operator (type_operator, lst)
let rec uncompile_expression' : O.expression -> I.expression result =
fun e ->

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

@ -41,43 +41,9 @@ let rec idle_type_expression : I.type_expression -> O.type_expression result =
return @@ T_arrow {type1;type2}
| I.T_variable type_variable -> return @@ T_variable type_variable
| I.T_constant type_constant -> return @@ T_constant type_constant
| I.T_operator type_operator ->
let%bind type_operator = idle_type_operator type_operator in
return @@ T_operator type_operator
and idle_type_operator : I.type_operator -> O.type_operator result =
fun t_o ->
match t_o with
| TC_contract c ->
let%bind c = idle_type_expression c in
ok @@ O.TC_contract c
| TC_option o ->
let%bind o = idle_type_expression o in
ok @@ O.TC_option o
| TC_list l ->
let%bind l = idle_type_expression l in
ok @@ O.TC_list l
| TC_set s ->
let%bind s = idle_type_expression s in
ok @@ O.TC_set s
| TC_map (k,v) ->
let%bind (k,v) = bind_map_pair idle_type_expression (k,v) in
ok @@ O.TC_map (k,v)
| 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_pair_right_comb c ->
let%bind c = idle_type_expression c in
ok @@ O.TC_michelson_pair_right_comb c
| 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
| I.T_operator (type_operator, lst) ->
let%bind lst = bind_map_list idle_type_expression lst in
return @@ T_operator (type_operator, lst)
let rec compile_expression : I.expression -> O.expression result =
fun e ->
@ -274,44 +240,9 @@ let rec uncompile_type_expression : O.type_expression -> I.type_expression resul
return @@ T_arrow {type1;type2}
| O.T_variable type_variable -> return @@ T_variable type_variable
| O.T_constant type_constant -> return @@ T_constant type_constant
| O.T_operator type_operator ->
let%bind type_operator = uncompile_type_operator type_operator in
return @@ T_operator type_operator
and uncompile_type_operator : O.type_operator -> I.type_operator result =
fun t_o ->
match t_o with
| TC_contract c ->
let%bind c = uncompile_type_expression c in
ok @@ I.TC_contract c
| TC_option o ->
let%bind o = uncompile_type_expression o in
ok @@ I.TC_option o
| TC_list l ->
let%bind l = uncompile_type_expression l in
ok @@ I.TC_list l
| TC_set s ->
let%bind s = uncompile_type_expression s in
ok @@ I.TC_set s
| TC_map (k,v) ->
let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in
ok @@ I.TC_map (k,v)
| 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_map_or_big_map _ -> failwith "TC_map_or_big_map shouldn't be uncompiled"
| TC_michelson_pair_right_comb c ->
let%bind c = uncompile_type_expression c in
ok @@ I.TC_michelson_pair_right_comb c
| 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
| O.T_operator (type_operator, lst) ->
let%bind lst = bind_map_list uncompile_type_expression lst in
return @@ T_operator (type_operator, lst)
let rec uncompile_expression : O.expression -> I.expression result =
fun e ->

5
src/passes/8-typer-new/errors.ml
View File

@ -150,3 +150,8 @@ let type_error ?(msg="") ~(expected: O.type_expression) ~(actual: O.type_express
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
let bad_type_operator type_op =
let title () = Format.asprintf "bad type operator %a" I.PP.type_expression type_op in
let message () = "" in
error title message

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

@ -156,36 +156,37 @@ 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
| TC_set s ->
| T_operator (op, lst) ->
let%bind opt = match op,lst with
| TC_set, [s] ->
let%bind s = evaluate_type e s in
ok @@ O.TC_set (s)
| TC_option o ->
| TC_option, [o] ->
let%bind o = evaluate_type e o in
ok @@ O.TC_option (o)
| TC_list l ->
| TC_list, [l] ->
let%bind l = evaluate_type e l in
ok @@ O.TC_list (l)
| TC_map (k,v) ->
| 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}
| TC_big_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}
| TC_map_or_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}
| TC_contract c ->
| 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_or_right_comb _c | TC_michelson_or_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"
| _ -> fail @@ bad_type_operator t
in
return (T_operator (opt))

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

@ -178,28 +178,28 @@ let rec untype_type_expression (t:O.type_expression) : (I.type_expression) resul
let%bind type_name = match type_name with
| O.TC_option t ->
let%bind t' = untype_type_expression t in
ok @@ I.TC_option t'
ok @@ (I.TC_option, [t'])
| O.TC_list t ->
let%bind t' = untype_type_expression t in
ok @@ I.TC_list t'
ok @@ (I.TC_list, [t'])
| O.TC_set t ->
let%bind t' = untype_type_expression t in
ok @@ I.TC_set t'
ok @@ (I.TC_set, [t'])
| O.TC_map {k;v} ->
let%bind k = untype_type_expression k in
let%bind v = untype_type_expression v in
ok @@ I.TC_map (k,v)
ok @@ (I.TC_map, [k;v])
| O.TC_big_map {k;v} ->
let%bind k = untype_type_expression k in
let%bind v = untype_type_expression v in
ok @@ I.TC_big_map (k,v)
ok @@ (I.TC_big_map, [k;v])
| O.TC_map_or_big_map {k;v} ->
let%bind k = untype_type_expression k in
let%bind v = untype_type_expression v in
ok @@ I.TC_map_or_big_map (k,v)
ok @@ (I.TC_map_or_big_map, [k;v])
| O.TC_contract c->
let%bind c = untype_type_expression c in
ok @@ I.TC_contract c
ok @@ (I.TC_contract, [c])
in
ok @@ I.T_operator (type_name)
in

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

@ -97,19 +97,21 @@ let rec type_expression_to_type_value_copypasted : I.type_expression -> O.type_v
| _ -> failwith "unknown type constructor")
in
p_constant csttag []
| T_operator (type_name) ->
let (csttag, args) = T.(match type_name with
| TC_option o -> (C_option , [o])
| TC_list l -> (C_list , [l])
| TC_set s -> (C_set , [s])
| TC_map ( k , v ) -> (C_map , [k;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_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])
| T_operator (type_name, args) ->
let csttag = T.(match type_name with
| TC_option -> C_option
| TC_list -> C_list
| TC_set -> C_set
| TC_map -> C_map
| TC_big_map -> C_big_map
| TC_map_or_big_map -> C_map
| TC_contract -> C_contract
| TC_michelson_pair
| TC_michelson_or
| TC_michelson_pair_right_comb -> C_record
| TC_michelson_pair_left_comb -> C_record
| TC_michelson_or_right_comb -> C_record
| TC_michelson_or_left_comb -> C_record
)
in
p_constant csttag (List.map type_expression_to_type_value_copypasted args)

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

@ -230,6 +230,11 @@ module Errors = struct
] in
error ~data title message ()
let bad_type_operator type_op =
let title () = Format.asprintf "bad type operator %a" I.PP.type_expression type_op in
let message () = "" in
error title message
end
open Errors
@ -614,59 +619,60 @@ 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 -> ( match opt with
| TC_set s ->
| T_operator (op, lst) -> ( match op,lst with
| TC_set, [s] ->
let%bind s = evaluate_type e s in
return @@ T_operator (O.TC_set (s))
| TC_option o ->
| TC_option, [o] ->
let%bind o = evaluate_type e o in
return @@ T_operator (O.TC_option (o))
| TC_list l ->
| TC_list, [l] ->
let%bind l = evaluate_type e l in
return @@ T_operator (O.TC_list (l))
| TC_map (k,v) ->
| TC_map, [k;v] ->
let%bind k = evaluate_type e k in
let%bind v = evaluate_type e v in
return @@ T_operator (O.TC_map {k;v})
| TC_big_map (k,v) ->
| TC_big_map, [k;v] ->
let%bind k = evaluate_type e k in
let%bind v = evaluate_type e v in
return @@ T_operator (O.TC_big_map {k;v})
| TC_map_or_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
return @@ T_operator (O.TC_map_or_big_map {k;v})
| TC_contract c ->
| TC_contract, [c] ->
let%bind c = evaluate_type e c in
return @@ T_operator (O.TC_contract c)
| TC_michelson_pair_right_comb c ->
| TC_michelson_pair_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_pair_to_right_comb (Ast_typed.LMap.to_kv_list lmap) in
return @@ record
| TC_michelson_pair_left_comb c ->
| TC_michelson_pair_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_pair_to_left_comb (Ast_typed.LMap.to_kv_list lmap) in
return @@ record
| TC_michelson_or_right_comb c ->
| 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 ->
| 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
| _ -> fail @@ bad_type_operator t
)
and type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state) result

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

@ -32,8 +32,6 @@ module Concrete_to_imperative = struct
- The left-hand-side is the reserved name in the given front-end.
- The right-hand-side is the name that will be used in the AST.
*)
let unit_expr = make_t @@ T_constant TC_unit
let type_constants s =
match s with
"chain_id" -> Some TC_chain_id
@ -53,16 +51,16 @@ module Concrete_to_imperative = struct
let type_operators s =
match s with
"list" -> Some (TC_list unit_expr)
| "option" -> Some (TC_option unit_expr)
| "set" -> Some (TC_set unit_expr)
| "map" -> Some (TC_map (unit_expr,unit_expr))
| "big_map" -> Some (TC_big_map (unit_expr,unit_expr))
| "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)
"list" -> Some (TC_list)
| "option" -> Some (TC_option)
| "set" -> Some (TC_set)
| "map" -> Some (TC_map)
| "big_map" -> Some (TC_big_map)
| "contract" -> Some (TC_contract)
| "michelson_pair_right_comb" -> Some (TC_michelson_pair_right_comb)
| "michelson_pair_left_comb" -> Some (TC_michelson_pair_left_comb)
| "michelson_or_right_comb" -> Some (TC_michelson_or_right_comb)
| "michelson_or_left_comb" -> Some (TC_michelson_or_left_comb)
| _ -> None
let pseudo_modules = function

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

@ -42,30 +42,27 @@ let rec type_expression' :
| T_variable tv -> type_variable ppf tv
| T_constant tc -> type_constant ppf tc
| T_operator to_ -> type_operator f ppf to_
| T_annoted (ty, str) -> fprintf ppf "(%a%%%s)" type_expression ty str
and type_expression ppf (te : type_expression) : unit =
type_expression' type_expression ppf te
and type_operator :
(formatter -> type_expression -> unit)
-> formatter
-> type_operator
-> unit =
and type_operator : (formatter -> type_expression -> unit) -> formatter -> type_operator * type_expression list -> unit =
fun f ppf to_ ->
let s =
match to_ with
| TC_option te -> Format.asprintf "option(%a)" f te
| TC_list te -> Format.asprintf "list(%a)" f te
| TC_set te -> Format.asprintf "set(%a)" f te
| 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_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_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
let s = match to_ with
TC_option , lst -> Format.asprintf "option(%a)" (list_sep_d f) lst
| TC_list , lst -> Format.asprintf "list(%a)" (list_sep_d f) lst
| TC_set , lst -> Format.asprintf "set(%a)" (list_sep_d f) lst
| TC_map , lst -> Format.asprintf "Map (%a)" (list_sep_d f) lst
| TC_big_map , lst -> Format.asprintf "Big Map (%a)" (list_sep_d f) lst
| TC_map_or_big_map , lst -> Format.asprintf "Map Or Big Map (%a)" (list_sep_d f) lst
| TC_contract , lst -> Format.asprintf "Contract (%a)" (list_sep_d f) lst
| TC_michelson_pair , lst -> Format.asprintf "michelson_pair (%a)" (list_sep_d f) lst
| TC_michelson_or , lst -> Format.asprintf "michelson_or (%a)" (list_sep_d f) lst
| TC_michelson_pair_right_comb , lst -> Format.asprintf "michelson_pair_right_comb (%a)" (list_sep_d f) lst
| TC_michelson_pair_left_comb , lst -> Format.asprintf "michelson_pair_left_comb (%a)" (list_sep_d f) lst
| TC_michelson_or_right_comb , lst -> Format.asprintf "michelson_or_right_comb (%a)" (list_sep_d f) lst
| TC_michelson_or_left_comb , lst -> Format.asprintf "michelson_or_left_comb (%a)" (list_sep_d f) lst
in
fprintf ppf "(TO_%s)" s

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

@ -12,10 +12,6 @@ module Errors = struct
("location" , fun () -> Format.asprintf "%a" Location.pp location) ;
] in
error ~data title message
let bad_type_operator type_op =
let title () = Format.asprintf "bad type operator %a" (PP.type_operator PP.type_expression) type_op in
let message () = "" in
error title message
end
open Errors
@ -34,8 +30,8 @@ let t_signature ?loc () : type_expression = make_t ?loc @@ T_constant (TC_sign
let t_key ?loc () : type_expression = make_t ?loc @@ T_constant (TC_key)
let t_key_hash ?loc () : type_expression = make_t ?loc @@ T_constant (TC_key_hash)
let t_timestamp ?loc () : type_expression = make_t ?loc @@ T_constant (TC_timestamp)
let t_option ?loc o : type_expression = make_t ?loc @@ T_operator (TC_option o)
let t_list ?loc t : type_expression = make_t ?loc @@ T_operator (TC_list t)
let t_option ?loc o : type_expression = make_t ?loc @@ T_operator (TC_option, [o])
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.mapi (fun i (k, v) -> (Label k, {field_type=v;field_decl_pos=i})) lst in
@ -56,33 +52,25 @@ let t_sum ?loc m : type_expression =
let lst = Map.String.to_kv_list m in
ez_t_sum ?loc lst
let t_function ?loc type1 type2 : type_expression = make_t ?loc @@ T_arrow {type1; type2}
let t_map ?loc key value : type_expression = make_t ?loc @@ T_operator (TC_map (key, value))
let t_big_map ?loc key value : type_expression = make_t ?loc @@ T_operator (TC_big_map (key , value))
let t_set ?loc key : type_expression = make_t ?loc @@ T_operator (TC_set key)
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_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)
let t_operator ?loc op lst: type_expression = make_t ?loc @@ T_operator (op, lst)
let t_annoted ?loc ty str : type_expression = make_t ?loc @@ T_annoted (ty, str)
(* TODO find a better way than using list*)
let t_operator ?loc op lst: type_expression result =
match op,lst with
| TC_set _ , [t] -> ok @@ t_set ?loc t
| TC_list _ , [t] -> ok @@ t_list ?loc t
| TC_option _ , [t] -> ok @@ t_option ?loc t
| TC_map (_,_) , [kt;vt] -> ok @@ t_map ?loc kt vt
| 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_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 t_function ?loc type1 type2 : type_expression = make_t ?loc @@ T_arrow {type1; type2}
let t_map ?loc key value : type_expression = make_t ?loc @@ T_operator (TC_map ,[key; value])
let t_big_map ?loc key value : type_expression = make_t ?loc @@ T_operator (TC_big_map, [key; value])
let t_set ?loc key : type_expression = make_t ?loc @@ T_operator (TC_set, [key])
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, [t_annoted l l_ann; t_annoted r r_ann])
let t_michelson_pair ?loc l l_ann r r_ann : type_expression = make_t ?loc @@ T_operator (TC_michelson_pair, [t_annoted l l_ann; t_annoted 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])
let get_t_annoted = fun te ->
match te.type_content with
T_annoted (te, lst) -> ok (te,lst)
| _ -> simple_fail "not a T_annoted"
let make_e ?(loc = Location.generated) expression_content =
let location = loc in

9
src/stages/1-ast_imperative/combinators.mli
View File

@ -46,11 +46,18 @@ val t_michelson_or : ?loc:Location.t -> type_expression -> michelson_prct_annota
type_expression -> michelson_prct_annotation -> type_expression
val t_michelson_pair : ?loc:Location.t -> type_expression -> michelson_prct_annotation ->
type_expression -> michelson_prct_annotation -> type_expression
val t_michelson_pair_right_comb : ?loc:Location.t -> type_expression -> type_expression
val t_michelson_pair_left_comb : ?loc:Location.t -> type_expression -> type_expression
val t_michelson_or_right_comb : ?loc:Location.t -> type_expression -> type_expression
val t_michelson_or_left_comb : ?loc:Location.t -> type_expression -> type_expression
val t_operator : ?loc:Location.t -> type_operator -> type_expression list -> type_expression result
val t_operator : ?loc:Location.t -> type_operator -> type_expression list -> type_expression
val t_set : ?loc:Location.t -> type_expression -> type_expression
val t_contract : ?loc:Location.t -> type_expression -> type_expression
val t_annoted : ?loc:Location.t -> type_expression -> string -> type_expression
val get_t_annoted : type_expression -> (type_expression* string) result
val make_e : ?loc:Location.t -> expression_content -> expression
val e_literal : ?loc:Location.t -> literal -> expression

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

@ -11,7 +11,8 @@ type type_content =
| T_arrow of arrow
| T_variable of type_variable
| T_constant of type_constant
| T_operator of type_operator
| T_operator of (type_operator * type_expression list)
| T_annoted of (type_expression * string)
and arrow = {type1: type_expression; type2: type_expression}
@ -21,20 +22,6 @@ and ctor_content = {ctor_type : type_expression ; ctor_decl_pos : int}
and michelson_prct_annotation = string
and type_operator =
| TC_contract of type_expression
| TC_option of type_expression
| TC_list of type_expression
| TC_set of type_expression
| TC_map of type_expression * type_expression
| 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
and type_expression = {type_content: type_content; location: Location.t}

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

@ -42,20 +42,22 @@ let rec type_expression' :
and type_expression ppf (te : type_expression) : unit =
type_expression' type_expression ppf te
and type_operator : (formatter -> type_expression -> unit) -> formatter -> type_operator -> unit =
and type_operator : (formatter -> type_expression -> unit) -> formatter -> type_operator * type_expression list -> unit =
fun f ppf to_ ->
let s =
match to_ with
| TC_option te -> Format.asprintf "option(%a)" f te
| TC_list te -> Format.asprintf "list(%a)" f te
| TC_set te -> Format.asprintf "set(%a)" f te
| 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_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
let s = match to_ with
TC_option , lst -> Format.asprintf "option(%a)" (list_sep_d f) lst
| TC_list , lst -> Format.asprintf "list(%a)" (list_sep_d f) lst
| TC_set , lst -> Format.asprintf "set(%a)" (list_sep_d f) lst
| TC_map , lst -> Format.asprintf "Map (%a)" (list_sep_d f) lst
| TC_big_map , lst -> Format.asprintf "Big Map (%a)" (list_sep_d f) lst
| TC_map_or_big_map , lst -> Format.asprintf "Map Or Big Map (%a)" (list_sep_d f) lst
| TC_contract , lst -> Format.asprintf "Contract (%a)" (list_sep_d f) lst
| TC_michelson_pair , lst -> Format.asprintf "michelson_pair (%a)" (list_sep_d f) lst
| TC_michelson_or , lst -> Format.asprintf "michelson_or (%a)" (list_sep_d f) lst
| TC_michelson_pair_right_comb , lst -> Format.asprintf "michelson_pair_right_comb (%a)" (list_sep_d f) lst
| TC_michelson_pair_left_comb , lst -> Format.asprintf "michelson_pair_left_comb (%a)" (list_sep_d f) lst
| TC_michelson_or_right_comb , lst -> Format.asprintf "michelson_or_right_comb (%a)" (list_sep_d f) lst
| TC_michelson_or_left_comb , lst -> Format.asprintf "michelson_or_left_comb (%a)" (list_sep_d f) lst
in
fprintf ppf "(TO_%s)" s

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

@ -12,10 +12,6 @@ module Errors = struct
("location" , fun () -> Format.asprintf "%a" Location.pp location) ;
] in
error ~data title message
let bad_type_operator type_op =
let title () = Format.asprintf "bad type operator %a" (PP.type_operator PP.type_expression) type_op in
let message () = "" in
error title message
end
open Errors
@ -40,8 +36,8 @@ let t_signature ?loc () : type_expression = make_t ?loc @@ T_constant (TC_sign
let t_key ?loc () : type_expression = make_t ?loc @@ T_constant (TC_key)
let t_key_hash ?loc () : type_expression = make_t ?loc @@ T_constant (TC_key_hash)
let t_timestamp ?loc () : type_expression = make_t ?loc @@ T_constant (TC_timestamp)
let t_option ?loc o : type_expression = make_t ?loc @@ T_operator (TC_option o)
let t_list ?loc t : type_expression = make_t ?loc @@ T_operator (TC_list t)
let t_option ?loc o : type_expression = make_t ?loc @@ T_operator (TC_option, [o])
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
@ -65,21 +61,12 @@ let t_sum ?loc m : type_expression =
ez_t_sum ?loc lst
let t_function ?loc type1 type2 : type_expression = make_t ?loc @@ T_arrow {type1; type2}
let t_map ?loc key value : type_expression = make_t ?loc @@ T_operator (TC_map (key, value))
let t_big_map ?loc key value : type_expression = make_t ?loc @@ T_operator (TC_big_map (key , value))
let t_set ?loc key : type_expression = make_t ?loc @@ T_operator (TC_set key)
let t_contract ?loc contract : type_expression = make_t ?loc @@ T_operator (TC_contract contract)
let t_map ?loc key value : type_expression = make_t ?loc @@ T_operator (TC_map ,[key; value])
let t_big_map ?loc key value : type_expression = make_t ?loc @@ T_operator (TC_big_map, [key; value])
let t_set ?loc key : type_expression = make_t ?loc @@ T_operator (TC_set, [key])
let t_contract ?loc contract : type_expression = make_t ?loc @@ T_operator (TC_contract, [contract])
(* TODO find a better way than using list*)
let t_operator ?loc op lst: type_expression result =
match op,lst with
| TC_set _ , [t] -> ok @@ t_set ?loc t
| TC_list _ , [t] -> ok @@ t_list ?loc t
| TC_option _ , [t] -> ok @@ t_option ?loc t
| TC_map (_,_) , [kt;vt] -> ok @@ t_map ?loc kt vt
| TC_big_map (_,_) , [kt;vt] -> ok @@ t_big_map ?loc kt vt
| TC_contract _ , [t] -> ok @@ t_contract ?loc t
| _ , _ -> fail @@ bad_type_operator op
let t_operator ?loc op lst: type_expression = make_t ?loc @@ T_operator (op, lst)
let make_e ?(loc = Location.generated) expression_content =
let location = loc in

6
src/stages/2-ast_sugar/combinators.mli
View File

@ -41,9 +41,11 @@ val t_sum : ?loc:Location.t -> ctor_content Map.String.t -> type_expression
val ez_t_sum : ?loc:Location.t -> ( string * ctor_content ) list -> type_expression
val t_function : ?loc:Location.t -> type_expression -> type_expression -> type_expression
val t_map : ?loc:Location.t -> type_expression -> type_expression -> type_expression
val t_operator : ?loc:Location.t -> type_operator -> type_expression list -> type_expression result
val t_operator : ?loc:Location.t -> type_operator -> type_expression list -> type_expression
val t_map : ?loc:Location.t -> type_expression -> type_expression -> type_expression
val t_big_map : ?loc:Location.t -> type_expression -> type_expression -> type_expression
val t_contract : ?loc:Location.t -> type_expression -> type_expression
val t_set : ?loc:Location.t -> type_expression -> type_expression
val make_e : ?loc:Location.t -> expression_content -> expression

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

@ -15,7 +15,7 @@ type type_content =
| T_arrow of arrow
| T_variable of type_variable
| T_constant of type_constant
| T_operator of type_operator
| T_operator of (type_operator * type_expression list)
and arrow = {type1: type_expression; type2: type_expression}
@ -23,18 +23,6 @@ and ctor_content = {ctor_type : type_expression ; michelson_annotation : string
and field_content = {field_type : type_expression ; michelson_annotation : string option ; field_decl_pos : int}
and type_operator =
| TC_contract of type_expression
| TC_option of type_expression
| TC_list of type_expression
| TC_set of type_expression
| TC_map of type_expression * type_expression
| 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}

27
src/stages/3-ast_core/combinators.ml
View File

@ -12,10 +12,6 @@ module Errors = struct
("location" , fun () -> Format.asprintf "%a" Location.pp location) ;
] in
error ~data title message
let bad_type_operator type_op =
let title () = Format.asprintf "bad type operator %a" (PP.type_operator PP.type_expression) type_op in
let message () = "" in
error title message
end
open Errors
@ -40,8 +36,8 @@ let t_signature ?loc () : type_expression = make_t ?loc @@ T_constant (TC_sign
let t_key ?loc () : type_expression = make_t ?loc @@ T_constant (TC_key)
let t_key_hash ?loc () : type_expression = make_t ?loc @@ T_constant (TC_key_hash)
let t_timestamp ?loc () : type_expression = make_t ?loc @@ T_constant (TC_timestamp)
let t_option ?loc o : type_expression = make_t ?loc @@ T_operator (TC_option o)
let t_list ?loc t : type_expression = make_t ?loc @@ T_operator (TC_list t)
let t_option ?loc o : type_expression = make_t ?loc @@ T_operator (TC_option, [o])
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
@ -63,21 +59,12 @@ let t_sum ?loc m : type_expression =
ez_t_sum ?loc lst
let t_function ?loc type1 type2 : type_expression = make_t ?loc @@ T_arrow {type1; type2}
let t_map ?loc key value : type_expression = make_t ?loc @@ T_operator (TC_map (key, value))
let t_big_map ?loc key value : type_expression = make_t ?loc @@ T_operator (TC_big_map (key , value))
let t_set ?loc key : type_expression = make_t ?loc @@ T_operator (TC_set key)
let t_contract ?loc contract : type_expression = make_t ?loc @@ T_operator (TC_contract contract)
(* TODO find a better way than using list*)
let t_operator ?loc op lst: type_expression result =
match op,lst with
| TC_set _ , [t] -> ok @@ t_set ?loc t
| TC_list _ , [t] -> ok @@ t_list ?loc t
| TC_option _ , [t] -> ok @@ t_option ?loc t
| TC_map (_,_) , [kt;vt] -> ok @@ t_map kt ?loc vt
| TC_big_map (_,_) , [kt;vt] -> ok @@ t_big_map ?loc kt vt
| TC_contract _ , [t] -> ok @@ t_contract ?loc t
| _ , _ -> fail @@ bad_type_operator op
let t_operator ?loc op lst : type_expression = make_t ?loc @@ T_operator (op, lst)
let t_map ?loc key value : type_expression = make_t ?loc @@ T_operator (TC_map, [key; value])
let t_big_map ?loc key value : type_expression = make_t ?loc @@ T_operator (TC_big_map, [key; value])
let t_set ?loc key : type_expression = make_t ?loc @@ T_operator (TC_set, [key])
let t_contract ?loc contract : type_expression = make_t ?loc @@ T_operator (TC_contract, [contract])
let make_e ?(loc = Location.generated) expression_content = { expression_content; location=loc }

6
src/stages/3-ast_core/combinators.mli
View File

@ -41,9 +41,11 @@ val t_sum : ?loc:Location.t -> Types.ctor_content Map.String.t -> type_expres
val ez_t_sum : ?loc:Location.t -> ( string * Types.ctor_content ) list -> type_expression
val t_function : ?loc:Location.t -> type_expression -> type_expression -> type_expression
val t_map : ?loc:Location.t -> type_expression -> type_expression -> type_expression
val t_operator : ?loc:Location.t -> type_operator -> type_expression list -> type_expression result
val t_operator : ?loc:Location.t -> type_operator -> type_expression list -> type_expression
val t_map : ?loc:Location.t -> type_expression -> type_expression -> type_expression
val t_big_map : ?loc:Location.t -> type_expression -> type_expression -> type_expression
val t_contract : ?loc:Location.t -> type_expression -> type_expression
val t_set : ?loc:Location.t -> type_expression -> type_expression
val make_e : ?loc:Location.t -> expression_content -> expression

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

@ -239,25 +239,22 @@ module Ast_PP_type (PARAMETER : AST_PARAMETER_TYPE) = struct
and type_expression ppf (te : type_expression) : unit =
type_expression' type_expression ppf te
and type_operator :
(formatter -> type_expression -> unit)
-> formatter
-> type_operator
-> unit =
and type_operator : (formatter -> type_expression -> unit) -> formatter -> type_operator * type_expression list -> unit =
fun f ppf to_ ->
let s =
match to_ with
| TC_option te -> Format.asprintf "option(%a)" f te
| TC_list te -> Format.asprintf "list(%a)" f te
| TC_set te -> Format.asprintf "set(%a)" f te
| 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_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_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
let s = match to_ with
TC_option , lst -> Format.asprintf "option(%a)" (list_sep_d f) lst
| TC_list , lst -> Format.asprintf "list(%a)" (list_sep_d f) lst
| TC_set , lst -> Format.asprintf "set(%a)" (list_sep_d f) lst
| TC_map , lst -> Format.asprintf "Map (%a)" (list_sep_d f) lst
| TC_big_map , lst -> Format.asprintf "Big Map (%a)" (list_sep_d f) lst
| TC_map_or_big_map , lst -> Format.asprintf "Map Or Big Map (%a)" (list_sep_d f) lst
| TC_contract , lst -> Format.asprintf "Contract (%a)" (list_sep_d f) lst
| TC_michelson_pair , lst -> Format.asprintf "michelson_pair (%a)" (list_sep_d f) lst
| TC_michelson_or , lst -> Format.asprintf "michelson_or (%a)" (list_sep_d f) lst
| TC_michelson_pair_right_comb , lst -> Format.asprintf "michelson_pair_right_comb (%a)" (list_sep_d f) lst
| TC_michelson_pair_left_comb , lst -> Format.asprintf "michelson_pair_left_comb (%a)" (list_sep_d f) lst
| TC_michelson_or_right_comb , lst -> Format.asprintf "michelson_or_right_comb (%a)" (list_sep_d f) lst
| TC_michelson_or_left_comb , lst -> Format.asprintf "michelson_or_left_comb (%a)" (list_sep_d f) lst
in
fprintf ppf "(type_operator: %s)" s
end

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

@ -29,6 +29,21 @@ type 'a constructor_map = 'a CMap.t
| TC_signature
| TC_timestamp
| TC_void
and type_operator =
| TC_contract
| TC_option
| TC_list
| TC_set
| TC_map
| TC_big_map
| TC_map_or_big_map
| TC_michelson_pair
| TC_michelson_or
| TC_michelson_pair_right_comb
| TC_michelson_pair_left_comb
| TC_michelson_or_right_comb
| TC_michelson_or_left_comb
module type AST_PARAMETER_TYPE = sig
type type_meta
end
@ -44,7 +59,7 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
| T_arrow of arrow
| T_variable of type_variable
| T_constant of type_constant
| T_operator of type_operator
| T_operator of (type_operator * type_expression list)
and arrow = {type1: type_expression; type2: type_expression}
@ -52,69 +67,32 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
and field_content = {field_type : type_expression ; field_annotation : string option ; field_decl_pos : int}
and type_operator =
| TC_contract of type_expression
| TC_option of type_expression
| TC_list of type_expression
| TC_set of type_expression
| 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_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}
open Trace
let map_type_operator f = function
TC_contract x -> TC_contract (f x)
| TC_option x -> TC_option (f x)
| TC_list x -> TC_list (f x)
| TC_set x -> TC_set (f x)
| 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_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
| TC_option x -> let%bind x = f x in ok @@ TC_option x
| TC_list x -> let%bind x = f x in ok @@ TC_list x
| TC_set x -> let%bind x = f x in ok @@ TC_set x
| 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_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"
| TC_option _ -> "TC_option"
| TC_list _ -> "TC_list"
| TC_set _ -> "TC_set"
| TC_map _ -> "TC_map"
| TC_big_map _ -> "TC_big_map"
| 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"
TC_contract -> "TC_contract"
| TC_option -> "TC_option"
| TC_list -> "TC_list"
| TC_set -> "TC_set"
| TC_map -> "TC_map"
| TC_big_map -> "TC_big_map"
| TC_map_or_big_map -> "TC_map_or_big_map"
| TC_michelson_pair -> "TC_michelson_pair"
| TC_michelson_or -> "TC_michelson_or"
| 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)
| "TC_option" , [x] -> ok @@ T_operator(TC_option x)
| "TC_list" , [x] -> ok @@ T_operator(TC_list x)
| "TC_set" , [x] -> ok @@ T_operator(TC_set x)
| "TC_map" , [x ; y] -> ok @@ T_operator(TC_map (x , y))
| "TC_big_map" , [x ; y] -> ok @@ T_operator(TC_big_map (x, y))
| "TC_contract" , [x] -> ok @@ T_operator(TC_contract, [x])
| "TC_option" , [x] -> ok @@ T_operator(TC_option, [x])
| "TC_list" , [x] -> ok @@ T_operator(TC_list, [x])
| "TC_set" , [x] -> ok @@ T_operator(TC_set, [x])
| "TC_map" , [x ; y] -> ok @@ T_operator(TC_map, [x ; y])
| "TC_big_map" , [x ; y] -> ok @@ T_operator(TC_big_map, [x; y])
| ("TC_contract" | "TC_option" | "TC_list" | "TC_set" | "TC_map" | "TC_big_map"), _ ->
failwith "internal error: wrong number of arguments for type operator"
@ -137,17 +115,19 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
failwith "internal error: unknown type operator"
let string_of_type_operator = function
| TC_contract x -> "TC_contract" , [x]
| TC_option x -> "TC_option" , [x]
| TC_list x -> "TC_list" , [x]
| TC_set x -> "TC_set" , [x]
| 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_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]
| TC_contract , lst -> "TC_contract" , lst
| TC_option , lst -> "TC_option" , lst
| TC_list , lst -> "TC_list" , lst
| TC_set , lst -> "TC_set" , lst
| TC_map , lst -> "TC_map" , lst
| TC_big_map , lst -> "TC_big_map" , lst
| TC_map_or_big_map , lst -> "TC_map_or_big_map" , lst
| TC_michelson_pair , lst -> "TC_michelson_pair" , lst
| TC_michelson_or , lst -> "TC_michelson_or" , lst
| TC_michelson_pair_right_comb , lst -> "TC_michelson_pair_right_comb" , lst
| TC_michelson_pair_left_comb , lst -> "TC_michelson_pair_left_comb" , lst
| TC_michelson_or_right_comb , lst -> "TC_michelson_or_right_comb" , lst
| TC_michelson_or_left_comb , lst -> "TC_michelson_or_left_comb" , lst
let string_of_type_constant = function
| TC_unit -> "TC_unit", []

9
src/stages/typesystem/misc.ml
View File

@ -91,13 +91,12 @@ module Substitution = struct
| Ast_core.T_record _ -> failwith "TODO: subst: unimplemented case s_type_expression record"
| Ast_core.T_arrow _ -> failwith "TODO: subst: unimplemented case s_type_expression arrow"
| Ast_core.T_variable _ -> failwith "TODO: subst: unimplemented case s_type_expression variable"
| Ast_core.T_operator op ->
let%bind op =
Ast_core.bind_map_type_operator
| Ast_core.T_operator (op,lst) ->
let%bind lst = bind_map_list
(s_abstr_type_expression ~substs)
op in
lst in
(* TODO: when we have generalized operators, we might need to subst the operator name itself? *)
ok @@ Ast_core.T_operator op
ok @@ Ast_core.T_operator (op, lst)
| Ast_core.T_constant constant ->
ok @@ Ast_core.T_constant constant