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

Use ADT for types and move type to ast_common

Browse Source 
and Making name, type_variable, built-in, constructor, label and string uncompatible types in ligo (weird bug with types in ligodity)
This commit is contained in:
Pierre-Emmanuel Wulfman 2019-12-04 11:40:58 +00:00
parent 0312f1bf64
commit 034c92a64c
74 changed files with 2248 additions and 1786 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

109
src/passes/2-simplify/ligodity.ml
View File

@ -169,9 +169,9 @@ let rec simpl_type_expression : Raw.type_expr -> type_expression result = fun te
match te with
TPar x -> simpl_type_expression x.value.inside
| TVar v -> (
match List.assoc_opt v.value type_constants with
Some s -> ok @@ T_constant (s , [])
| None -> ok @@ T_variable v.value
match type_constants v.value with
| Ok (s,_) -> ok @@ make_t @@ T_constant s
| Error _ -> ok @@ make_t @@ T_variable (Var.of_name v.value)
)
| TFun x -> (
let%bind (a , b) =
@ -180,17 +180,16 @@ let rec simpl_type_expression : Raw.type_expr -> type_expression result = fun te
let%bind b = simpl_type_expression b in
ok (a , b)
in
ok @@ T_function (a , b)
ok @@ make_t @@ T_arrow (a , b)
)
| TApp x -> (
let (name, tuple) = x.value in
let lst = npseq_to_list tuple.value.inside in
let%bind cst =
trace_option (unknown_predefined_type name) @@
List.assoc_opt name.value type_constants
in
let%bind lst' = bind_map_list simpl_type_expression lst in
ok @@ T_constant (cst , lst')
let%bind cst =
trace (unknown_predefined_type name) @@
type_operators name.value in
ok @@ t_operator cst lst'
)
| TProd p -> (
let%bind tpl = simpl_list_type_expression @@ npseq_to_list p.value in
@ -205,8 +204,8 @@ let rec simpl_type_expression : Raw.type_expr -> type_expression result = fun te
@@ List.map aux
@@ List.map apply
@@ npseq_to_list r.value.ne_elements in
let m = List.fold_left (fun m (x, y) -> SMap.add x y m) SMap.empty lst in
ok @@ T_record m
let m = List.fold_left (fun m (x, y) -> LMap.add (Label x) y m) LMap.empty lst in
ok @@ make_t @@ T_record m
| TSum s ->
let aux (v:Raw.variant Raw.reg) =
let args =
@ -219,8 +218,8 @@ let rec simpl_type_expression : Raw.type_expr -> type_expression result = fun te
let%bind lst = bind_list
@@ List.map aux
@@ npseq_to_list s.value in
let m = List.fold_left (fun m (x, y) -> SMap.add x y m) SMap.empty lst in
ok @@ T_sum m
let m = List.fold_left (fun m (x, y) -> CMap.add (Constructor x) y m) CMap.empty lst in
ok @@ make_t @@ T_sum m
and simpl_list_type_expression (lst:Raw.type_expr list) : type_expression result =
match lst with
@ -228,7 +227,7 @@ and simpl_list_type_expression (lst:Raw.type_expr list) : type_expression result
| [hd] -> simpl_type_expression hd
| lst ->
let%bind lst = bind_map_list simpl_type_expression lst in
ok @@ T_tuple lst
ok @@ make_t @@ T_tuple lst
let rec simpl_expression :
Raw.expr -> expr result = fun t ->
@ -236,7 +235,7 @@ let rec simpl_expression :
let simpl_projection = fun (p:Raw.projection Region.reg) ->
let (p , loc) = r_split p in
let var =
let name = p.struct_name.value in
let name = Var.of_name p.struct_name.value in
e_variable name in
let path = p.field_path in
let path' =
@ -263,7 +262,7 @@ let rec simpl_expression :
None -> rhs
| Some ty -> e_annotation rhs ty in
let%bind body = simpl_expression body in
return @@ e_let_in (variable.value , None) rhs' body
return @@ e_let_in (Var.of_name variable.value , None) rhs' body
| Raw.EAnnot a ->
let (expr , type_expr), loc = r_split a in
let%bind expr' = simpl_expression expr in
@ -271,21 +270,21 @@ let rec simpl_expression :
return @@ e_annotation ~loc expr' type_expr'
| EVar c ->
let c' = c.value in
(match List.assoc_opt c' constants with
None -> return @@ e_variable c.value
| Some s -> return @@ e_constant s [])
(match constants c' with
| Error _ -> return @@ e_variable (Var.of_name c.value)
| Ok (s,_) -> return @@ e_constant s [])
| ECall x -> (
let ((e1 , e2) , loc) = r_split x in
let%bind args = bind_map_list simpl_expression (nseq_to_list e2) in
match e1 with
| EVar f -> (
let (f , f_loc) = r_split f in
match List.assoc_opt f constants with
| None -> (
match constants f with
| Error _ -> (
let%bind arg = simpl_tuple_expression (nseq_to_list e2) in
return @@ e_application ~loc (e_variable ~loc:f_loc f) arg
return @@ e_application ~loc (e_variable ~loc:f_loc (Var.of_name f)) arg
)
| Some s -> return @@ e_constant ~loc s args
| Ok (s,_) -> return @@ e_constant ~loc s args
)
| e1 ->
let%bind e1' = simpl_expression e1 in
@ -312,7 +311,7 @@ let rec simpl_expression :
| EConstr (ESomeApp a) ->
let (_, args), loc = r_split a in
let%bind arg = simpl_expression args in
return @@ e_constant ~loc "SOME" [arg]
return @@ e_constant ~loc C_SOME [arg]
| EConstr (ENone reg) ->
let loc = Location.lift reg in
return @@ e_none ~loc ()
@ -391,7 +390,7 @@ let rec simpl_expression :
let x' = x.value in
match x'.pattern with
| Raw.PVar y ->
let var_name = y.value in
let var_name = Var.of_name y.value in
let%bind type_expr = simpl_type_expression x'.type_expr in
return @@ e_let_in (var_name , Some type_expr) e rhs
| _ -> default_action ()
@ -433,7 +432,7 @@ and simpl_fun lamb' : expr result =
let aux ((var : Raw.variable) , ty_opt) =
match var.value , ty_opt with
| "storage" , None ->
ok (var , T_variable "storage")
ok (var , t_variable "storage")
| _ , None ->
fail @@ untyped_fun_param var
| _ , Some ty -> (
@ -446,7 +445,7 @@ and simpl_fun lamb' : expr result =
match args' with
| [ single ] -> (
let (binder , input_type) =
((fst single).value , snd single) in
(Var.of_name (fst single).value , snd single) in
let%bind (body , body_type) = expr_to_typed_expr lamb.body in
let%bind output_type =
bind_map_option simpl_type_expression body_type in
@ -455,7 +454,7 @@ and simpl_fun lamb' : expr result =
)
| _ -> (
let arguments_name = "arguments" in
let arguments_name = Var.of_name "arguments" in (* TODO wrong, should be fresh? *)
let (binder , input_type) =
let type_expression = T_tuple (List.map snd args') in
(arguments_name , type_expression) in
@ -466,11 +465,11 @@ and simpl_fun lamb' : expr result =
let wrapped_result =
let aux = fun i ((name : Raw.variable) , ty) wrapped ->
let accessor = e_accessor (e_variable arguments_name) [ Access_tuple i ] in
e_let_in (name.value , Some ty) accessor wrapped
e_let_in (Var.of_name name.value , Some ty) accessor wrapped
in
let wraps = List.mapi aux args' in
List.fold_right' (fun x f -> f x) result wraps in
return @@ e_lambda ~loc binder (Some input_type) output_type wrapped_result
return @@ e_lambda ~loc binder (Some (make_t @@ input_type)) output_type wrapped_result
)
@ -521,12 +520,14 @@ and simpl_binop (name:string) (t:_ Raw.bin_op Region.reg) : expression result =
let (args , loc) = r_split t in
let%bind a = simpl_expression args.arg1 in
let%bind b = simpl_expression args.arg2 in
let%bind name = constants name in
return @@ e_constant ~loc name [ a ; b ]
and simpl_unop (name:string) (t:_ Raw.un_op Region.reg) : expression result =
let return x = ok @@ x in
let (t , loc) = r_split t in
let%bind a = simpl_expression t.arg in
let%bind name = constants name in
return @@ e_constant ~loc name [ a ]
and simpl_tuple_expression ?loc (lst:Raw.expr list) : expression result =
@ -547,7 +548,7 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result
| TypeDecl x ->
let {name;type_expr} : Raw.type_decl = x.value in
let%bind type_expression = simpl_type_expression type_expr in
ok @@ [loc x @@ Declaration_type (name.value , type_expression)]
ok @@ [loc x @@ Declaration_type (Var.of_name name.value , type_expression)]
| Let x -> (
let binding, _ = r_split x in
let binding = snd binding in
@ -566,7 +567,7 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result
| None -> fail @@ wrong_pattern "typed var tuple" par_var in
let%bind v_type_expression = v_type_expression in
let%bind simpl_rhs_expr = simpl_expression rhs_expr in
ok @@ loc x @@ Declaration_constant (v.value, Some v_type_expression, simpl_rhs_expr) )
ok @@ loc x @@ Declaration_constant (Var.of_name v.value, Some v_type_expression, simpl_rhs_expr) )
in let%bind variables = ok @@ npseq_to_list pt.value
in let%bind expr_bind_lst =
match let_rhs with
@ -620,26 +621,26 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result
let hd, tl = binders in ok (hd, tl) in
let%bind var = pattern_to_var hd in
ok (var , tl)
in
match args with
| [] ->
let%bind lhs_type' =
bind_map_option (fun (_,te) -> simpl_type_expression te) lhs_type in
let%bind rhs' = simpl_expression let_rhs in
ok @@ [loc x @@ Declaration_constant (var.value , lhs_type' , rhs')]
| param1::others ->
let fun_ = {
kwd_fun = Region.ghost;
binders = param1, others;
lhs_type;
arrow = Region.ghost;
body = let_rhs} in
let rhs = Raw.EFun {region=Region.ghost ; value=fun_} in
let%bind rhs' = simpl_expression rhs in
ok @@ [loc x @@ Declaration_constant (var.value , None , rhs')]
)
in
match args with
| [] ->
let%bind lhs_type' =
bind_map_option (fun (_,te) -> simpl_type_expression te) lhs_type in
let%bind rhs' = simpl_expression let_rhs in
ok @@ [loc x @@ (Declaration_constant (Var.of_name var.value , lhs_type' , rhs'))]
| param1::others ->
let fun_ = {
kwd_fun = Region.ghost;
binders = param1, others;
lhs_type;
arrow = Region.ghost;
body = let_rhs} in
let rhs = Raw.EFun {region=Region.ghost ; value=fun_} in
let%bind rhs' = simpl_expression rhs in
ok @@ [loc x @@ (Declaration_constant (Var.of_name var.value , None , rhs'))]
)
and simpl_cases : type a . (Raw.pattern * a) list -> a matching result =
and simpl_cases : type a . (Raw.pattern * a) list -> (a, unit) matching result =
fun t ->
let open Raw in
let rec get_var (t:Raw.pattern) =
@ -719,7 +720,7 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result =
let%bind a = get_var a in
let%bind b = get_var b in
ok (a, b) in
ok @@ Match_list {match_cons=(a, b, cons); match_nil=nil}
ok @@ Match_list {match_cons=(Var.of_name a, Var.of_name b, cons, ()); match_nil=nil}
| lst ->
let error x =
let title () = "Pattern" in
@ -736,7 +737,7 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result =
let%bind x' = trace (error x) @@ get_constr x
in ok (x', y)
in bind_map_list aux lst
in ok @@ Match_variant constrs in
in ok @@ ez_match_variant constrs in
let as_option () =
let aux (x, y) =
let%bind x' = trace (error x) @@ get_constr_opt x
@ -748,7 +749,7 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result =
| [ (("None", None), none_expr);
(("Some", Some some_var), some_expr) ] ->
ok @@ Match_option {
match_some = (some_var, some_expr);
match_some = (Var.of_name some_var, some_expr, ());
match_none = none_expr }
| _ -> simple_fail "bad option pattern"
in bind_or (as_option () , as_variant ())

185
src/passes/2-simplify/pascaligo.ml
View File

@ -13,19 +13,19 @@ let pseq_to_list = function
| None -> []
| Some lst -> npseq_to_list lst
let get_value : 'a Raw.reg -> 'a = fun x -> x.value
let is_compiler_generated = fun name -> String.contains name '#'
let is_compiler_generated = fun (name) -> String.contains (Var.to_name name) '#'
let detect_local_declarations (for_body : expression) =
let%bind aux = Self_ast_simplified.fold_expression
(fun (nlist, cur_loop : type_name list * bool) (ass_exp : expression) ->
(fun (nlist, cur_loop : expression_variable list * bool) (ass_exp : expression) ->
if cur_loop then
match ass_exp.expression with
| E_let_in {binder;rhs = _;result = _} ->
let (name,_) = binder in
ok (name::nlist, cur_loop)
| E_constant ("MAP_FOLD", _)
| E_constant ("SET_FOLD", _)
| E_constant ("LIST_FOLD", _) -> ok @@ (nlist, false)
| E_constant (C_MAP_FOLD, _)
| E_constant (C_SET_FOLD, _)
| E_constant (C_LIST_FOLD, _) -> ok @@ (nlist, false)
| _ -> ok (nlist, cur_loop)
else
ok @@ (nlist, cur_loop)
@ -34,16 +34,16 @@ let detect_local_declarations (for_body : expression) =
for_body in
ok @@ fst aux
let detect_free_variables (for_body : expression) (local_decl_names : string list) =
let detect_free_variables (for_body : expression) (local_decl_names : expression_variable list) =
let%bind captured_names = Self_ast_simplified.fold_expression
(fun (prev : type_name list) (ass_exp : expression) ->
(fun (prev : expression_variable list) (ass_exp : expression) ->
match ass_exp.expression with
| E_assign ( name , _ , _ ) ->
if is_compiler_generated name then ok prev
else ok (name::prev)
| E_constant (n, [a;b])
when n="OR" || n="AND" || n="LT" || n="GT" ||
n="LE" || n="GE" || n="EQ" || n="NEQ" -> (
when n=C_OR || n=C_AND || n=C_LT || n=C_GT ||
n=C_LE || n=C_GE || n=C_EQ || n=C_NEQ -> (
match (a.expression,b.expression) with
| E_variable na , E_variable nb ->
let ret = [] in
@ -60,6 +60,8 @@ let detect_free_variables (for_body : expression) (local_decl_names : string lis
| _ -> ok prev )
[]
for_body in
let captured_names = List.map (fun (s) -> Var.to_name s) captured_names in
let local_decl_names = List.map (fun (s) -> Var.to_name s) local_decl_names in
ok @@ SSet.elements
@@ SSet.diff (SSet.of_list captured_names) (SSet.of_list local_decl_names)
@ -227,24 +229,24 @@ let rec simpl_type_expression (t:Raw.type_expr) : type_expression result =
match t with
TPar x -> simpl_type_expression x.value.inside
| TVar v -> (
match List.assoc_opt v.value type_constants with
| Some s -> ok @@ T_constant (s , [])
| None -> ok @@ T_variable v.value
match type_constants v.value with
| Ok (s,_) -> ok @@ make_t @@ T_constant s
| Error _ -> ok @@ make_t @@ T_variable (Var.of_name v.value)
)
| TFun x -> (
let%bind (a , b) =
let (a , _ , b) = x.value in
bind_map_pair simpl_type_expression (a , b) in
ok @@ T_function (a , b)
ok @@ make_t @@ T_arrow (a , b)
)
| TApp x ->
let (name, tuple) = x.value in
let lst = npseq_to_list tuple.value.inside in
let%bind lst' = bind_list @@ List.map simpl_type_expression lst in
let%bind lst = bind_list @@ List.map simpl_type_expression lst in (** TODO: fix constant and operator*)
let%bind cst =
trace_option (unknown_predefined_type name) @@
List.assoc_opt name.value type_constants in
ok @@ T_constant (cst , lst')
trace (unknown_predefined_type name) @@
type_operators name.value in
ok @@ t_operator cst lst
| TProd p ->
let%bind tpl = simpl_list_type_expression
@@ npseq_to_list p.value in
@ -260,8 +262,8 @@ let rec simpl_type_expression (t:Raw.type_expr) : type_expression result =
@@ List.map aux
@@ List.map apply
@@ npseq_to_list r.value.ne_elements in
let m = List.fold_left (fun m (x, y) -> SMap.add x y m) SMap.empty lst in
ok @@ T_record m
let m = List.fold_left (fun m (x, y) -> LMap.add (Label x) y m) LMap.empty lst in
ok @@ make_t @@ T_record m
| TSum s ->
let aux (v:Raw.variant Raw.reg) =
let args =
@ -275,8 +277,8 @@ let rec simpl_type_expression (t:Raw.type_expr) : type_expression result =
let%bind lst = bind_list
@@ List.map aux
@@ npseq_to_list s.value in
let m = List.fold_left (fun m (x, y) -> SMap.add x y m) SMap.empty lst in
ok @@ T_sum m
let m = List.fold_left (fun m (x, y) -> CMap.add (Constructor x) y m) CMap.empty lst in
ok @@ make_t @@ T_sum m
and simpl_list_type_expression (lst:Raw.type_expr list) : type_expression result =
match lst with
@ -284,12 +286,12 @@ and simpl_list_type_expression (lst:Raw.type_expr list) : type_expression result
| [hd] -> simpl_type_expression hd
| lst ->
let%bind lst = bind_list @@ List.map simpl_type_expression lst in
ok @@ T_tuple lst
ok @@ make_t @@ T_tuple lst
let simpl_projection : Raw.projection Region.reg -> _ = fun p ->
let (p' , loc) = r_split p in
let var =
let name = p'.struct_name.value in
let name = Var.of_name p'.struct_name.value in
e_variable name in
let path = p'.field_path in
let path' =
@ -313,9 +315,9 @@ let rec simpl_expression (t:Raw.expr) : expr result =
)
| EVar c -> (
let (c' , loc) = r_split c in
match List.assoc_opt c' constants with
| None -> return @@ e_variable ~loc c.value
| Some s -> return @@ e_constant ~loc s []
match constants c' with
| Error _ -> return @@ e_variable ~loc (Var.of_name c.value)
| Ok (s,_) -> return @@ e_constant ~loc s []
)
| ECall x -> (
let ((f, args) , loc) = r_split x in
@ -324,11 +326,11 @@ let rec simpl_expression (t:Raw.expr) : expr result =
match f with
| EVar name -> (
let (f_name , f_loc) = r_split name in
match List.assoc_opt f_name constants with
| None ->
match constants f_name with
| Error _ ->
let%bind arg = simpl_tuple_expression ~loc:args_loc args' in
return @@ e_application ~loc (e_variable ~loc:f_loc f_name) arg
| Some s ->
return @@ e_application ~loc (e_variable ~loc:f_loc (Var.of_name f_name)) arg
| Ok (s,_) ->
let%bind lst = bind_map_list simpl_expression args' in
return @@ e_constant ~loc s lst
)
@ -373,7 +375,7 @@ let rec simpl_expression (t:Raw.expr) : expr result =
let%bind arg =
simpl_tuple_expression ~loc:args_loc
@@ npseq_to_list args.inside in
return @@ e_constant ~loc "SOME" [arg]
return @@ e_constant ~loc C_SOME [arg]
| EConstr (NoneExpr reg) -> (
let loc = Location.lift reg in
return @@ e_none ~loc ()
@ -468,7 +470,7 @@ let rec simpl_expression (t:Raw.expr) : expr result =
let%bind path = match lu.path with
| Name v -> (
let (v , loc) = r_split v in
return @@ e_variable ~loc v
return @@ e_variable ~loc (Var.of_name v)
)
| Path p -> simpl_projection p
in
@ -534,7 +536,7 @@ and simpl_set_expression (t:Raw.set_expr) : expression result =
let (x' , loc) = r_split x in
let%bind set' = simpl_expression x'.set in
let%bind element' = simpl_expression x'.element in
ok @@ e_constant ~loc "SET_MEM" [ element' ; set' ]
ok @@ e_constant ~loc C_SET_MEM [ element' ; set' ]
)
| SetInj x -> (
let (x' , loc) = r_split x in
@ -548,12 +550,14 @@ and simpl_binop (name:string) (t:_ Raw.bin_op Region.reg) : expression result =
let (t , loc) = r_split t in
let%bind a = simpl_expression t.arg1 in
let%bind b = simpl_expression t.arg2 in
let%bind name = constants name in
return @@ e_constant ~loc name [ a ; b ]
and simpl_unop (name:string) (t:_ Raw.un_op Region.reg) : expression result =
let return x = ok x in
let (t , loc) = r_split t in
let%bind a = simpl_expression t.arg in
let%bind name = constants name in
return @@ e_constant ~loc name [ a ]
and simpl_tuple_expression ?loc (lst:Raw.expr list) : expression result =
@ -577,35 +581,35 @@ and simpl_data_declaration : Raw.data_decl -> _ result = fun t ->
let name = x.name.value in
let%bind t = simpl_type_expression x.var_type in
let%bind expression = simpl_expression x.init in
return_let_in ~loc (name , Some t) expression
return_let_in ~loc (Var.of_name name , Some t) expression
| LocalConst x ->
let (x , loc) = r_split x in
let name = x.name.value in
let%bind t = simpl_type_expression x.const_type in
let%bind expression = simpl_expression x.init in
return_let_in ~loc (name , Some t) expression
return_let_in ~loc (Var.of_name name , Some t) expression
| LocalFun f ->
let (f , loc) = r_split f in
let%bind ((name_opt , ty_opt) , e) = simpl_fun_expression ~loc f.fun_expr.value in
let%bind name = trace_option (unexpected_anonymous_function loc) name_opt in
return_let_in ~loc (name , ty_opt) e
and simpl_param : Raw.param_decl -> (type_name * type_expression) result =
and simpl_param : Raw.param_decl -> (expression_variable * type_expression) result =
fun t ->
match t with
| ParamConst c ->
let c = c.value in
let type_name = c.var.value in
let type_name = Var.of_name c.var.value in
let%bind type_expression = simpl_type_expression c.param_type in
ok (type_name , type_expression)
| ParamVar v ->
let c = v.value in
let type_name = c.var.value in
let type_name = Var.of_name c.var.value in
let%bind type_expression = simpl_type_expression c.param_type in
ok (type_name , type_expression)
and simpl_fun_expression :
loc:_ -> Raw.fun_expr -> ((name option * type_expression option) * expression) result =
loc:_ -> Raw.fun_expr -> ((expression_variable option * type_expression option) * expression) result =
fun ~loc x ->
let open! Raw in
let {name;param;ret_type;local_decls;block;return} : fun_expr = x in
@ -617,7 +621,7 @@ and simpl_fun_expression :
(match param.value.inside with
a, [] -> (
let%bind input = simpl_param a in
let name = Option.map (fun (x : _ reg) -> x.value) name in
let name = Option.map (fun (x : _ reg) -> Var.of_name x.value) name in
let (binder , input_type) = input in
let%bind local_declarations =
bind_map_list simpl_local_declaration local_decls in
@ -632,12 +636,12 @@ and simpl_fun_expression :
bind_fold_right_list aux result body in
let expression : expression = e_lambda ~loc binder (Some input_type)
(Some output_type) result in
let type_annotation = Some (T_function (input_type, output_type)) in
let type_annotation = Some (make_t @@ T_arrow (input_type, output_type)) in
ok ((name , type_annotation) , expression)
)
| lst -> (
let lst = npseq_to_list lst in
let arguments_name = "arguments" in
let arguments_name = Var.of_name "arguments" in (* TODO wrong, should be fresh? *)
let%bind params = bind_map_list simpl_param lst in
let (binder , input_type) =
let type_expression = T_tuple (List.map snd params) in
@ -645,8 +649,8 @@ and simpl_fun_expression :
let%bind tpl_declarations =
let aux = fun i x ->
let expr = e_accessor (e_variable arguments_name) [Access_tuple i] in
let type_ = Some (snd x) in
let ass = return_let_in (fst x , type_) expr in
let type_variable = Some (snd x) in
let ass = return_let_in (fst x , type_variable) expr in
ass
in
bind_list @@ List.mapi aux params in
@ -662,9 +666,9 @@ and simpl_fun_expression :
let aux prec cur = cur (Some prec) in
bind_fold_right_list aux result body in
let expression =
e_lambda ~loc binder (Some input_type) (Some output_type) result in
let type_annotation = Some (T_function (input_type, output_type)) in
let name = Option.map (fun (x : _ reg) -> x.value) name in
e_lambda ~loc binder (Some (make_t @@ input_type)) (Some output_type) result in
let type_annotation = Some (make_t @@ T_arrow (make_t input_type, output_type)) in
let name = Option.map (fun (x : _ reg) -> Var.of_name x.value) name in
ok ((name , type_annotation) , expression)
)
)
@ -676,14 +680,14 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap result =
let (x , loc) = r_split x in
let {name;type_expr} : Raw.type_decl = x in
let%bind type_expression = simpl_type_expression type_expr in
ok @@ Location.wrap ~loc (Declaration_type (name.value , type_expression))
ok @@ Location.wrap ~loc (Declaration_type (Var.of_name name.value , type_expression))
)
| ConstDecl x ->
let simpl_const_decl = fun {name;const_type;init} ->
let%bind expression = simpl_expression init in
let%bind t = simpl_type_expression const_type in
let type_annotation = Some t in
ok @@ Declaration_constant (name.value , type_annotation , expression)
ok @@ Declaration_constant (Var.of_name name.value , type_annotation , expression)
in
bind_map_location simpl_const_decl (Location.lift_region x)
| FunDecl x -> (
@ -709,11 +713,11 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
match f with
| EVar name -> (
let (f_name , f_loc) = r_split name in
match List.assoc_opt f_name constants with
| None ->
match constants f_name with
| Error _ ->
let%bind arg = simpl_tuple_expression ~loc:args_loc args' in
return_statement @@ e_application ~loc (e_variable ~loc:f_loc f_name) arg
| Some s ->
return_statement @@ e_application ~loc (e_variable ~loc:f_loc (Var.of_name f_name)) arg
| Ok (s,_) ->
let%bind lst = bind_map_list simpl_expression args' in
return_statement @@ e_constant ~loc s lst
)
@ -777,7 +781,7 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
| MapPath v -> (
let v' = v.value in
let%bind (varname,map,path) = match v'.path with
| Name name -> ok (name.value , e_variable name.value, [])
| Name name -> ok (name.value , e_variable (Var.of_name name.value), [])
| Path p ->
let (name,p') = simpl_path v'.path in
let%bind accessor = simpl_projection p in
@ -859,7 +863,7 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
let assigns = List.fold_right
(fun (key, value) map -> (e_map_add key value map))
inj
(e_accessor ~loc (e_variable name) access_path)
(e_accessor ~loc (e_variable (Var.of_name name)) access_path)
in e_assign ~loc name access_path assigns
in return_statement @@ expr
)
@ -875,8 +879,8 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
| [] -> e_skip ~loc ()
| _ :: _ ->
let assigns = List.fold_right
(fun hd s -> e_constant "SET_ADD" [hd ; s])
inj (e_accessor ~loc (e_variable name) access_path) in
(fun hd s -> e_constant C_SET_ADD [hd ; s])
inj (e_accessor ~loc (e_variable (Var.of_name name)) access_path) in
e_assign ~loc name access_path assigns in
return_statement @@ expr
)
@ -884,27 +888,27 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
let (v , loc) = r_split r in
let key = v.key in
let%bind (varname,map,path) = match v.map with
| Name v -> ok (v.value , e_variable v.value , [])
| Name v -> ok (v.value , e_variable (Var.of_name v.value) , [])
| Path p ->
let (name,p') = simpl_path v.map in
let%bind accessor = simpl_projection p in
ok @@ (name , accessor , p')
in
let%bind key' = simpl_expression key in
let expr = e_constant ~loc "MAP_REMOVE" [key' ; map] in
let expr = e_constant ~loc C_MAP_REMOVE [key' ; map] in
return_statement @@ e_assign ~loc varname path expr
)
| SetRemove r -> (
let (set_rm, loc) = r_split r in
let%bind (varname, set, path) = match set_rm.set with
| Name v -> ok (v.value, e_variable v.value, [])
| Name v -> ok (v.value, e_variable (Var.of_name v.value), [])
| Path path ->
let(name, p') = simpl_path set_rm.set in
let%bind accessor = simpl_projection path in
ok @@ (name, accessor, p')
in
let%bind removed' = simpl_expression set_rm.element in
let expr = e_constant ~loc "SET_REMOVE" [removed' ; set] in
let expr = e_constant ~loc C_SET_REMOVE [removed' ; set] in
return_statement @@ e_assign ~loc varname path expr
)
@ -925,7 +929,7 @@ and simpl_path : Raw.path -> string * Ast_simplified.access_path = fun p ->
(var , path')
)
and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t ->
and simpl_cases : type a . (Raw.pattern * a) list -> (a, unit) matching result = fun t ->
let open Raw in
let get_var (t:Raw.pattern) =
match t with
@ -977,7 +981,7 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t -
let%bind v = match v.value.inside with
| PVar v -> ok v.value
| p -> fail @@ unsupported_deep_Some_patterns p in
ok @@ Match_option {match_none = none ; match_some = (v, some) }
ok @@ Match_option {match_none = none ; match_some = (Var.of_name v, some, ()) }
)
| [(PList PCons c, cons) ; (PList (PNil _), nil)]
| [(PList (PNil _), nil) ; (PList PCons c, cons)] ->
@ -988,8 +992,9 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t -
let%bind b = get_var b in
ok (a, b)
| _ -> fail @@ unsupported_deep_list_patterns c
in
ok @@ Match_list {match_cons = (a, b, cons) ; match_nil = nil}
ok @@ Match_list {match_cons = (Var.of_name a, Var.of_name b, cons,()) ; match_nil = nil}
| lst ->
trace (simple_info "currently, only booleans, options, lists and \
user-defined constructors are supported in patterns") @@
@ -1006,7 +1011,7 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t -
get_constr x in
ok (x' , y) in
bind_map_list aux lst in
ok @@ Match_variant constrs
ok @@ ez_match_variant constrs
and simpl_instruction : Raw.instruction -> (_ -> expression result) result =
fun t ->
@ -1029,23 +1034,23 @@ and simpl_block : Raw.block -> (_ -> expression result) result = fun t ->
and simpl_for_int : Raw.for_int -> (_ -> expression result) result = fun fi ->
(* cond part *)
let var = e_variable fi.assign.value.name.value in
let var = e_variable (Var.of_name fi.assign.value.name.value) in
let%bind value = simpl_expression fi.assign.value.expr in
let%bind bound = simpl_expression fi.bound in
let comp = e_annotation (e_constant "LE" [var ; bound]) t_bool
let comp = e_annotation (e_constant C_LE [var ; bound]) t_bool
in
(* body part *)
let%bind body = simpl_block fi.block.value in
let%bind body = body None in
let step = e_int 1 in
let ctrl = e_assign
fi.assign.value.name.value [] (e_constant "ADD" [ var ; step ]) in
fi.assign.value.name.value [] (e_constant C_ADD [ var ; step ]) in
let rec add_to_seq expr = match expr.expression with
| E_sequence (_,a) -> add_to_seq a
| _ -> e_sequence body ctrl in
let body' = add_to_seq body in
let loop = e_loop comp body' in
return_statement @@ e_let_in (fi.assign.value.name.value, Some t_int) value loop
return_statement @@ e_let_in (Var.of_name fi.assign.value.name.value, Some t_int) value loop
(** simpl_for_collect
For loops over collections, like
@ -1141,8 +1146,8 @@ and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun
| Some v -> "#COMPILER#elt_"^(snd v).value
| None -> "#COMPILER#elt_unused" in
let element_names = ok @@ match fc.bind_to with
| Some v -> [fc.var.value;(snd v).value]
| None -> [fc.var.value] in
| Some v -> [Var.of_name fc.var.value;Var.of_name (snd v).value]
| None -> [Var.of_name fc.var.value] in
(* STEP 1 *)
let%bind for_body = simpl_block fc.block.value in
let%bind for_body = for_body None in
@ -1150,8 +1155,8 @@ and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun
let%bind local_decl_name_list = bind_concat (detect_local_declarations for_body) element_names in
let%bind captured_name_list = detect_free_variables for_body local_decl_name_list in
(* STEP 3 *)
let add_to_record (prev: expression type_name_map) (captured_name: string) =
SMap.add captured_name (e_variable captured_name) prev in
let add_to_record (prev: expression SMap.t) (captured_name: string) =
SMap.add captured_name (e_variable (Var.of_name captured_name)) prev in
let init_record = e_record (List.fold_left add_to_record SMap.empty captured_name_list) in
(* STEP 4 *)
let replace exp =
@ -1161,27 +1166,29 @@ and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun
if (List.mem name local_decl_name_list ) then
ok @@ exp
else
let name = Var.to_name name in
let path' = List.filter
( fun el ->
match el with
| Access_record name -> not @@ is_compiler_generated name
| Access_record name -> not @@ is_compiler_generated (Var.of_name name)
| _ -> true )
((Access_record name)::path) in
ok @@ e_assign "#COMPILER#acc" path' expr )
| E_variable name -> (
let name = Var.to_name name in
if (List.mem name captured_name_list) then
(* replace references to fold accumulator as rhs *)
ok @@ e_accessor (e_variable "#COMPILER#acc") [Access_record name]
ok @@ e_accessor (e_variable (Var.of_name "#COMPILER#acc")) [Access_record name] (* TODO fresh *)
else match fc.collection with
(* loop on map *)
| Map _ ->
let k' = e_variable elt_name in
let k' = e_variable (Var.of_name elt_name) in
if ( name = fc.var.value ) then
ok @@ k' (* replace references to the the key *)
else (
match fc.bind_to with
| Some (_,v) ->
let v' = e_variable elt_v_name in
let v' = e_variable (Var.of_name elt_v_name) in
if ( name = v.value ) then
ok @@ v' (* replace references to the the value *)
else ok @@ exp
@ -1191,7 +1198,7 @@ and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun
| (Set _ | List _) ->
if (name = fc.var.value ) then
(* replace references to the collection element *)
ok @@ (e_variable elt_name)
ok @@ (e_variable (Var.of_name elt_name))
else ok @@ exp
)
| _ -> ok @@ exp in
@ -1199,34 +1206,34 @@ and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun
(* STEP 5 *)
let rec add_return (expr : expression) = match expr.expression with
| E_sequence (a,b) -> e_sequence a (add_return b)
| _ -> e_sequence expr (e_variable "#COMPILER#acc") in
| _ -> e_sequence expr (e_variable (Var.of_name "#COMPILER#acc")) in (* TODO fresh *)
let for_body = add_return for_body in
(* STEP 6 *)
let for_body =
let ( arg_access: Types.access_path -> expression ) = e_accessor (e_variable "arguments") in
let ( arg_access: Types.access_path -> expression ) = e_accessor (e_variable (Var.of_name "arguments")) in (* TODO fresh *)
( match fc.collection with
| Map _ ->
let acc = arg_access [Access_tuple 0 ] in
let collec_elt_v = arg_access [Access_tuple 1 ; Access_tuple 0] in
let collec_elt_k = arg_access [Access_tuple 1 ; Access_tuple 1] in
e_let_in ("#COMPILER#acc", None) acc @@
e_let_in (elt_name, None) collec_elt_v @@
e_let_in (elt_v_name, None) collec_elt_k (for_body)
e_let_in (Var.of_name "#COMPILER#acc", None) acc @@ (* TODO fresh *)
e_let_in (Var.of_name elt_name, None) collec_elt_v @@
e_let_in (Var.of_name elt_v_name, None) collec_elt_k (for_body)
| _ ->
let acc = arg_access [Access_tuple 0] in
let collec_elt = arg_access [Access_tuple 1] in
e_let_in ("#COMPILER#acc", None) acc @@
e_let_in (elt_name, None) collec_elt (for_body)
e_let_in (Var.of_name "#COMPILER#acc", None) acc @@ (* TODO fresh *)
e_let_in (Var.of_name elt_name, None) collec_elt (for_body)
) in
(* STEP 7 *)
let%bind collect = simpl_expression fc.expr in
let lambda = e_lambda "arguments" None None for_body in
let lambda = e_lambda (Var.of_name "arguments") None None for_body in
let op_name = match fc.collection with
| Map _ -> "MAP_FOLD" | Set _ -> "SET_FOLD" | List _ -> "LIST_FOLD" in
| Map _ -> C_MAP_FOLD | Set _ -> C_SET_FOLD | List _ -> C_LIST_FOLD in
let fold = e_constant op_name [lambda; collect ; init_record] in
(* STEP 8 *)
let assign_back (prev : expression option) (captured_varname : string) : expression option =
let access = e_accessor (e_variable "#COMPILER#folded_record")
let access = e_accessor (e_variable (Var.of_name "#COMPILER#folded_record")) (* TODO fresh *)
[Access_record captured_varname] in
let assign = e_assign captured_varname [] access in
match prev with
@ -1237,7 +1244,7 @@ and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun
let final_sequence = match reassign_sequence with
(* None case means that no variables were captured *)
| None -> e_skip ()
| Some seq -> e_let_in ("#COMPILER#folded_record", None) fold seq in
| Some seq -> e_let_in (Var.of_name "#COMPILER#folded_record", None) fold seq in (* TODO fresh *)
return_statement @@ final_sequence
let simpl_program : Raw.ast -> program result = fun t ->

34
src/passes/3-self_ast_simplified/helpers.ml
View File

@ -20,7 +20,7 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
ok res
)
| E_lambda { binder = _ ; input_type = _ ; output_type = _ ; result = e }
| E_annotation (e , _) | E_constructor (_ , e) -> (
| E_ascription (e , _) | E_constructor (_ , e) -> (
let%bind res = self init' e in
ok res
)
@ -38,7 +38,7 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
let%bind res = fold_expression self init'' expr in
ok res
in
let%bind res = bind_fold_smap aux (ok init') m in
let%bind res = bind_fold_lmap aux (ok init') m in
ok res
)
| E_let_in { binder = _ ; rhs ; result } -> (
@ -54,21 +54,21 @@ and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
let%bind res = fold_expression f res match_false in
ok res
)
| Match_list { match_nil ; match_cons = (_ , _ , cons) } -> (
| Match_list { match_nil ; match_cons = (_ , _ , cons, _) } -> (
let%bind res = fold_expression f init match_nil in
let%bind res = fold_expression f res cons in
ok res
)
| Match_option { match_none ; match_some = (_ , some) } -> (
| Match_option { match_none ; match_some = (_ , some, _) } -> (
let%bind res = fold_expression f init match_none in
let%bind res = fold_expression f res some in
ok res
)
| Match_tuple (_ , e) -> (
| Match_tuple ((_ , e), _) -> (
let%bind res = fold_expression f init e in
ok res
)
| Match_variant lst -> (
| Match_variant (lst, _) -> (
let aux init' ((_ , _) , e) =
let%bind res' = fold_expression f init' e in
ok res' in
@ -110,9 +110,9 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
let%bind ab' = bind_map_pair self ab in
return @@ E_loop ab'
)
| E_annotation (e , t) -> (
| E_ascription (e , t) -> (
let%bind e' = self e in
return @@ E_annotation (e' , t)
return @@ E_ascription (e' , t)
)
| E_assign (name , path , e) -> (
let%bind e' = self e in
@ -128,7 +128,7 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
return @@ E_accessor (e' , path)
)
| E_record m -> (
let%bind m' = bind_map_smap self m in
let%bind m' = bind_map_lmap self m in
return @@ E_record m'
)
| E_constructor (name , e) -> (
@ -166,27 +166,27 @@ and map_cases : mapper -> matching_expr -> matching_expr result = fun f m ->
let%bind match_false = map_expression f match_false in
ok @@ Match_bool { match_true ; match_false }
)
| Match_list { match_nil ; match_cons = (hd , tl , cons) } -> (
| Match_list { match_nil ; match_cons = (hd , tl , cons, _) } -> (
let%bind match_nil = map_expression f match_nil in
let%bind cons = map_expression f cons in
ok @@ Match_list { match_nil ; match_cons = (hd , tl , cons) }
ok @@ Match_list { match_nil ; match_cons = (hd , tl , cons, ()) }
)
| Match_option { match_none ; match_some = (name , some) } -> (
| Match_option { match_none ; match_some = (name , some, _) } -> (
let%bind match_none = map_expression f match_none in
let%bind some = map_expression f some in
ok @@ Match_option { match_none ; match_some = (name , some) }
ok @@ Match_option { match_none ; match_some = (name , some, ()) }
)
| Match_tuple (names , e) -> (
| Match_tuple ((names , e), _) -> (
let%bind e' = map_expression f e in
ok @@ Match_tuple (names , e')
ok @@ Match_tuple ((names , e'), [])
)
| Match_variant lst -> (
| Match_variant (lst, _) -> (
let aux ((a , b) , e) =
let%bind e' = map_expression f e in
ok ((a , b) , e')
in
let%bind lst' = bind_map_list aux lst in
ok @@ Match_variant lst'
ok @@ Match_variant (lst', ())
)
and map_program : mapper -> program -> program result = fun m p ->

12
src/passes/3-self_ast_simplified/literals.ml
View File

@ -4,7 +4,7 @@ open Trace
let peephole_expression : expression -> expression result = fun e ->
let return expression = ok { e with expression } in
match e.expression with
| E_constant ("BIG_MAP_LITERAL" , lst) -> (
| E_constant (C_BIG_MAP_LITERAL , lst) -> (
let%bind elt =
trace_option (simple_error "big_map literal expects a single parameter") @@
List.to_singleton lst
@ -25,7 +25,7 @@ let peephole_expression : expression -> expression result = fun e ->
let%bind pairs = bind_map_list aux lst in
return @@ E_big_map pairs
)
| E_constant ("MAP_LITERAL" , lst) -> (
| E_constant (C_MAP_LITERAL, lst) -> (
let%bind elt =
trace_option (simple_error "map literal expects a single parameter") @@
List.to_singleton lst
@ -46,21 +46,21 @@ let peephole_expression : expression -> expression result = fun e ->
let%bind pairs = bind_map_list aux lst in
return @@ E_map pairs
)
| E_constant ("BIG_MAP_EMPTY" , lst) -> (
| E_constant (C_BIG_MAP_EMPTY, lst) -> (
let%bind () =
trace_strong (simple_error "BIG_MAP_EMPTY expects no parameter") @@
Assert.assert_list_empty lst
in
return @@ E_big_map []
)
| E_constant ("MAP_EMPTY" , lst) -> (
| E_constant (C_MAP_EMPTY, lst) -> (
let%bind () =
trace_strong (simple_error "MAP_EMPTY expects no parameter") @@
Assert.assert_list_empty lst
in
return @@ E_map []
)
| E_constant ("SET_LITERAL" , lst) -> (
| E_constant (C_SET_LITERAL, lst) -> (
let%bind elt =
trace_option (simple_error "map literal expects a single parameter") @@
List.to_singleton lst
@ -71,7 +71,7 @@ let peephole_expression : expression -> expression result = fun e ->
in
return @@ E_set lst
)
| E_constant ("SET_EMPTY" , lst) -> (
| E_constant (C_SET_EMPTY, lst) -> (
let%bind () =
trace_strong (simple_error "SET_EMPTY expects no parameter") @@
Assert.assert_list_empty lst

4
src/passes/3-self_ast_simplified/none_variant.ml
View File

@ -4,6 +4,6 @@ open Trace
let peephole_expression : expression -> expression result = fun e ->
let return expression = ok { e with expression } in
match e.expression with
| E_constructor ("Some" , e) -> return @@ E_constant ("SOME" , [ e ])
| E_constructor ("None" , _) -> return @@ E_constant ("NONE" , [ ])
| E_constructor (Constructor "Some" , e) -> return @@ E_constant (C_SOME , [ e ])
| E_constructor (Constructor "None" , _) -> return @@ E_constant (C_NONE , [ ])
| e -> return e

8
src/passes/3-self_ast_simplified/tezos_type_annotation.ml
View File

@ -4,10 +4,10 @@ open Trace
let peephole_expression : expression -> expression result = fun e ->
let return expression = ok { e with expression } in
match e.expression with
| E_annotation (e' , t) as e -> (
match (e'.expression , t) with
| (E_literal (Literal_string str) , T_constant ("address" , [])) -> return @@ E_literal (Literal_address str)
| (E_literal (Literal_string str) , T_constant ("bytes" , [])) -> (
| E_ascription (e' , t) as e -> (
match (e'.expression , t.type_expression') with
| (E_literal (Literal_string str) , T_constant (TC_address)) -> return @@ E_literal (Literal_address str)
| (E_literal (Literal_string str) , T_constant (TC_bytes)) -> (
let%bind e' = e'_bytes str in
return e'
)

231
src/passes/4-typer-new/solver.ml
View File

@ -37,83 +37,88 @@ module Wrap = struct
| T_tuple types ->
P_constant (C_tuple, List.map type_expression_to_type_value types)
| T_sum kvmap ->
P_constant (C_variant, Map.String.to_list @@ Map.String.map type_expression_to_type_value kvmap)
P_constant (C_variant, T.CMap.to_list @@ T.CMap.map type_expression_to_type_value kvmap)
| T_record kvmap ->
P_constant (C_record, Map.String.to_list @@ Map.String.map type_expression_to_type_value kvmap)
| T_function (arg , ret) ->
P_constant (C_record, T.LMap.to_list @@ T.LMap.map type_expression_to_type_value kvmap)
| T_arrow (arg , ret) ->
P_constant (C_arrow, List.map type_expression_to_type_value [ arg ; ret ])
| T_variable (Type_name type_name) -> P_variable type_name
| T_constant (Type_name type_name , args) ->
| T_variable (type_name) -> P_variable type_name
| T_constant (type_name) ->
let csttag = Core.(match type_name with
| "arrow" -> C_arrow
| "option" -> C_option
| "tuple" -> C_tuple
(* record *)
(* variant *)
| "map" -> C_map
| "big_map" -> C_map
| "list" -> C_list
| "set" -> C_set
| "unit" -> C_unit
| "bool" -> C_bool
| "string" -> C_string
| "nat" -> C_nat
| "mutez" -> C_tez (* TODO: rename tez to mutez*)
| "timestamp" -> C_timestamp
| "int" -> C_int
| "address" -> C_address
| "bytes" -> C_bytes
| "key_hash" -> C_key_hash
| "key" -> C_key
| "signature" -> C_signature
| "operation" -> C_operation
| "contract" -> C_contract
| unknown ->
(* TODO: return a Trace.result *)
let _ = fail (fun () -> Errors.unknown_type_constructor unknown te ()) in
failwith ("unknown type constructor " ^ unknown))
| TC_unit -> C_unit
| TC_bool -> C_bool
| TC_string -> C_string
| TC_nat -> C_nat
| TC_mutez -> C_mutez
| TC_timestamp -> C_timestamp
| TC_int -> C_int
| TC_address -> C_address
| TC_bytes -> C_bytes
| TC_key_hash -> C_key_hash
| TC_key -> C_key
| TC_signature -> C_signature
| TC_operation -> C_operation
| TC_chain_id -> C_unit (* TODO : replace with chain_id*)
)
in
P_constant (csttag, [])
| T_operator (type_operator) ->
let (csttag, args) = Core.(match type_operator with
| TC_option o -> (C_option, [o])
| 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_list l -> (C_list, [l])
| TC_contract c -> (C_contract, [c])
)
in
P_constant (csttag, List.map type_expression_to_type_value args)
let rec type_expression_to_type_value_copypasted : I.type_expression -> O.type_value = fun te ->
match te with
match te.type_expression' with
| T_tuple types ->
P_constant (C_tuple, List.map type_expression_to_type_value_copypasted types)
| T_sum kvmap ->
P_constant (C_variant, Map.String.to_list @@ Map.String.map type_expression_to_type_value_copypasted kvmap)
P_constant (C_variant, I.CMap.to_list @@ I.CMap.map type_expression_to_type_value_copypasted kvmap)
| T_record kvmap ->
P_constant (C_record, Map.String.to_list @@ Map.String.map type_expression_to_type_value_copypasted kvmap)
| T_function (arg , ret) ->
P_constant (C_record, I.LMap.to_list @@ I.LMap.map type_expression_to_type_value_copypasted kvmap)
| T_arrow (arg , ret) ->
P_constant (C_arrow, List.map type_expression_to_type_value_copypasted [ arg ; ret ])
| T_variable type_name -> P_variable type_name
| T_constant (type_name , args) ->
| T_constant (type_name) ->
let csttag = Core.(match type_name with
| "arrow" -> C_arrow
| "option" -> C_option
| "tuple" -> C_tuple
| "map" -> C_map
| "list" -> C_list
| "set" -> C_set
| "unit" -> C_unit
| "bool" -> C_bool
| "string" -> C_string
| TC_unit -> C_unit
| TC_bool -> C_bool
| TC_string -> C_string
| _ -> failwith "unknown type constructor")
in
P_constant (csttag,[])
| T_operator (type_name) ->
let (csttag, args) = Core.(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_contract c -> (C_contract, [c])
)
in
P_constant (csttag, List.map type_expression_to_type_value_copypasted args)
let failwith_ : unit -> (constraints * O.type_variable) = fun () ->
let type_name = Core.fresh_type_variable () in
[] , type_name
let variable : I.name -> T.type_value -> (constraints * T.type_name) = fun _name expr ->
let variable : I.expression_variable -> T.type_value -> (constraints * T.type_variable) = fun _name expr ->
let pattern = type_expression_to_type_value expr in
let type_name = Core.fresh_type_variable () in
[C_equation (P_variable (type_name) , pattern)] , Type_name type_name
[C_equation (P_variable (type_name) , pattern)] , type_name
let literal : T.type_value -> (constraints * T.type_name) = fun t ->
let literal : T.type_value -> (constraints * T.type_variable) = fun t ->
let pattern = type_expression_to_type_value t in
let type_name = Core.fresh_type_variable () in
[C_equation (P_variable (type_name) , pattern)] , Type_name type_name
[C_equation (P_variable (type_name) , pattern)] , type_name
(*
let literal_bool : unit -> (constraints * O.type_variable) = fun () ->
@ -127,11 +132,11 @@ module Wrap = struct
[C_equation (P_variable (type_name) , pattern)] , type_name
*)
let tuple : T.type_value list -> (constraints * T.type_name) = fun tys ->
let tuple : T.type_value list -> (constraints * T.type_variable) = fun tys ->
let patterns = List.map type_expression_to_type_value tys in
let pattern = O.(P_constant (C_tuple , patterns)) in
let type_name = Core.fresh_type_variable () in
[C_equation (P_variable (type_name) , pattern)] , Type_name type_name
[C_equation (P_variable (type_name) , pattern)] , type_name
(* let t_tuple = ('label:int, 'v) … -> record ('label : 'v) … *)
(* let t_constructor = ('label:string, 'v) -> variant ('label : 'v) *)
@ -157,16 +162,16 @@ module Wrap = struct
end
(* TODO: I think we should take an I.expression for the base+label *)
let access_label ~(base : T.type_value) ~(label : O.label) : (constraints * T.type_name) =
let access_label ~(base : T.type_value) ~(label : O.accessor) : (constraints * T.type_variable) =
let base' = type_expression_to_type_value base in
let expr_type = Core.fresh_type_variable () in
[O.C_access_label (base' , label , expr_type)] , Type_name expr_type
[O.C_access_label (base' , label , expr_type)] , expr_type
let access_int ~base ~index = access_label ~base ~label:(L_int index)
let access_string ~base ~property = access_label ~base ~label:(L_string property)
let constructor
: T.type_value -> T.type_value -> T.type_value -> (constraints * T.type_name)
: T.type_value -> T.type_value -> T.type_value -> (constraints * T.type_variable)
= fun t_arg c_arg sum ->
let t_arg = type_expression_to_type_value t_arg in
let c_arg = type_expression_to_type_value c_arg in
@ -175,14 +180,14 @@ module Wrap = struct
[
C_equation (P_variable (whole_expr) , sum) ;
C_equation (t_arg , c_arg)
] , Type_name whole_expr
] , whole_expr
let record : T.type_value I.type_name_map -> (constraints * T.type_name) = fun fields ->
let record : T.type_value I.label_map -> (constraints * T.type_variable) = fun fields ->
let record_type = type_expression_to_type_value (T.t_record fields ()) in
let whole_expr = Core.fresh_type_variable () in
[C_equation (P_variable whole_expr , record_type)] , Type_name whole_expr
[C_equation (P_variable whole_expr , record_type)] , whole_expr
let collection : O.constant_tag -> T.type_value list -> (constraints * T.type_name) =
let collection : O.constant_tag -> T.type_value list -> (constraints * T.type_variable) =
fun ctor element_tys ->
let elttype = O.P_variable (Core.fresh_type_variable ()) in
let aux elt =
@ -192,12 +197,12 @@ module Wrap = struct
let whole_expr = Core.fresh_type_variable () in
O.[
C_equation (P_variable whole_expr , O.P_constant (ctor , [elttype]))
] @ equations , Type_name whole_expr
] @ equations , whole_expr
let list = collection O.C_list
let set = collection O.C_set
let map : (T.type_value * T.type_value) list -> (constraints * T.type_name) =
let map : (T.type_value * T.type_value) list -> (constraints * T.type_variable) =
fun kv_tys ->
let k_type = O.P_variable (Core.fresh_type_variable ()) in
let v_type = O.P_variable (Core.fresh_type_variable ()) in
@ -212,9 +217,9 @@ module Wrap = struct
let whole_expr = Core.fresh_type_variable () in
O.[
C_equation (P_variable whole_expr , O.P_constant (C_map , [k_type ; v_type]))
] @ equations_k @ equations_v , Type_name whole_expr
] @ equations_k @ equations_v , whole_expr
let big_map : (T.type_value * T.type_value) list -> (constraints * T.type_name) =
let big_map : (T.type_value * T.type_value) list -> (constraints * T.type_variable) =
fun kv_tys ->
let k_type = O.P_variable (Core.fresh_type_variable ()) in
let v_type = O.P_variable (Core.fresh_type_variable ()) in
@ -231,18 +236,18 @@ module Wrap = struct
(* TODO: this doesn't tag big_maps uniquely (i.e. if two
big_map have the same type, they can be swapped. *)
C_equation (P_variable whole_expr , O.P_constant (C_big_map , [k_type ; v_type]))
] @ equations_k @ equations_v , Type_name whole_expr
] @ equations_k @ equations_v , whole_expr
let application : T.type_value -> T.type_value -> (constraints * T.type_name) =
let application : T.type_value -> T.type_value -> (constraints * T.type_variable) =
fun f arg ->
let whole_expr = Core.fresh_type_variable () in
let f' = type_expression_to_type_value f in
let arg' = type_expression_to_type_value arg in
O.[
C_equation (f' , P_constant (C_arrow , [arg' ; P_variable whole_expr]))
] , Type_name whole_expr
] , whole_expr
let look_up : T.type_value -> T.type_value -> (constraints * T.type_name) =
let look_up : T.type_value -> T.type_value -> (constraints * T.type_variable) =
fun ds ind ->
let ds' = type_expression_to_type_value ds in
let ind' = type_expression_to_type_value ind in
@ -251,9 +256,9 @@ module Wrap = struct
O.[
C_equation (ds' , P_constant (C_map, [ind' ; P_variable v])) ;
C_equation (P_variable whole_expr , P_constant (C_option , [P_variable v]))
] , Type_name whole_expr
] , whole_expr
let sequence : T.type_value -> T.type_value -> (constraints * T.type_name) =
let sequence : T.type_value -> T.type_value -> (constraints * T.type_variable) =
fun a b ->
let a' = type_expression_to_type_value a in
let b' = type_expression_to_type_value b in
@ -261,9 +266,9 @@ module Wrap = struct
O.[
C_equation (a' , P_constant (C_unit , [])) ;
C_equation (b' , P_variable whole_expr)
] , Type_name whole_expr
] , whole_expr
let loop : T.type_value -> T.type_value -> (constraints * T.type_name) =
let loop : T.type_value -> T.type_value -> (constraints * T.type_variable) =
fun expr body ->
let expr' = type_expression_to_type_value expr in
let body' = type_expression_to_type_value body in
@ -272,9 +277,9 @@ module Wrap = struct
C_equation (expr' , P_constant (C_bool , [])) ;
C_equation (body' , P_constant (C_unit , [])) ;
C_equation (P_variable whole_expr , P_constant (C_unit , []))
] , Type_name whole_expr
] , whole_expr
let let_in : T.type_value -> T.type_value option -> T.type_value -> (constraints * T.type_name) =
let let_in : T.type_value -> T.type_value option -> T.type_value -> (constraints * T.type_variable) =
fun rhs rhs_tv_opt result ->
let rhs' = type_expression_to_type_value rhs in
let result' = type_expression_to_type_value result in
@ -284,9 +289,9 @@ module Wrap = struct
let whole_expr = Core.fresh_type_variable () in
O.[
C_equation (result' , P_variable whole_expr)
] @ rhs_tv_opt', Type_name whole_expr
] @ rhs_tv_opt', whole_expr
let assign : T.type_value -> T.type_value -> (constraints * T.type_name) =
let assign : T.type_value -> T.type_value -> (constraints * T.type_variable) =
fun v e ->
let v' = type_expression_to_type_value v in
let e' = type_expression_to_type_value e in
@ -294,9 +299,9 @@ module Wrap = struct
O.[
C_equation (v' , e') ;
C_equation (P_variable whole_expr , P_constant (C_unit , []))
] , Type_name whole_expr
] , whole_expr
let annotation : T.type_value -> T.type_value -> (constraints * T.type_name) =
let annotation : T.type_value -> T.type_value -> (constraints * T.type_variable) =
fun e annot ->
let e' = type_expression_to_type_value e in
let annot' = type_expression_to_type_value annot in
@ -304,14 +309,14 @@ module Wrap = struct
O.[
C_equation (e' , annot') ;
C_equation (e' , P_variable whole_expr)
] , Type_name whole_expr
] , whole_expr
let matching : T.type_value list -> (constraints * T.type_name) =
let matching : T.type_value list -> (constraints * T.type_variable) =
fun es ->
let whole_expr = Core.fresh_type_variable () in
let type_values = (List.map type_expression_to_type_value es) in
let cs = List.map (fun e -> O.C_equation (P_variable whole_expr , e)) type_values
in cs, Type_name whole_expr
in cs, whole_expr
let fresh_binder () =
Core.fresh_type_variable ()
@ -320,7 +325,7 @@ module Wrap = struct
: T.type_value ->
T.type_value option ->
T.type_value option ->
(constraints * T.type_name) =
(constraints * T.type_variable) =
fun fresh arg body ->
let whole_expr = Core.fresh_type_variable () in
let unification_arg = Core.fresh_type_variable () in
@ -336,27 +341,27 @@ module Wrap = struct
C_equation (P_variable whole_expr ,
P_constant (C_arrow , [P_variable unification_arg ;
P_variable unification_body]))
] @ arg' @ body' , Type_name whole_expr
] @ arg' @ body' , whole_expr
end
(* begin unionfind *)
module TV =
module TypeVariable =
struct
type t = Core.type_variable
let compare = String.compare
let to_string = (fun s -> s)
let compare a b= Var.compare a b
let to_string = (fun s -> Format.asprintf "%a" Var.pp s)
end
module UF = Union_find.Partition0.Make(TV)
module UF = Union_find.Partition0.Make(TypeVariable)
type unionfind = UF.t
(* end unionfind *)
(* representant for an equivalence class of type variables *)
module TypeVariable = String
module TypeVariableMap = Map.Make(TypeVariable)
@ -716,7 +721,7 @@ let rec compare_list f = function
compare_list f tl1 tl2)
| [] -> (function [] -> 0 | _::_ -> -1) (* This follows the behaviour of Pervasives.compare for lists of different length *)
let compare_type_variable a b =
String.compare a b
Var.compare a b
let compare_label = function
| L_int a -> (function L_int b -> Int.compare a b | L_string _ -> -1)
| L_string a -> (function L_int _ -> 1 | L_string b -> String.compare a b)
@ -724,93 +729,93 @@ let compare_simple_c_constant = function
| C_arrow -> (function
(* N/A -> 1 *)
| C_arrow -> 0
| C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_option -> (function
| C_arrow -> 1
| C_option -> 0
| C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_tuple -> (function
| C_arrow | C_option -> 1
| C_tuple -> 0
| C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_record -> (function
| C_arrow | C_option | C_tuple -> 1
| C_record -> 0
| C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_variant -> (function
| C_arrow | C_option | C_tuple | C_record -> 1
| C_variant -> 0
| C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_map -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant -> 1
| C_map -> 0
| C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_big_map -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map -> 1
| C_big_map -> 0
| C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_list -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map -> 1
| C_list -> 0
| C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_set -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list -> 1
| C_set -> 0
| C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_unit -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set -> 1
| C_unit -> 0
| C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_bool -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit -> 1
| C_bool -> 0
| C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_string -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool -> 1
| C_string -> 0
| C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_nat -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string -> 1
| C_nat -> 0
| C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_tez -> (function
| C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_mutez -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat -> 1
| C_tez -> 0
| C_mutez -> 0
| C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_timestamp -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez -> 1
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez -> 1
| C_timestamp -> 0
| C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_int -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp -> 1
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp -> 1
| C_int -> 0
| C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_address -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int -> 1
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int -> 1
| C_address -> 0
| C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_bytes -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address -> 1
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address -> 1
| C_bytes -> 0
| C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_key_hash -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes -> 1
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes -> 1
| C_key_hash -> 0
| C_key | C_signature | C_operation | C_contract -> -1)
| C_key -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash -> 1
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash -> 1
| C_key -> 0
| C_signature | C_operation | C_contract -> -1)
| C_signature -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key -> 1
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key -> 1
| C_signature -> 0
| C_operation | C_contract -> -1)
| C_operation -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature -> 1
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature -> 1
| C_operation -> 0
| C_contract -> -1)
| C_contract -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation -> 1
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation -> 1
| C_contract -> 0
(* N/A -> -1 *)
)
@ -826,7 +831,7 @@ and compare_type_value = function
| P_apply _ -> -1)
| P_variable a -> (function
| P_forall _ -> 1
| P_variable b -> String.compare a b
| P_variable b -> compare_type_variable a b
| P_constant _ -> -1
| P_apply _ -> -1)
| P_constant (a1, a2) -> (function

260
src/passes/4-typer-new/typer.ml
View File

@ -4,8 +4,6 @@ module I = Ast_simplified
module O = Ast_typed
open O.Combinators
module SMap = O.SMap
module Environment = O.Environment
module Solver = Solver
@ -13,28 +11,28 @@ module Solver = Solver
type environment = Environment.t
module Errors = struct
let unbound_type_variable (e:environment) (n:string) () =
let unbound_type_variable (e:environment) (tv:I.type_variable) () =
let title = (thunk "unbound type variable") in
let message () = "" in
let data = [
("variable" , fun () -> Format.asprintf "%s" n) ;
("variable" , fun () -> Format.asprintf "%a" Stage_common.PP.type_variable tv) ;
(* TODO: types don't have srclocs for now. *)
(* ("location" , fun () -> Format.asprintf "%a" Location.pp (n.location)) ; *)
("in" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e)
] in
error ~data title message ()
let unbound_variable (e:environment) (n:string) (loc:Location.t) () =
let unbound_variable (e:environment) (n:I.expression_variable) (loc:Location.t) () =
let title = (thunk "unbound variable") in
let message () = "" in
let data = [
("variable" , fun () -> Format.asprintf "%s" n) ;
("variable" , fun () -> Format.asprintf "%a" Stage_common.PP.name n) ;
("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
let match_empty_variant : type a . a I.matching -> Location.t -> unit -> _ =
let match_empty_variant : type a . (a,unit) I.matching -> Location.t -> unit -> _ =
fun matching loc () ->
let title = (thunk "match with no cases") in
let message () = "" in
@ -44,7 +42,7 @@ module Errors = struct
] in
error ~data title message ()
let match_missing_case : type a . a I.matching -> Location.t -> unit -> _ =
let match_missing_case : type a . (a, unit) I.matching -> Location.t -> unit -> _ =
fun matching loc () ->
let title = (thunk "missing case in match") in
let message () = "" in
@ -54,7 +52,7 @@ module Errors = struct
] in
error ~data title message ()
let match_redundant_case : type a . a I.matching -> Location.t -> unit -> _ =
let match_redundant_case : type a . (a, unit) I.matching -> Location.t -> unit -> _ =
fun matching loc () ->
let title = (thunk "missing case in match") in
let message () = "" in
@ -64,25 +62,16 @@ module Errors = struct
] in
error ~data title message ()
let unbound_constructor (e:environment) (n:string) (loc:Location.t) () =
let unbound_constructor (e:environment) (c:I.constructor) (loc:Location.t) () =
let title = (thunk "unbound constructor") in
let message () = "" in
let data = [
("constructor" , fun () -> Format.asprintf "%s" n) ;
("constructor" , fun () -> Format.asprintf "%a" Stage_common.PP.constructor c) ;
("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
let unrecognized_constant (n:string) (loc:Location.t) () =
let title = (thunk "unrecognized constant") in
let message () = "" in
let data = [
("constant" , fun () -> Format.asprintf "%s" n) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
let wrong_arity (n:string) (expected:int) (actual:int) (loc : Location.t) () =
let title () = "wrong arity" in
let message () = "" in
@ -113,11 +102,11 @@ module Errors = struct
] in
error ~data title message ()
let constant_declaration_error (name:string) (ae:I.expr) (expected: O.type_value option) () =
let constant_declaration_error (name: I.expression_variable) (ae:I.expr) (expected: O.type_value option) () =
let title = (thunk "typing constant declaration") in
let message () = "" in
let data = [
("constant" , fun () -> Format.asprintf "%s" name) ;
("constant" , fun () -> Format.asprintf "%a" Stage_common.PP.name name) ; (* Todo : remove Stage_common*)
("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
("expected" , fun () ->
match expected with
@ -127,7 +116,7 @@ module Errors = struct
] in
error ~data title message ()
let match_error : type a . ?msg:string -> expected: a I.matching -> actual: O.type_value -> Location.t -> unit -> _ =
let match_error : type a . ?msg:string -> expected: (a, unit) I.matching -> actual: O.type_value -> Location.t -> unit -> _ =
fun ?(msg = "") ~expected ~actual loc () ->
let title = (thunk "typing match") in
let message () = msg in
@ -199,15 +188,6 @@ module Errors = struct
] in
error ~data title message ()
let constant_error loc lst tv_opt =
let title () = "typing constant" in
let message () = "" in
let data = [
("location" , fun () -> Format.asprintf "%a" Location.pp loc ) ;
("argument_types" , fun () -> Format.asprintf "%a" PP_helpers.(list_sep Ast_typed.PP.type_value (const " , ")) lst) ;
("type_opt" , fun () -> Format.asprintf "%a" PP_helpers.(option Ast_typed.PP.type_value) tv_opt) ;
] in
error ~data title message
end
open Errors
@ -249,7 +229,7 @@ let rec type_declaration env state : I.declaration -> (environment * Solver.stat
ok (env', state' , Some (O.Declaration_constant ((make_n_e name ae') , (env , env'))))
)
and type_match : environment -> Solver.state -> O.type_value -> 'i I.matching -> I.expression -> Location.t -> (O.value O.matching * Solver.state) result =
and type_match : environment -> Solver.state -> O.type_value -> ('i, unit) I.matching -> I.expression -> Location.t -> ((O.value, O.type_value) O.matching * Solver.state) result =
fun e state t i ae loc -> match i with
| Match_bool {match_true ; match_false} ->
let%bind _ =
@ -263,22 +243,21 @@ and type_match : environment -> Solver.state -> O.type_value -> 'i I.matching ->
trace_strong (match_error ~expected:i ~actual:t loc)
@@ get_t_option t in
let%bind (match_none , state') = type_expression e state match_none in
let (n, b) = match_some in
let n' = n, t_opt in
let (n, b, _) = match_some in
let e' = Environment.add_ez_binder n t_opt e in
let%bind (b' , state'') = type_expression e' state' b in
ok (O.Match_option {match_none ; match_some = (n', b')} , state'')
ok (O.Match_option {match_none ; match_some = (n, b', t_opt)} , state'')
| Match_list {match_nil ; match_cons} ->
let%bind t_list =
let%bind t_elt =
trace_strong (match_error ~expected:i ~actual:t loc)
@@ get_t_list t in
let%bind (match_nil , state') = type_expression e state match_nil in
let (hd, tl, b) = match_cons in
let e' = Environment.add_ez_binder hd t_list e in
let (hd, tl, b, _) = match_cons in
let e' = Environment.add_ez_binder hd t_elt e in
let e' = Environment.add_ez_binder tl t e' in
let%bind (b' , state'') = type_expression e' state' b in
ok (O.Match_list {match_nil ; match_cons = ((hd, t_list), (tl, t)), b'} , state'')
| Match_tuple (lst, b) ->
ok (O.Match_list {match_nil ; match_cons = (hd, tl, b',t)} , state'')
| Match_tuple ((lst, b),_) ->
let%bind t_tuple =
trace_strong (match_error ~expected:i ~actual:t loc)
@@ get_t_tuple t in
@ -288,8 +267,8 @@ and type_match : environment -> Solver.state -> O.type_value -> 'i I.matching ->
let aux prev (name, tv) = Environment.add_ez_binder name tv prev in
let e' = List.fold_left aux e lst' in
let%bind (b' , state') = type_expression e' state b in
ok (O.Match_tuple (lst, b') , state')
| Match_variant lst ->
ok (O.Match_tuple ((lst, b'), t_tuple) , state')
| Match_variant (lst,_) ->
let%bind variant_opt =
let aux acc ((constructor_name , _) , _) =
let%bind (_ , variant) =
@ -318,7 +297,7 @@ and type_match : environment -> Solver.state -> O.type_value -> 'i I.matching ->
let%bind variant_cases' =
trace (match_error ~expected:i ~actual:t loc)
@@ Ast_typed.Combinators.get_t_sum variant in
let variant_cases = List.map fst @@ Map.String.to_kv_list variant_cases' in
let variant_cases = List.map fst @@ I.CMap.to_kv_list variant_cases' in
let match_cases = List.map (Function.compose fst fst) lst in
let test_case = fun c ->
Assert.assert_true (List.mem c match_cases)
@ -349,11 +328,11 @@ and type_match : environment -> Solver.state -> O.type_value -> 'i I.matching ->
*)
and evaluate_type (e:environment) (t:I.type_expression) : O.type_value result =
let return tv' = ok (make_t tv' (Some t)) in
match t with
| T_function (a, b) ->
match t.type_expression' with
| T_arrow (a, b) ->
let%bind a' = evaluate_type e a in
let%bind b' = evaluate_type e b in
return (T_function (a', b'))
return (T_arrow (a', b'))
| T_tuple lst ->
let%bind lst' = bind_list @@ List.map (evaluate_type e) lst in
return (T_tuple lst')
@ -361,26 +340,49 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_value result =
let aux k v prev =
let%bind prev' = prev in
let%bind v' = evaluate_type e v in
ok @@ SMap.add k v' prev'
ok @@ I.CMap.add k v' prev'
in
let%bind m = SMap.fold aux m (ok SMap.empty) in
let%bind m = I.CMap.fold aux m (ok I.CMap.empty) in
return (T_sum m)
| T_record m ->
let aux k v prev =
let%bind prev' = prev in
let%bind v' = evaluate_type e v in
ok @@ SMap.add k v' prev'
ok @@ I.LMap.add k v' prev'
in
let%bind m = SMap.fold aux m (ok SMap.empty) in
let%bind m = I.LMap.fold aux m (ok I.LMap.empty) in
return (T_record m)
| T_variable name ->
let%bind tv =
trace_option (unbound_type_variable e name)
@@ Environment.get_type_opt name e in
ok tv
| T_constant (cst, lst) ->
let%bind lst' = bind_list @@ List.map (evaluate_type e) lst in
return (T_constant(Type_name cst, lst'))
| T_constant cst ->
return (T_constant cst)
| T_operator opt ->
let%bind opt = match opt with
| TC_set s ->
let%bind s = evaluate_type e s in
ok @@ O.TC_set (s)
| TC_option o ->
let%bind o = evaluate_type e o in
ok @@ O.TC_option (o)
| TC_list l ->
let%bind l = evaluate_type e l in
ok @@ 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)
| 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_contract c ->
let%bind c = evaluate_type e c in
ok @@ O.TC_contract c
in
return (T_operator (opt))
and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.expression -> (O.annotated_expression * Solver.state) result = fun e state ?tv_opt ae ->
let () = ignore tv_opt in (* For compatibility with the old typer's API, this argument can be removed once the new typer is used. *)
@ -492,7 +494,7 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
| E_accessor (base , [Access_record property]) -> (
let%bind (base' , state') = type_expression e state base in
let wrapped = Wrap.access_string ~base:base'.type_annotation ~property in
return_wrapped (E_record_accessor (base' , property)) state' wrapped
return_wrapped (E_record_accessor (base' , Label property)) state' wrapped
)
| E_accessor (_base , []) | E_accessor (_base , _ :: _ :: _) -> (
failwith
@ -505,8 +507,9 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
let error =
let title () = "no such constructor" in
let content () =
Format.asprintf "%s in:\n%a\n"
c O.Environment.PP.full_environment e
Format.asprintf "%a in:\n%a\n"
Stage_common.PP.constructor c
O.Environment.PP.full_environment e
in
error title content in
trace_option error @@
@ -520,10 +523,10 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
| E_record m ->
let aux (acc, state) k expr =
let%bind (expr' , state') = type_expression e state expr in
ok (SMap.add k expr' acc , state')
ok (I.LMap.add k expr' acc , state')
in
let%bind (m' , state') = bind_fold_smap aux (ok (SMap.empty , state)) m in
let wrapped = Wrap.record (SMap.map get_type_annotation m') in
let%bind (m' , state') = I.bind_fold_lmap aux (ok (I.LMap.empty , state)) m in
let wrapped = Wrap.record (I.LMap.map get_type_annotation m') in
return_wrapped (E_record m') state' wrapped
(* Data-structure *)
@ -783,7 +786,7 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
let%bind m = get_t_record prec_tv in
let%bind tv' =
trace_option (bad_record_access property ae prec_tv ae.location) @@
Map.String.find_opt property m in
I.LMap.find_opt (Label property) m in
ok (tv' , prec_path @ [O.Access_record property])
)
in
@ -791,7 +794,7 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
let%bind (expr' , state') = type_expression e state expr in
let wrapped = Wrap.assign assign_tv expr'.type_annotation in
return_wrapped (O.E_assign (typed_name , path' , expr')) state' wrapped
| E_annotation (expr , te) ->
| E_ascription (expr , te) ->
let%bind tv = evaluate_type e te in
let%bind (expr' , state') = type_expression e state expr in
let wrapped = Wrap.annotation expr'.type_annotation tv
@ -805,12 +808,12 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
let%bind (ex' , state') = type_expression e state ex in
let%bind (m' , state'') = type_match e state' ex'.type_annotation m ae ae.location in
let tvs =
let aux (cur:O.value O.matching) =
let aux (cur:(O.value, O.type_value) O.matching) =
match cur with
| Match_bool { match_true ; match_false } -> [ match_true ; match_false ]
| Match_list { match_nil ; match_cons = ((_ , _) , match_cons) } -> [ match_nil ; match_cons ]
| Match_option { match_none ; match_some = (_ , match_some) } -> [ match_none ; match_some ]
| Match_tuple (_ , match_tuple) -> [ match_tuple ]
| Match_list { match_nil ; match_cons = (_ , _ , match_cons, _) } -> [ match_nil ; match_cons ]
| Match_option { match_none ; match_some = (_ , match_some, _) } -> [ match_none ; match_some ]
| Match_tuple ((_ , match_tuple), _) -> [ match_tuple ]
| Match_variant (lst , _) -> List.map snd lst in
List.map get_type_annotation @@ aux m' in
let%bind () = match tvs with
@ -861,7 +864,7 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
let%bind input_type' = bind_map_option (evaluate_type e) input_type in
let%bind output_type' = bind_map_option (evaluate_type e) output_type in
let fresh : O.type_value = t_variable (Type_name (Wrap.fresh_binder ())) () in
let fresh : O.type_value = t_variable (Wrap.fresh_binder ()) () in
let e' = Environment.add_ez_binder (fst binder) fresh e in
let%bind (result , state') = type_expression e' state result in
@ -884,14 +887,10 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
(* Advanced *)
and type_constant (name:string) (lst:O.type_value list) (tv_opt:O.type_value option) (loc : Location.t) : (string * O.type_value) result =
(* Constant poorman's polymorphism *)
let ct = Operators.Typer.constant_typers in
let%bind typer =
trace_option (unrecognized_constant name loc) @@
Map.String.find_opt name ct in
trace (constant_error loc lst tv_opt) @@
typer lst tv_opt
and type_constant (name:I.constant) (lst:O.type_value list) (tv_opt:O.type_value option) : (O.constant * O.type_value) result =
let%bind typer = Operators.Typer.constant_typers name in
let%bind tv = typer lst tv_opt in
ok(name, tv)
let untype_type_value (t:O.type_value) : (I.type_expression) result =
match t.simplified with
@ -933,13 +932,13 @@ let type_program_returns_state (p:I.program) : (environment * Solver.state * O.p
let () = ignore (env' , state') in
ok (env', state', declarations)
module TSMap = TMap(Solver.TypeVariable)
(* module TSMap = TMap(Solver.TypeVariable) *)
let type_program (p : I.program) : (O.program * Solver.state) result =
let%bind (env, state, program) = type_program_returns_state p in
let subst_all =
let assignments = state.structured_dbs.assignments in
let aux (v : string (* this string is a type_name or type_variable I think *)) (expr : Solver.c_constructor_simpl) (p:O.program result) =
let aux (v : I.type_variable) (expr : Solver.c_constructor_simpl) (p:O.program result) =
let%bind p = p in
Typesystem.Misc.Substitution.Pattern.program ~p ~v ~expr in
(* let p = TSMap.bind_fold_Map aux program assignments in *) (* TODO: Module magic: this does not work *)
@ -975,24 +974,49 @@ let type_program' : I.program -> O.program result = fun p ->
*)
let rec untype_type_expression (t:O.type_value) : (I.type_expression) result =
(* TODO: or should we use t.simplified if present? *)
match t.type_value' with
let%bind t = match t.type_value' with
| O.T_tuple x ->
let%bind x' = bind_map_list untype_type_expression x in
ok @@ I.T_tuple x'
| O.T_sum x ->
let%bind x' = bind_map_smap untype_type_expression x in
let%bind x' = I.bind_map_cmap untype_type_expression x in
ok @@ I.T_sum x'
| O.T_record x ->
let%bind x' = bind_map_smap untype_type_expression x in
let%bind x' = I.bind_map_lmap untype_type_expression x in
ok @@ I.T_record x'
| O.T_constant (Type_name tag, args) ->
let%bind args' = bind_map_list untype_type_expression args in
ok @@ I.T_constant (tag, args')
| O.T_variable (Type_name name) -> ok @@ I.T_variable name (* TODO: is this the right conversion? *)
| O.T_function (a , b) ->
| O.T_constant (tag) ->
ok @@ I.T_constant (tag)
| O.T_variable (name) -> ok @@ I.T_variable name (* TODO: is this the right conversion? *)
| O.T_arrow (a , b) ->
let%bind a' = untype_type_expression a in
let%bind b' = untype_type_expression b in
ok @@ I.T_function (a' , b')
ok @@ I.T_arrow (a' , b')
| O.T_operator (type_name) ->
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'
| O.TC_list t ->
let%bind t' = untype_type_expression t in
ok @@ I.TC_list t'
| O.TC_set t ->
let%bind t' = untype_type_expression t in
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)
| 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)
| O.TC_contract c->
let%bind c = untype_type_expression c in
ok @@ I.TC_contract c
in
ok @@ I.T_operator (type_name)
in
ok @@ I.make_t t
(* match t.simplified with *)
(* | Some s -> ok s *)
@ -1030,16 +1054,16 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
| E_literal l ->
let%bind l = untype_literal l in
return (e_literal l)
| E_constant (n, lst) ->
| E_constant (const, lst) ->
let%bind lst' = bind_map_list untype_expression lst in
return (e_constant n lst')
| E_variable n ->
return (e_constant const lst')
| E_variable (n) ->
return (e_variable n)
| E_application (f, arg) ->
let%bind f' = untype_expression f in
let%bind arg' = untype_expression arg in
return (e_application f' arg')
| E_lambda {binder ; body} -> (
| E_lambda {binder; body} -> (
let%bind io = get_t_function e.type_annotation in
let%bind (input_type , output_type) = bind_map_pair untype_type_value io in
let%bind result = untype_expression body in
@ -1052,14 +1076,16 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
| E_tuple_accessor (tpl, ind) ->
let%bind tpl' = untype_expression tpl in
return (e_accessor tpl' [Access_tuple ind])
| E_constructor (n, p) ->
| E_constructor (Constructor c, p) ->
let%bind p' = untype_expression p in
return (e_constructor n p')
return (e_constructor c p')
| E_record r ->
let aux ( Label k ,v) = (k, v) in
let r = Map.String.of_list @@ List.map aux (LMap.to_kv_list r) in
let%bind r' = bind_smap
@@ SMap.map untype_expression r in
@@ Map.String.map untype_expression r in
return (e_record r')
| E_record_accessor (r, s) ->
| E_record_accessor (r, Label s) ->
let%bind r' = untype_expression r in
return (e_accessor r' [Access_record s])
| E_map m ->
@ -1087,7 +1113,7 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
| E_sequence _
| E_loop _
| E_assign _ -> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e.expression
| E_let_in {binder;rhs;result} ->
| E_let_in {binder; rhs;result} ->
let%bind tv = untype_type_value rhs.type_annotation in
let%bind rhs = untype_expression rhs in
let%bind result = untype_expression result in
@ -1096,29 +1122,29 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
(*
Tranform a Ast_typed matching into an ast_simplified matching
*)
and untype_matching : type o i . (o -> i result) -> o O.matching -> (i I.matching) result = fun f m ->
and untype_matching : type o i . (o -> i result) -> (o,O.type_value) O.matching -> ((i,unit) I.matching) result = fun f m ->
let open I in
match m with
| Match_bool {match_true ; match_false} ->
let%bind match_true = f match_true in
let%bind match_false = f match_false in
ok @@ Match_bool {match_true ; match_false}
| Match_tuple (lst, b) ->
let%bind b = f b in
ok @@ Match_tuple (lst, b)
| Match_option {match_none ; match_some = (v, some)} ->
let%bind match_none = f match_none in
let%bind some = f some in
let match_some = fst v, some in
ok @@ Match_option {match_none ; match_some}
| Match_list {match_nil ; match_cons = (((hd_name , _) , (tl_name , _)), cons)} ->
let%bind match_nil = f match_nil in
let%bind cons = f cons in
let match_cons = hd_name , tl_name , cons in
ok @@ Match_list {match_nil ; match_cons}
let%bind match_true = f match_true in
let%bind match_false = f match_false in
ok @@ Match_bool {match_true ; match_false}
| Match_tuple ((lst, b),_) ->
let%bind b = f b in
ok @@ I.Match_tuple ((lst, b),[])
| Match_option {match_none ; match_some = (v, some,_)} ->
let%bind match_none = f match_none in
let%bind some = f some in
let match_some = v, some, () in
ok @@ Match_option {match_none ; match_some}
| Match_list {match_nil ; match_cons = (hd_name, tl_name, cons,_)} ->
let%bind match_nil = f match_nil in
let%bind cons = f cons in
let match_cons = hd_name , tl_name , cons, () in
ok @@ Match_list {match_nil ; match_cons}
| Match_variant (lst , _) ->
let aux ((a,b),c) =
let%bind c' = f c in
ok ((a,b),c') in
let%bind lst' = bind_map_list aux lst in
ok @@ Match_variant lst'
let aux ((a,b),c) =
let%bind c' = f c in
ok ((a,b),c') in
let%bind lst' = bind_map_list aux lst in
ok @@ Match_variant (lst',())

2
src/passes/4-typer-new/typer.ml.old
View File

@ -737,7 +737,7 @@ and type_expression : environment -> ?tv_opt:O.type_expression -> I.expression -
let e' = Environment.add_ez_declaration (fst binder) rhs e in
let%bind result = type_expression e' result in
return (E_let_in {binder = fst binder; rhs; result}) result.type_annotation
| E_annotation (expr , te) ->
| E_ascription (expr , te) ->
let%bind tv = evaluate_type e te in
let%bind expr' = type_expression ~tv_opt:tv e expr in
let%bind type_annotation =

3
src/passes/4-typer-new/typer.mli
View File

@ -3,7 +3,6 @@ open Trace
module I = Ast_simplified
module O = Ast_typed
module SMap = O.SMap
module Environment = O.Environment
module Solver = Solver
@ -45,7 +44,7 @@ val type_declaration : environment -> Solver.state -> I.declaration -> (environm
(* val type_match : (environment -> 'i -> 'o result) -> environment -> O.type_value -> 'i I.matching -> I.expression -> Location.t -> 'o O.matching result *)
val evaluate_type : environment -> I.type_expression -> O.type_value result
val type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.expression -> (O.annotated_expression * Solver.state) result
val type_constant : string -> O.type_value list -> O.type_value option -> Location.t -> (string * O.type_value) result
val type_constant : I.constant -> O.type_value list -> O.type_value option -> (O.constant * O.type_value) result
(*
val untype_type_value : O.type_value -> (I.type_expression) result
val untype_literal : O.literal -> I.literal result

198
src/passes/4-typer-old/typer.ml
View File

@ -4,8 +4,6 @@ module I = Ast_simplified
module O = Ast_typed
open O.Combinators
module SMap = O.SMap
module Environment = O.Environment
module Solver = Typer_new.Solver
@ -13,28 +11,28 @@ module Solver = Typer_new.Solver
type environment = Environment.t
module Errors = struct
let unbound_type_variable (e:environment) (n:string) () =
let unbound_type_variable (e:environment) (tv:I.type_variable) () =
let title = (thunk "unbound type variable") in
let message () = "" in
let data = [
("variable" , fun () -> Format.asprintf "%s" n) ;
("variable" , fun () -> Format.asprintf "%a" Stage_common.PP.type_variable tv) ;
(* TODO: types don't have srclocs for now. *)
(* ("location" , fun () -> Format.asprintf "%a" Location.pp (n.location)) ; *)
("in" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e)
] in
error ~data title message ()
let unbound_variable (e:environment) (n:string) (loc:Location.t) () =
let unbound_variable (e:environment) (n:I.expression_variable) (loc:Location.t) () =
let title = (thunk "unbound variable") in
let message () = "" in
let data = [
("variable" , fun () -> Format.asprintf "%s" n) ;
("variable" , fun () -> Format.asprintf "%a" Stage_common.PP.name n) ;
("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
let match_empty_variant : type a . a I.matching -> Location.t -> unit -> _ =
let match_empty_variant : type a . (a, unit) I.matching -> Location.t -> unit -> _ =
fun matching loc () ->
let title = (thunk "match with no cases") in
let message () = "" in
@ -44,7 +42,7 @@ module Errors = struct
] in
error ~data title message ()
let match_missing_case : type a . a I.matching -> Location.t -> unit -> _ =
let match_missing_case : type a . (a, unit) I.matching -> Location.t -> unit -> _ =
fun matching loc () ->
let title = (thunk "missing case in match") in
let message () = "" in
@ -54,7 +52,7 @@ module Errors = struct
] in
error ~data title message ()
let match_redundant_case : type a . a I.matching -> Location.t -> unit -> _ =
let match_redundant_case : type a . (a, unit) I.matching -> Location.t -> unit -> _ =
fun matching loc () ->
let title = (thunk "missing case in match") in
let message () = "" in
@ -64,25 +62,16 @@ module Errors = struct
] in
error ~data title message ()
let unbound_constructor (e:environment) (n:string) (loc:Location.t) () =
let unbound_constructor (e:environment) (c:I.constructor) (loc:Location.t) () =
let title = (thunk "unbound constructor") in
let message () = "" in
let data = [
("constructor" , fun () -> Format.asprintf "%s" n) ;
("constructor" , fun () -> Format.asprintf "%a" Stage_common.PP.constructor c);
("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
let unrecognized_constant (n:string) (loc:Location.t) () =
let title = (thunk "unrecognized constant") in
let message () = "" in
let data = [
("constant" , fun () -> Format.asprintf "%s" n) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
let wrong_arity (n:string) (expected:int) (actual:int) (loc : Location.t) () =
let title () = "wrong arity" in
let message () = "" in
@ -113,11 +102,11 @@ module Errors = struct
] in
error ~data title message ()
let constant_declaration_error (name:string) (ae:I.expr) (expected: O.type_value option) () =
let constant_declaration_error (name:I.expression_variable) (ae:I.expr) (expected: O.type_value option) () =
let title = (thunk "typing constant declaration") in
let message () = "" in
let data = [
("constant" , fun () -> Format.asprintf "%s" name) ;
("constant" , fun () -> Format.asprintf "%a" Stage_common.PP.name name) ;
("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
("expected" , fun () ->
match expected with
@ -127,7 +116,7 @@ module Errors = struct
] in
error ~data title message ()
let match_error : type a . ?msg:string -> expected: a I.matching -> actual: O.type_value -> Location.t -> unit -> _ =
let match_error : type a . ?msg:string -> expected: (a, unit) I.matching -> actual: O.type_value -> Location.t -> unit -> _ =
fun ?(msg = "") ~expected ~actual loc () ->
let title = (thunk "typing match") in
let message () = msg in
@ -180,11 +169,11 @@ module Errors = struct
] in
error ~data title message ()
let bad_record_access (field : string) (ae : I.expression) (t : O.type_value) (loc:Location.t) () =
let bad_record_access (field : I.label) (ae : I.expression) (t : O.type_value) (loc:Location.t) () =
let title = (thunk "invalid record field") in
let message () = "" in
let data = [
("field" , fun () -> Format.asprintf "%s" field) ;
("field" , fun () -> Format.asprintf "%a" Stage_common.PP.label field) ;
("record_value" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_value t) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
@ -199,15 +188,6 @@ module Errors = struct
] in
error ~data title message ()
let constant_error loc lst tv_opt =
let title () = "typing constant" in
let message () = "" in
let data = [
("location" , fun () -> Format.asprintf "%a" Location.pp loc ) ;
("argument_types" , fun () -> Format.asprintf "%a" PP_helpers.(list_sep Ast_typed.PP.type_value (const " , ")) lst) ;
("type_opt" , fun () -> Format.asprintf "%a" PP_helpers.(option Ast_typed.PP.type_value) tv_opt) ;
] in
error ~data title message
end
open Errors
@ -239,7 +219,7 @@ and type_declaration env (_placeholder_for_state_of_new_typer : Solver.state) :
ok (env', (Solver.placeholder_for_state_of_new_typer ()) , Some (O.Declaration_constant ((make_n_e name ae') , (env , env'))))
)
and type_match : type i o . (environment -> i -> o result) -> environment -> O.type_value -> i I.matching -> I.expression -> Location.t -> o O.matching result =
and type_match : type i o . (environment -> i -> o result) -> environment -> O.type_value -> (i, unit) I.matching -> I.expression -> Location.t -> (o, O.type_value) O.matching result =
fun f e t i ae loc -> match i with
| Match_bool {match_true ; match_false} ->
let%bind _ =
@ -253,22 +233,21 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
trace_strong (match_error ~expected:i ~actual:t loc)
@@ get_t_option t in
let%bind match_none = f e match_none in
let (n, b) = match_some in
let n' = n, t_opt in
let (n, b,_) = match_some in
let e' = Environment.add_ez_binder n t_opt e in
let%bind b' = f e' b in
ok (O.Match_option {match_none ; match_some = (n', b')})
ok (O.Match_option {match_none ; match_some = (n, b', t_opt)})
| Match_list {match_nil ; match_cons} ->
let%bind t_list =
let%bind t_elt =
trace_strong (match_error ~expected:i ~actual:t loc)
@@ get_t_list t in
let%bind match_nil = f e match_nil in
let (hd, tl, b) = match_cons in
let e' = Environment.add_ez_binder hd t_list e in
let (hd, tl, b,_) = match_cons in
let e' = Environment.add_ez_binder hd t_elt e in
let e' = Environment.add_ez_binder tl t e' in
let%bind b' = f e' b in
ok (O.Match_list {match_nil ; match_cons = (((hd , t_list), (tl , t)), b')})
| Match_tuple (lst, b) ->
ok (O.Match_list {match_nil ; match_cons = (hd, tl, b', t_elt)})
| Match_tuple ((lst, b),_) ->
let%bind t_tuple =
trace_strong (match_error ~expected:i ~actual:t loc)
@@ get_t_tuple t in
@ -278,8 +257,8 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
let aux prev (name, tv) = Environment.add_ez_binder name tv prev in
let e' = List.fold_left aux e lst' in
let%bind b' = f e' b in
ok (O.Match_tuple (lst, b'))
| Match_variant lst ->
ok (O.Match_tuple ((lst, b'),t_tuple))
| Match_variant (lst,_) ->
let%bind variant_opt =
let aux acc ((constructor_name , _) , _) =
let%bind (_ , variant) =
@ -308,7 +287,7 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
let%bind variant_cases' =
trace (match_error ~expected:i ~actual:t loc)
@@ Ast_typed.Combinators.get_t_sum variant in
let variant_cases = List.map fst @@ Map.String.to_kv_list variant_cases' in
let variant_cases = List.map fst @@ I.CMap.to_kv_list variant_cases' in
let match_cases = List.map (Function.compose fst fst) lst in
let test_case = fun c ->
Assert.assert_true (List.mem c match_cases)
@ -335,11 +314,11 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
and evaluate_type (e:environment) (t:I.type_expression) : O.type_value result =
let return tv' = ok (make_t tv' (Some t)) in
match t with
| T_function (a, b) ->
match t.type_expression' with
| T_arrow (a, b) ->
let%bind a' = evaluate_type e a in
let%bind b' = evaluate_type e b in
return (T_function (a', b'))
return (T_arrow (a', b'))
| T_tuple lst ->
let%bind lst' = bind_list @@ List.map (evaluate_type e) lst in
return (T_tuple lst')
@ -347,26 +326,49 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_value result =
let aux k v prev =
let%bind prev' = prev in
let%bind v' = evaluate_type e v in
ok @@ SMap.add k v' prev'
ok @@ I.CMap.add k v' prev'
in
let%bind m = SMap.fold aux m (ok SMap.empty) in
let%bind m = I.CMap.fold aux m (ok I.CMap.empty) in
return (T_sum m)
| T_record m ->
let aux k v prev =
let%bind prev' = prev in
let%bind v' = evaluate_type e v in
ok @@ SMap.add k v' prev'
ok @@ I.LMap.add k v' prev'
in
let%bind m = SMap.fold aux m (ok SMap.empty) in
let%bind m = I.LMap.fold aux m (ok I.LMap.empty) in
return (T_record m)
| T_variable name ->
let%bind tv =
trace_option (unbound_type_variable e name)
@@ Environment.get_type_opt name e in
ok tv
| T_constant (cst, lst) ->
let%bind lst' = bind_list @@ List.map (evaluate_type e) lst in
return (T_constant(Type_name cst, lst'))
| T_constant cst ->
return (T_constant cst)
| T_operator opt ->
let%bind opt = match opt with
| TC_set s ->
let%bind s = evaluate_type e s in
ok @@ O.TC_set (s)
| TC_option o ->
let%bind o = evaluate_type e o in
ok @@ O.TC_option (o)
| TC_list l ->
let%bind l = evaluate_type e l in
ok @@ 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)
| 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_contract c ->
let%bind c = evaluate_type e c in
ok @@ I.TC_contract c
in
return (T_operator (opt))
and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.expression -> (O.annotated_expression * Solver.state) result
= fun e _placeholder_for_state_of_new_typer ?tv_opt ae ->
@ -444,10 +446,11 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
ok @@ make_a_e ~location (E_tuple_accessor(prev , index)) tv e
)
| Access_record property -> (
let property = I.Label property in
let%bind r_tv = get_t_record prev.type_annotation in
let%bind tv =
generic_try (bad_record_access property ae' prev.type_annotation ae.location)
@@ (fun () -> SMap.find property r_tv) in
@@ (fun () -> I.LMap.find property r_tv) in
let location = ae.location in
ok @@ make_a_e ~location (E_record_accessor (prev , property)) tv e
)
@ -469,8 +472,9 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
let error =
let title () = "no such constructor" in
let content () =
Format.asprintf "%s in:\n%a\n"
c O.Environment.PP.full_environment e
Format.asprintf "%a in:\n%a\n"
Stage_common.PP.constructor c
O.Environment.PP.full_environment e
in
error title content in
trace_option error @@
@ -482,10 +486,10 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
| E_record m ->
let aux prev k expr =
let%bind expr' = type_expression' e expr in
ok (SMap.add k expr' prev)
ok (I.LMap.add k expr' prev)
in
let%bind m' = bind_fold_smap aux (ok SMap.empty) m in
return (E_record m') (t_record (SMap.map get_type_annotation m') ())
let%bind m' = I.bind_fold_lmap aux (ok I.LMap.empty) m in
return (E_record m') (t_record (I.LMap.map get_type_annotation m') ())
(* Data-structure *)
| E_list lst ->
let%bind lst' = bind_map_list (type_expression' e) lst in
@ -624,7 +628,7 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
let output_type = body.type_annotation in
return (E_lambda {binder = fst binder ; body}) (t_function input_type output_type ())
)
| E_constant ( ("LIST_FOLD"|"MAP_FOLD"|"SET_FOLD") as opname ,
| E_constant ( ( C_LIST_FOLD | C_MAP_FOLD | C_SET_FOLD) as opname ,
[
( { expression = (I.E_lambda { binder = (lname, None) ;
input_type = None ;
@ -640,8 +644,8 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
let tv_col = get_type_annotation v_col in (* this is the type of the collection *)
let tv_out = get_type_annotation v_initr in (* this is the output type of the lambda*)
let%bind input_type = match tv_col.type_value' with
| O.T_constant ( (Type_name "list"|Type_name "set") , t) -> ok @@ t_tuple (tv_out::t) ()
| O.T_constant ( Type_name "map" , t) -> ok @@ t_tuple (tv_out::[(t_tuple t ())]) ()
| O.T_operator ( TC_list t | TC_set t) -> ok @@ t_tuple (tv_out::[t]) ()
| O.T_operator ( TC_map (k,v)| TC_big_map (k,v)) -> ok @@ t_tuple (tv_out::[(t_tuple [k;v] ())]) ()
| _ ->
let wtype = Format.asprintf
"Loops over collections expect lists, sets or maps, got type %a" O.PP.type_value tv_col in
@ -653,19 +657,19 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
let lst' = [lambda'; v_col; v_initr] in
let tv_lst = List.map get_type_annotation lst' in
let%bind (opname', tv) =
type_constant opname tv_lst tv_opt ae.location in
type_constant opname tv_lst tv_opt in
return (E_constant (opname' , lst')) tv
| E_constant (name, lst) ->
let%bind lst' = bind_list @@ List.map (type_expression' e) lst in
let tv_lst = List.map get_type_annotation lst' in
let%bind (name', tv) =
type_constant name tv_lst tv_opt ae.location in
type_constant name tv_lst tv_opt in
return (E_constant (name' , lst')) tv
| E_application (f, arg) ->
let%bind f' = type_expression' e f in
let%bind arg = type_expression' e arg in
let%bind tv = match f'.type_annotation.type_value' with
| T_function (param, result) ->
| T_arrow (param, result) ->
let%bind _ = O.assert_type_value_eq (param, arg.type_annotation) in
ok result
| _ ->
@ -686,12 +690,12 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
let%bind ex' = type_expression' e ex in
let%bind m' = type_match (type_expression' ?tv_opt:None) e ex'.type_annotation m ae ae.location in
let tvs =
let aux (cur:O.value O.matching) =
let aux (cur:(O.value, O.type_value) O.matching) =
match cur with
| Match_bool { match_true ; match_false } -> [ match_true ; match_false ]
| Match_list { match_nil ; match_cons = ((_ , _) , match_cons) } -> [ match_nil ; match_cons ]
| Match_option { match_none ; match_some = (_ , match_some) } -> [ match_none ; match_some ]
| Match_tuple (_ , match_tuple) -> [ match_tuple ]
| Match_list { match_nil ; match_cons = (_ , _ , match_cons, _) } -> [ match_nil ; match_cons ]
| Match_option { match_none ; match_some = (_ , match_some, _) } -> [ match_none ; match_some ]
| Match_tuple ((_ , match_tuple), _) -> [ match_tuple ]
| Match_variant (lst , _) -> List.map snd lst in
List.map get_type_annotation @@ aux m' in
let aux prec cur =
@ -758,8 +762,8 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
| Access_record property -> (
let%bind m = get_t_record prec_tv in
let%bind tv' =
trace_option (bad_record_access property ae prec_tv ae.location) @@
Map.String.find_opt property m in
trace_option (bad_record_access (Label property) ae prec_tv ae.location) @@
I.LMap.find_opt (Label property) m in
ok (tv' , prec_path @ [O.Access_record property])
)
in
@ -781,7 +785,7 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
let e' = Environment.add_ez_declaration (fst binder) rhs e in
let%bind result = type_expression' e' result in
return (E_let_in {binder = fst binder; rhs; result}) result.type_annotation
| E_annotation (expr , te) ->
| E_ascription (expr , te) ->
let%bind tv = evaluate_type e te in
let%bind expr' = type_expression' ~tv_opt:tv e expr in
let%bind type_annotation =
@ -792,14 +796,10 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
ok {expr' with type_annotation}
and type_constant (name:string) (lst:O.type_value list) (tv_opt:O.type_value option) (loc : Location.t) : (string * O.type_value) result =
(* Constant poorman's polymorphism *)
let ct = Operators.Typer.constant_typers in
let%bind typer =
trace_option (unrecognized_constant name loc) @@
Map.String.find_opt name ct in
trace (constant_error loc lst tv_opt) @@
typer lst tv_opt
and type_constant (name:I.constant) (lst:O.type_value list) (tv_opt:O.type_value option) : (O.constant * O.type_value) result =
let%bind typer = Operators.Typer.constant_typers name in
let%bind tv = typer lst tv_opt in
ok(name, tv)
let untype_type_value (t:O.type_value) : (I.type_expression) result =
match t.simplified with
@ -831,9 +831,9 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
| E_literal l ->
let%bind l = untype_literal l in
return (e_literal l)
| E_constant (n, lst) ->
| E_constant (const, lst) ->
let%bind lst' = bind_map_list untype_expression lst in
return (e_constant n lst')
return (e_constant const lst')
| E_variable n ->
return (e_variable n)
| E_application (f, arg) ->
@ -853,14 +853,16 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
| E_tuple_accessor (tpl, ind) ->
let%bind tpl' = untype_expression tpl in
return (e_accessor tpl' [Access_tuple ind])
| E_constructor (n, p) ->
| E_constructor ( Constructor n, p) ->
let%bind p' = untype_expression p in
return (e_constructor n p')
| E_record r ->
let%bind r' = bind_smap
@@ SMap.map untype_expression r in
return (e_record r')
| E_record_accessor (r, s) ->
let aux ( Label k ,v) = (k, v) in
let r = Map.String.of_list @@ List.map aux (LMap.to_kv_list r) in
let%bind r' = bind_smap
@@ Map.String.map untype_expression r in
return (e_record r')
| E_record_accessor (r, Label s) ->
let%bind r' = untype_expression r in
return (e_accessor r' [Access_record s])
| E_map m ->
@ -891,29 +893,29 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
let%bind result = untype_expression result in
return (e_let_in (binder , (Some tv)) rhs result)
and untype_matching : type o i . (o -> i result) -> o O.matching -> (i I.matching) result = fun f m ->
and untype_matching : type o i . (o -> i result) -> (o,O.type_value) O.matching -> ((i,unit) I.matching) result = fun f m ->
let open I in
match m with
| Match_bool {match_true ; match_false} ->
let%bind match_true = f match_true in
let%bind match_false = f match_false in
ok @@ Match_bool {match_true ; match_false}
| Match_tuple (lst, b) ->
| Match_tuple ((lst, b),_) ->
let%bind b = f b in
ok @@ Match_tuple (lst, b)
| Match_option {match_none ; match_some = (v, some)} ->
ok @@ I.Match_tuple ((lst, b),[])
| Match_option {match_none ; match_some = (v, some,_)} ->
let%bind match_none = f match_none in
let%bind some = f some in
let match_some = fst v, some in
let match_some = v, some, () in
ok @@ Match_option {match_none ; match_some}
| Match_list {match_nil ; match_cons = (((hd_name , _) , (tl_name , _)), cons)} ->
| Match_list {match_nil ; match_cons = (hd_name, tl_name, cons,_)} ->
let%bind match_nil = f match_nil in
let%bind cons = f cons in
let match_cons = hd_name , tl_name , cons in
let match_cons = hd_name , tl_name , cons, () in
ok @@ Match_list {match_nil ; match_cons}
| Match_variant (lst , _) ->
let aux ((a,b),c) =
let%bind c' = f c in
ok ((a,b),c') in
let%bind lst' = bind_map_list aux lst in
ok @@ Match_variant lst'
ok @@ Match_variant (lst',())

3
src/passes/4-typer-old/typer.mli
View File

@ -3,7 +3,6 @@ open Trace
module I = Ast_simplified
module O = Ast_typed
module SMap = O.SMap
module Environment = O.Environment
module Solver : module type of Typer_new.Solver
@ -44,7 +43,7 @@ val type_declaration : environment -> Solver.state -> I.declaration -> (environm
(* val type_match : (environment -> 'i -> 'o result) -> environment -> O.type_value -> 'i I.matching -> I.expression -> Location.t -> 'o O.matching result *)
val evaluate_type : environment -> I.type_expression -> O.type_value result
val type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.expression -> (O.annotated_expression * Solver.state) result
val type_constant : string -> O.type_value list -> O.type_value option -> Location.t -> (string * O.type_value) result
val type_constant : I.constant -> O.type_value list -> O.type_value option -> (O.constant * O.type_value) result
(*
val untype_type_value : O.type_value -> (I.type_expression) result
val untype_literal : O.literal -> I.literal result

1
src/passes/4-typer/typer.ml
View File

@ -3,7 +3,6 @@ let use_new_typer = false
module I = Ast_simplified
module O = Ast_typed
module SMap = O.SMap
module Environment = O.Environment
module Solver = Typer_new.Solver (* Both the old typer and the new typer use the same solver state. *)

2
src/passes/4-typer/typer.mli
View File

@ -5,7 +5,6 @@ open Trace
module I = Ast_simplified
module O = Ast_typed
module SMap = O.SMap
module Environment = O.Environment
module Solver = Typer_new.Solver
@ -15,4 +14,3 @@ type environment = Environment.t
val type_program : I.program -> (O.program * Solver.state) result
val type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.expression -> (O.annotated_expression * Solver.state) result
val untype_expression : O.annotated_expression -> I.expression result

17
src/passes/6-transpiler/helpers.ml
View File

@ -3,18 +3,29 @@ module Append_tree = Tree.Append
open Trace
open Mini_c
open Stage_common.Types (*Todo : to remove *)
let list_of_lmap m = List.rev @@ LMap.fold (fun _ v prev -> v :: prev) m []
let kv_list_of_lmap m = List.rev @@ LMap.fold (fun k v prev -> (k, v) :: prev) m []
let list_of_cmap m = List.rev @@ CMap.fold (fun _ v prev -> v :: prev) m []
let kv_list_of_cmap m = List.rev @@ CMap.fold (fun k v prev -> (k, v) :: prev) m []
let list_of_map m = List.rev @@ Map.String.fold (fun _ v prev -> v :: prev) m []
let kv_list_of_map m = List.rev @@ Map.String.fold (fun k v prev -> (k, v) :: prev) m []
let cmap_of_kv_list lst =
let open CMap in
List.fold_left (fun prev (k, v) -> add k v prev) empty lst
let lmap_of_kv_list lst =
let open LMap in
List.fold_left (fun prev (k, v) -> add k v prev) empty lst
let map_of_kv_list lst =
let open AST.SMap in
let open Map.String in
List.fold_left (fun prev (k, v) -> add k v prev) empty lst
let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value * AST.type_value) result =
let open Append_tree in
let rec aux tv : (string * value * AST.type_value) result=
match tv with
| Leaf (k, t), v -> ok (k, v, t)
| Leaf (Constructor k, t), v -> ok (k, v, t)
| Node {a}, D_left v -> aux (a, v)
| Node {b}, D_right v -> aux (b, v)
| _ -> fail @@ internal_assertion_failure "bad constructor path"
@ -37,7 +48,7 @@ let extract_tuple (v : value) (tree : AST.type_value Append_tree.t') : ((value *
let extract_record (v : value) (tree : _ Append_tree.t') : (_ list) result =
let open Append_tree in
let rec aux tv : ((string * (value * AST.type_value)) list) result =
let rec aux tv : ((AST.label * (value * AST.type_value)) list) result =
match tv with
| Leaf (s, t), v -> ok @@ [s, (v, t)]
| Node {a;b}, D_pair (va, vb) ->

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

@ -2,8 +2,6 @@
For more info, see back-end.md: https://gitlab.com/ligolang/ligo/blob/dev/gitlab-pages/docs/contributors/big-picture/back-end.md *)
(* TODO(tomjack) all Var.of_name are suspicious, continue war against string? *)
open! Trace
open Helpers
@ -29,14 +27,9 @@ them. please report this to the developers." in
] in
error ~data title content
let unrecognized_type_constant name =
let title () = "unrecognized type constant" in
let content () = name in
error title content
let no_type_variable name =
let title () = "type variables can't be transpiled" in
let content () = name in
let content () = Format.asprintf "%a" Var.pp name in
error title content
let row_loc l = ("location" , fun () -> Format.asprintf "%a" Location.pp l)
@ -120,63 +113,62 @@ open Errors
let rec transpile_type (t:AST.type_value) : type_value result =
match t.type_value' with
| T_variable (Type_name name) -> fail @@ no_type_variable name
| T_constant (Type_name "bool", []) -> ok (T_base Base_bool)
| T_constant (Type_name "int", []) -> ok (T_base Base_int)
| T_constant (Type_name "nat", []) -> ok (T_base Base_nat)
| T_constant (Type_name "tez", []) -> ok (T_base Base_tez)
| T_constant (Type_name "string", []) -> ok (T_base Base_string)
| T_constant (Type_name "bytes", []) -> ok (T_base Base_bytes)
| T_constant (Type_name "address", []) -> ok (T_base Base_address)
| T_constant (Type_name "timestamp", []) -> ok (T_base Base_timestamp)
| T_constant (Type_name "unit", []) -> ok (T_base Base_unit)
| T_constant (Type_name "operation", []) -> ok (T_base Base_operation)
| T_constant (Type_name "signature", []) -> ok (T_base Base_signature)
| T_constant (Type_name "key_hash", []) -> ok (T_base Base_key_hash)
| T_constant (Type_name "key", []) -> ok (T_base Base_key)
| T_constant (Type_name "chain_id", []) -> ok (T_base Base_chain_id)
| T_constant (Type_name "contract", [x]) ->
| T_variable (name) -> fail @@ no_type_variable @@ name
| T_constant (TC_bool) -> ok (T_base Base_bool)
| T_constant (TC_int) -> ok (T_base Base_int)
| T_constant (TC_nat) -> ok (T_base Base_nat)
| T_constant (TC_mutez) -> ok (T_base Base_mutez)
| T_constant (TC_string) -> ok (T_base Base_string)
| T_constant (TC_bytes) -> ok (T_base Base_bytes)
| T_constant (TC_address) -> ok (T_base Base_address)
| T_constant (TC_timestamp) -> ok (T_base Base_timestamp)
| T_constant (TC_unit) -> ok (T_base Base_unit)
| T_constant (TC_operation) -> ok (T_base Base_operation)
| T_constant (TC_signature) -> ok (T_base Base_signature)
| T_constant (TC_key) -> ok (T_base Base_key)
| T_constant (TC_key_hash) -> ok (T_base Base_key_hash)
| T_constant (TC_chain_id) -> ok (T_base Base_chain_id)
| T_operator (TC_contract x) ->
let%bind x' = transpile_type x in
ok (T_contract x')
| T_constant (Type_name "map", [key;value]) ->
| T_operator (TC_map (key,value)) ->
let%bind kv' = bind_map_pair transpile_type (key, value) in
ok (T_map kv')
| T_constant (Type_name "big_map", [key;value] ) ->
| T_operator (TC_big_map (key,value)) ->
let%bind kv' = bind_map_pair transpile_type (key, value) in
ok (T_big_map kv')
| T_constant (Type_name "list", [t]) ->
| T_operator (TC_list t) ->
let%bind t' = transpile_type t in
ok (T_list t')
| T_constant (Type_name "set", [t]) ->
| T_operator (TC_set t) ->
let%bind t' = transpile_type t in
ok (T_set t')
| T_constant (Type_name "option", [o]) ->
| T_operator (TC_option o) ->
let%bind o' = transpile_type o in
ok (T_option o')
| T_constant (Type_name name , _lst) -> fail @@ unrecognized_type_constant name
(* TODO hmm *)
| T_sum m ->
let node = Append_tree.of_list @@ kv_list_of_map m in
let node = Append_tree.of_list @@ kv_list_of_cmap m in
let aux a b : type_value annotated result =
let%bind a = a in
let%bind b = b in
ok (None, T_or (a, b))
in
let%bind m' = Append_tree.fold_ne
(fun (ann, a) ->
(fun (Constructor ann, a) ->
let%bind a = transpile_type a in
ok (Some (String.uncapitalize_ascii ann), a))
aux node in
ok @@ snd m'
| T_record m ->
let node = Append_tree.of_list @@ kv_list_of_map m in
let node = Append_tree.of_list @@ kv_list_of_lmap m in
let aux a b : type_value annotated result =
let%bind a = a in
let%bind b = b in
ok (None, T_pair (a, b))
in
let%bind m' = Append_tree.fold_ne
(fun (ann, a) ->
(fun (Label ann, a) ->
let%bind a = transpile_type a in
ok (Some ann, a))
aux node in
@ -189,7 +181,7 @@ let rec transpile_type (t:AST.type_value) : type_value result =
ok (T_pair ((None, a), (None, b)))
in
Append_tree.fold_ne transpile_type aux node
| T_function (param, result) -> (
| T_arrow (param, result) -> (
let%bind param' = transpile_type param in
let%bind result' = transpile_type result in
ok (T_function (param', result'))
@ -214,11 +206,11 @@ let tuple_access_to_lr : type_value -> type_value list -> int -> (type_value * [
bind_fold_list aux (ty , []) lr_path in
ok lst
let record_access_to_lr : type_value -> type_value AST.type_name_map -> string -> (type_value * [`Left | `Right]) list result = fun ty tym ind ->
let tys = kv_list_of_map tym in
let record_access_to_lr : type_value -> type_value AST.label_map -> string -> (type_value * [`Left | `Right]) list result = fun ty tym ind ->
let tys = kv_list_of_lmap tym in
let node_tv = Append_tree.of_list tys in
let%bind path =
let aux (i , _) = i = ind in
let aux (Label i , _) = i = ind in
trace_option (corner_case ~loc:__LOC__ "record access leaf") @@
Append_tree.exists_path aux node_tv in
let lr_path = List.map (fun b -> if b then `Right else `Left) path in
@ -252,9 +244,9 @@ let rec transpile_literal : AST.literal -> value = fun l -> match l with
and transpile_environment_element_type : AST.environment_element -> type_value result = fun ele ->
transpile_type ele.type_value
and tree_of_sum : AST.type_value -> (type_name * AST.type_value) Append_tree.t result = fun t ->
and tree_of_sum : AST.type_value -> (constructor * AST.type_value) Append_tree.t result = fun t ->
let%bind map_tv = get_t_sum t in
ok @@ Append_tree.of_list @@ kv_list_of_map map_tv
ok @@ Append_tree.of_list @@ kv_list_of_cmap map_tv
and transpile_annotated_expression (ae:AST.annotated_expression) : expression result =
let%bind tv = transpile_type ae.type_annotation in
@ -269,14 +261,14 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
| E_let_in {binder; rhs; result} ->
let%bind rhs' = transpile_annotated_expression rhs in
let%bind result' = transpile_annotated_expression result in
return (E_let_in ((Var.of_name binder, rhs'.type_value), rhs', result'))
return (E_let_in ((binder, rhs'.type_value), rhs', result'))
| E_literal l -> return @@ E_literal (transpile_literal l)
| E_variable name -> (
let%bind ele =
trace_option (corner_case ~loc:__LOC__ "name not in environment") @@
AST.Environment.get_opt name ae.environment in
let%bind tv = transpile_environment_element_type ele in
return ~tv @@ E_variable (Var.of_name name)
return ~tv @@ E_variable (name)
)
| E_application (a, b) ->
let%bind a = transpile_annotated_expression a in
@ -304,8 +296,8 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
match (a, b) with
| (None, a), (None, b) -> ok (None, T_or ((None, a), (None, b)))
| (Some _, _), (Some _, _) -> fail @@ corner_case ~loc:__LOC__ "multiple identical constructors in the same variant"
| (Some v, a), (None, b) -> ok (Some (E_constant ("LEFT", [Combinators.Expression.make_tpl (v, a)])), T_or ((None, a), (None, b)))
| (None, a), (Some v, b) -> ok (Some (E_constant ("RIGHT", [Combinators.Expression.make_tpl (v, b)])), T_or ((None, a), (None, b)))
| (Some v, a), (None, b) -> ok (Some (E_constant (C_LEFT, [Combinators.Expression.make_tpl (v, a)])), T_or ((None, a), (None, b)))
| (None, a), (Some v, b) -> ok (Some (E_constant (C_RIGHT, [Combinators.Expression.make_tpl (v, b)])), T_or ((None, a), (None, b)))
in
let%bind (ae_opt, tv) = Append_tree.fold_ne leaf node node_tv in
let%bind ae =
@ -321,7 +313,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
let a_ty = Combinators.Expression.get_type a in
let b_ty = Combinators.Expression.get_type b in
let tv = T_pair ((None, a_ty) , (None, b_ty)) in
return ~tv @@ E_constant ("PAIR", [a; b])
return ~tv @@ E_constant (C_PAIR, [a; b])
in
Append_tree.fold_ne (transpile_annotated_expression) aux node
)
@ -336,39 +328,39 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
tuple_access_to_lr ty' ty'_lst ind in
let aux = fun pred (ty, lr) ->
let c = match lr with
| `Left -> "CAR"
| `Right -> "CDR" in
| `Left -> C_CAR
| `Right -> C_CDR in
Combinators.Expression.make_tpl (E_constant (c, [pred]) , ty) in
let%bind tpl' = transpile_annotated_expression tpl in
let expr = List.fold_left aux tpl' path in
ok expr
)
| E_record m -> (
let node = Append_tree.of_list @@ list_of_map m in
let node = Append_tree.of_list @@ list_of_lmap m in
let aux a b : expression result =
let%bind a = a in
let%bind b = b in
let a_ty = Combinators.Expression.get_type a in
let b_ty = Combinators.Expression.get_type b in
let tv = T_pair ((None, a_ty) , (None, b_ty)) in
return ~tv @@ E_constant ("PAIR", [a; b])
return ~tv @@ E_constant (C_PAIR, [a; b])
in
trace_strong (corner_case ~loc:__LOC__ "record build") @@
Append_tree.fold_ne (transpile_annotated_expression) aux node
)
| E_record_accessor (record, property) ->
| E_record_accessor (record, Label property) ->
let%bind ty' = transpile_type (get_type_annotation record) in
let%bind ty_smap =
let%bind ty_lmap =
trace_strong (corner_case ~loc:__LOC__ "not a record") @@
get_t_record (get_type_annotation record) in
let%bind ty'_smap = bind_map_smap transpile_type ty_smap in
let%bind ty'_lmap = AST.bind_map_lmap transpile_type ty_lmap in
let%bind path =
trace_strong (corner_case ~loc:__LOC__ "record access") @@
record_access_to_lr ty' ty'_smap property in
record_access_to_lr ty' ty'_lmap property in
let aux = fun pred (ty, lr) ->
let c = match lr with
| `Left -> "CAR"
| `Right -> "CDR" in
| `Left -> C_CAR
| `Right -> C_CDR in
Combinators.Expression.make_tpl (E_constant (c, [pred]) , ty) in
let%bind record' = transpile_annotated_expression record in
let expr = List.fold_left aux record' path in
@ -379,7 +371,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
let%bind body' = transpile_annotated_expression l.body in
let%bind (input , _) = AST.get_t_function f.type_annotation in
let%bind input' = transpile_type input in
ok ((Var.of_name l.binder , input') , body')
ok ((l.binder , input') , body')
in
let expression_to_iterator_body (f : AST.annotated_expression) =
match f.expression with
@ -399,29 +391,29 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
| _ -> fail @@ unsupported_iterator f.location
in
fun (lst : AST.annotated_expression list) -> match (lst , iterator_name) with
| [f ; i] , "ITER" | [f ; i] , "MAP" -> (
| [f ; i] , C_ITER | [f ; i] , C_MAP -> (
let%bind f' = expression_to_iterator_body f in
let%bind i' = transpile_annotated_expression i in
return @@ E_iterator (iterator_name , f' , i')
)
| [ f ; collection ; initial ] , "FOLD" -> (
| [ f ; collection ; initial ] , C_FOLD -> (
let%bind f' = expression_to_iterator_body f in
let%bind initial' = transpile_annotated_expression initial in
let%bind collection' = transpile_annotated_expression collection in
return @@ E_fold (f' , collection' , initial')
)
| _ -> fail @@ corner_case ~loc:__LOC__ ("bad iterator arity:" ^ iterator_name)
| _ -> fail @@ corner_case ~loc:__LOC__ (Format.asprintf "bad iterator arity: %a" Stage_common.PP.constant iterator_name)
in
let (iter , map , fold) = iterator_generator "ITER" , iterator_generator "MAP" , iterator_generator "FOLD" in
let (iter , map , fold) = iterator_generator C_ITER, iterator_generator C_MAP, iterator_generator C_FOLD in
match (name , lst) with
| ("SET_ITER" , lst) -> iter lst
| ("LIST_ITER" , lst) -> iter lst
| ("MAP_ITER" , lst) -> iter lst
| ("LIST_MAP" , lst) -> map lst
| ("MAP_MAP" , lst) -> map lst
| ("LIST_FOLD" , lst) -> fold lst
| ("SET_FOLD" , lst) -> fold lst
| ("MAP_FOLD" , lst) -> fold lst
| (C_SET_ITER , lst) -> iter lst
| (C_LIST_ITER , lst) -> iter lst
| (C_MAP_ITER , lst) -> iter lst
| (C_LIST_MAP , lst) -> map lst
| (C_MAP_MAP , lst) -> map lst
| (C_LIST_FOLD , lst) -> fold lst
| (C_SET_FOLD , lst) -> fold lst
| (C_MAP_FOLD , lst) -> fold lst
| _ -> (
let%bind lst' = bind_map_list (transpile_annotated_expression) lst in
return @@ E_constant (name , lst')
@ -436,7 +428,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
get_t_list tv in
let%bind lst' = bind_map_list (transpile_annotated_expression) lst in
let aux : expression -> expression -> expression result = fun prev cur ->
return @@ E_constant ("CONS", [cur ; prev]) in
return @@ E_constant (C_CONS, [cur ; prev]) in
let%bind (init : expression) = return @@ E_make_empty_list t in
bind_fold_right_list aux init lst'
)
@ -446,7 +438,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
get_t_set tv in
let%bind lst' = bind_map_list (transpile_annotated_expression) lst in
let aux : expression -> expression -> expression result = fun prev cur ->
return @@ E_constant ("SET_ADD", [cur ; prev]) in
return @@ E_constant (C_SET_ADD, [cur ; prev]) in
let%bind (init : expression) = return @@ E_make_empty_set t in
bind_fold_list aux init lst'
)
@ -459,7 +451,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
let%bind (k', v') =
let v' = e_a_some v ae.environment in
bind_map_pair (transpile_annotated_expression) (k , v') in
return @@ E_constant ("UPDATE", [k' ; v' ; prev'])
return @@ E_constant (C_UPDATE, [k' ; v' ; prev'])
in
let init = return @@ E_make_empty_map (src, dst) in
List.fold_left aux init m
@ -473,14 +465,14 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
let%bind (k', v') =
let v' = e_a_some v ae.environment in
bind_map_pair (transpile_annotated_expression) (k , v') in
return @@ E_constant ("UPDATE", [k' ; v' ; prev'])
return @@ E_constant (C_UPDATE, [k' ; v' ; prev'])
in
let init = return @@ E_make_empty_big_map (src, dst) in
List.fold_left aux init m
)
| E_look_up dsi -> (
let%bind (ds', i') = bind_map_pair f dsi in
return @@ E_constant ("MAP_GET", [i' ; ds'])
return @@ E_constant (C_MAP_GET, [i' ; ds'])
)
| E_sequence (a , b) -> (
let%bind a' = transpile_annotated_expression a in
@ -511,18 +503,18 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
let%bind ty_map =
trace_strong (corner_case ~loc:__LOC__ "not a record") @@
AST.Combinators.get_t_record prev in
let%bind ty'_map = bind_map_smap transpile_type ty_map in
let%bind ty'_map = bind_map_lmap transpile_type ty_map in
let%bind path = record_access_to_lr ty' ty'_map prop in
let path' = List.map snd path in
let%bind prop_in_ty_map = trace_option
(Errors.not_found "acessing prop in ty_map [TODO: better error message]")
(Map.String.find_opt prop ty_map) in
(AST.LMap.find_opt (Label prop) ty_map) in
ok (prop_in_ty_map, acc @ path')
)
in
let%bind (_, path) = bind_fold_list aux (ty, []) path in
let%bind expr' = transpile_annotated_expression expr in
return (E_assignment (Var.of_name typed_name.type_name, path, expr'))
return (E_assignment (typed_name.type_name, path, expr'))
)
| E_matching (expr, m) -> (
let%bind expr' = transpile_annotated_expression expr in
@ -530,24 +522,23 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
| Match_bool {match_true ; match_false} ->
let%bind (t , f) = bind_map_pair (transpile_annotated_expression) (match_true, match_false) in
return @@ E_if_bool (expr', t, f)
| Match_option { match_none; match_some = ((name, tv), s) } ->
| Match_option { match_none; match_some = (name, s, tv) } ->
let%bind n = transpile_annotated_expression match_none in
let%bind (tv' , s') =
let%bind tv' = transpile_type tv in
let%bind s' = transpile_annotated_expression s in
ok (tv' , s')
in
return @@ E_if_none (expr' , n , ((Var.of_name name , tv') , s'))
return @@ E_if_none (expr' , n , ((name , tv') , s'))
| Match_list {
match_nil ;
match_cons = (((hd_name , hd_ty) , (tl_name , tl_ty)) , match_cons) ;
match_cons = ((hd_name) , (tl_name), match_cons, ty) ;
} -> (
let%bind nil = transpile_annotated_expression match_nil in
let%bind cons =
let%bind hd_ty' = transpile_type hd_ty in
let%bind tl_ty' = transpile_type tl_ty in
let%bind ty' = transpile_type ty in
let%bind match_cons' = transpile_annotated_expression match_cons in
ok (((Var.of_name hd_name , hd_ty') , (Var.of_name tl_name , tl_ty')) , match_cons')
ok (((hd_name , ty') , (tl_name , ty')) , match_cons')
in
return @@ E_if_cons (expr' , nil , cons)
)
@ -579,20 +570,20 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
trace_option (corner_case ~loc:__LOC__ "missing match clause") @@
List.find_opt (fun ((constructor_name' , _) , _) -> constructor_name' = constructor_name) lst in
let%bind body' = transpile_annotated_expression body in
return @@ E_let_in ((Var.of_name name , tv) , top , body')
return @@ E_let_in ((name , tv) , top , body')
)
| ((`Node (a , b)) , tv) ->
let%bind a' =
let%bind a_ty = get_t_left tv in
let a_var = Var.of_name "left" , a_ty in
let%bind e = aux (((Expression.make (E_variable (Var.of_name "left")) a_ty))) a in
ok (a_var , e)
let left_var = Var.fresh ~name:"left" () in
let%bind e = aux (((Expression.make (E_variable left_var) a_ty))) a in
ok ((left_var , a_ty) , e)
in
let%bind b' =
let%bind b_ty = get_t_right tv in
let b_var = Var.of_name "right" , b_ty in
let%bind e = aux (((Expression.make (E_variable (Var.of_name "right")) b_ty))) b in
ok (b_var , e)
let right_var = Var.fresh ~name:"right" () in
let%bind e = aux (((Expression.make (E_variable right_var) b_ty))) b in
ok ((right_var , b_ty) , e)
in
return @@ E_if_left (top , a' , b')
in
@ -608,7 +599,7 @@ and transpile_lambda l (input_type , output_type) =
let%bind input = transpile_type input_type in
let%bind output = transpile_type output_type in
let tv = Combinators.t_function input output in
let closure = E_closure { binder = Var.of_name binder ; body = result'} in
let closure = E_closure { binder; body = result'} in
ok @@ Combinators.Expression.make_tpl (closure , tv)
let transpile_declaration env (d:AST.declaration) : toplevel_statement result =
@ -616,8 +607,8 @@ let transpile_declaration env (d:AST.declaration) : toplevel_statement result =
| Declaration_constant ({name;annotated_expression} , _) ->
let%bind expression = transpile_annotated_expression annotated_expression in
let tv = Combinators.Expression.get_type expression in
let env' = Environment.add (Var.of_name name, tv) env in
ok @@ ((Var.of_name name, expression), environment_wrap env env')
let env' = Environment.add (name, tv) env in
ok @@ ((name, expression), environment_wrap env env')
let transpile_program (lst : AST.program) : program result =
let aux (prev:(toplevel_statement list * Environment.t) result) cur =

283
src/passes/6-transpiler/untranspiler.ml
View File

@ -53,142 +53,148 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
let open! AST in
let return e = ok (make_a_e_empty e t) in
match t.type_value' with
| T_constant (Type_name "unit", []) -> (
let%bind () =
trace_strong (wrong_mini_c_value "unit" v) @@
get_unit v in
return (E_literal Literal_unit)
)
| T_constant (Type_name "bool", []) -> (
let%bind b =
trace_strong (wrong_mini_c_value "bool" v) @@
get_bool v in
return (E_literal (Literal_bool b))
)
| T_constant (Type_name "int", []) -> (
let%bind n =
trace_strong (wrong_mini_c_value "int" v) @@
get_int v in
return (E_literal (Literal_int n))
)
| T_constant (Type_name "nat", []) -> (
let%bind n =
trace_strong (wrong_mini_c_value "nat" v) @@
get_nat v in
return (E_literal (Literal_nat n))
)
| T_constant (Type_name "timestamp", []) -> (
let%bind n =
trace_strong (wrong_mini_c_value "timestamp" v) @@
get_timestamp v in
return (E_literal (Literal_timestamp n))
)
| T_constant (Type_name "tez", []) -> (
let%bind n =
trace_strong (wrong_mini_c_value "tez" v) @@
get_mutez v in
return (E_literal (Literal_mutez n))
)
| T_constant (Type_name "string", []) -> (
let%bind n =
trace_strong (wrong_mini_c_value "string" v) @@
get_string v in
return (E_literal (Literal_string n))
)
| T_constant (Type_name "bytes", []) -> (
let%bind n =
trace_strong (wrong_mini_c_value "bytes" v) @@
get_bytes v in
return (E_literal (Literal_bytes n))
)
| T_constant (Type_name "address", []) -> (
let%bind n =
trace_strong (wrong_mini_c_value "address" v) @@
get_string v in
return (E_literal (Literal_address n))
)
| T_constant (Type_name "option", [o]) -> (
let%bind opt =
trace_strong (wrong_mini_c_value "option" v) @@
get_option v in
match opt with
| None -> ok (e_a_empty_none o)
| Some s ->
let%bind s' = untranspile s o in
ok (e_a_empty_some s')
)
| T_constant (Type_name "map", [k_ty;v_ty]) -> (
let%bind lst =
trace_strong (wrong_mini_c_value "map" v) @@
get_map v in
let%bind lst' =
let aux = fun (k, v) ->
let%bind k' = untranspile k k_ty in
let%bind v' = untranspile v v_ty in
ok (k', v') in
bind_map_list aux lst in
return (E_map lst')
)
| T_constant (Type_name "big_map", [k_ty;v_ty]) -> (
let%bind lst =
trace_strong (wrong_mini_c_value "big_map" v) @@
get_big_map v in
let%bind lst' =
let aux = fun (k, v) ->
let%bind k' = untranspile k k_ty in
let%bind v' = untranspile v v_ty in
ok (k', v') in
bind_map_list aux lst in
return (E_big_map lst')
)
| T_constant (Type_name "list", [ty]) -> (
let%bind lst =
trace_strong (wrong_mini_c_value "list" v) @@
get_list v in
let%bind lst' =
let aux = fun e -> untranspile e ty in
bind_map_list aux lst in
return (E_list lst')
)
| T_constant (Type_name "key", []) -> (
let%bind n =
trace_strong (wrong_mini_c_value "key" v) @@
get_string v in
return (E_literal (Literal_key n))
| T_constant type_constant -> (
match type_constant with
| TC_unit -> (
let%bind () =
trace_strong (wrong_mini_c_value "unit" v) @@
get_unit v in
return (E_literal Literal_unit)
)
| TC_bool -> (
let%bind b =
trace_strong (wrong_mini_c_value "bool" v) @@
get_bool v in
return (E_literal (Literal_bool b))
)
| TC_int -> (
let%bind n =
trace_strong (wrong_mini_c_value "int" v) @@
get_int v in
return (E_literal (Literal_int n))
)
| TC_nat -> (
let%bind n =
trace_strong (wrong_mini_c_value "nat" v) @@
get_nat v in
return (E_literal (Literal_nat n))
)
| TC_timestamp -> (
let%bind n =
trace_strong (wrong_mini_c_value "timestamp" v) @@
get_timestamp v in
return (E_literal (Literal_timestamp n))
)
| TC_mutez -> (
let%bind n =
trace_strong (wrong_mini_c_value "tez" v) @@
get_mutez v in
return (E_literal (Literal_mutez n))
)
| TC_string -> (
let%bind n =
trace_strong (wrong_mini_c_value "string" v) @@
get_string v in
return (E_literal (Literal_string n))
)
| TC_bytes -> (
let%bind n =
trace_strong (wrong_mini_c_value "bytes" v) @@
get_bytes v in
return (E_literal (Literal_bytes n))
)
| TC_address -> (
let%bind n =
trace_strong (wrong_mini_c_value "address" v) @@
get_string v in
return (E_literal (Literal_address n))
)
| TC_operation -> (
let%bind op =
trace_strong (wrong_mini_c_value "operation" v) @@
get_operation v in
return (E_literal (Literal_operation op))
)
| TC_key -> (
let%bind n =
trace_strong (wrong_mini_c_value "key" v) @@
get_string v in
return (E_literal (Literal_key n))
)
| TC_key_hash -> (
let%bind n =
trace_strong (wrong_mini_c_value "key_hash" v) @@
get_string v in
return (E_literal (Literal_key_hash n))
)
| TC_chain_id -> (
let%bind n =
trace_strong (wrong_mini_c_value "chain_id" v) @@
get_string v in
return (E_literal (Literal_chain_id n))
)
| TC_signature ->
fail @@ bad_untranspile "signature" v
)
| T_constant (Type_name "key_hash", []) -> (
let%bind n =
trace_strong (wrong_mini_c_value "key_hash" v) @@
get_string v in
return (E_literal (Literal_key_hash n))
| T_operator type_operator -> (
match type_operator with
| TC_option o -> (
let%bind opt =
trace_strong (wrong_mini_c_value "option" v) @@
get_option v in
match opt with
| None -> ok (e_a_empty_none o)
| Some s ->
let%bind s' = untranspile s o in
ok (e_a_empty_some s')
)
| TC_map (k_ty,v_ty)-> (
let%bind lst =
trace_strong (wrong_mini_c_value "map" v) @@
get_map v in
let%bind lst' =
let aux = fun (k, v) ->
let%bind k' = untranspile k k_ty in
let%bind v' = untranspile v v_ty in
ok (k', v') in
bind_map_list aux lst in
return (E_map lst')
)
| TC_big_map (k_ty, v_ty) -> (
let%bind lst =
trace_strong (wrong_mini_c_value "big_map" v) @@
get_big_map v in
let%bind lst' =
let aux = fun (k, v) ->
let%bind k' = untranspile k k_ty in
let%bind v' = untranspile v v_ty in
ok (k', v') in
bind_map_list aux lst in
return (E_big_map lst')
)
| TC_list ty -> (
let%bind lst =
trace_strong (wrong_mini_c_value "list" v) @@
get_list v in
let%bind lst' =
let aux = fun e -> untranspile e ty in
bind_map_list aux lst in
return (E_list lst')
)
| TC_set ty -> (
let%bind lst =
trace_strong (wrong_mini_c_value "set" v) @@
get_set v in
let%bind lst' =
let aux = fun e -> untranspile e ty in
bind_map_list aux lst in
return (E_set lst')
)
| TC_contract _ ->
fail @@ bad_untranspile "contract" v
)
| T_constant (Type_name "chain_id", []) -> (
let%bind n =
trace_strong (wrong_mini_c_value "chain_id" v) @@
get_string v in
return (E_literal (Literal_chain_id n))
)
| T_constant (Type_name "set", [ty]) -> (
let%bind lst =
trace_strong (wrong_mini_c_value "set" v) @@
get_set v in
let%bind lst' =
let aux = fun e -> untranspile e ty in
bind_map_list aux lst in
return (E_set lst')
)
| T_constant (Type_name "contract" , [_ty]) ->
fail @@ bad_untranspile "contract" v
| T_constant (Type_name "operation" , []) -> (
let%bind op =
trace_strong (wrong_mini_c_value "operation" v) @@
get_operation v in
return (E_literal (Literal_operation op))
)
| T_constant (Type_name name , _lst) ->
fail @@ unknown_untranspile name v
| T_sum m ->
let lst = kv_list_of_map m in
let lst = kv_list_of_cmap m in
let%bind node = match Append_tree.of_list lst with
| Empty -> fail @@ corner_case ~loc:__LOC__ "empty sum type"
| Full t -> ok t
@ -197,7 +203,7 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
trace_strong (corner_case ~loc:__LOC__ "sum extract constructor") @@
extract_constructor v node in
let%bind sub = untranspile v tv in
return (E_constructor (name, sub))
return (E_constructor (Constructor name, sub))
| T_tuple lst ->
let%bind node = match Append_tree.of_list lst with
| Empty -> fail @@ corner_case ~loc:__LOC__ "empty tuple"
@ -209,7 +215,7 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
@@ List.map (fun (x, y) -> untranspile x y) tpl in
return (E_tuple tpl')
| T_record m ->
let lst = kv_list_of_map m in
let lst = kv_list_of_lmap m in
let%bind node = match Append_tree.of_list lst with
| Empty -> fail @@ corner_case ~loc:__LOC__ "empty record"
| Full t -> ok t in
@ -218,11 +224,12 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
extract_record v node in
let%bind lst = bind_list
@@ List.map (fun (x, (y, z)) -> let%bind yz = untranspile y z in ok (x, yz)) lst in
let m' = map_of_kv_list lst in
let m' = AST.LMap.of_list lst in
return (E_record m')
| T_function _ ->
| T_arrow _ ->
let%bind n =
trace_strong (wrong_mini_c_value "lambda as string" v) @@
get_string v in
return (E_literal (Literal_string n))
| T_variable (Type_name v) -> return (E_variable v)
| T_variable _ ->
fail @@ corner_case ~loc:__LOC__ "trying to untranspile at variable type"

52
src/passes/7-self_mini_c/self_mini_c.ml
View File

@ -15,28 +15,28 @@ let map_expression :
(* true if the name names a pure constant -- i.e. if uses will be pure
assuming arguments are pure *)
let is_pure_constant : string -> bool =
let is_pure_constant : constant -> bool =
function
| "UNIT"
| "CAR" | "CDR" | "PAIR"
| "NIL" | "CONS"
| "NEG" | "OR" | "AND" | "XOR" | "NOT"
| "EQ" | "NEQ" | "LT" | "LE" | "GT" | "GE"
| "SOME"
| "UPDATE" | "MAP_GET" | "MAP_FIND_OPT" | "MAP_ADD" | "MAP_UPDATE"
| "INT" | "ABS" | "ISNAT"
| "BALANCE" | "AMOUNT" | "ADDRESS" | "NOW" | "SOURCE" | "SENDER" | "CHAIN_ID"
| "SET_MEM" | "SET_ADD" | "SET_REMOVE" | "SLICE"
| "SHA256" | "SHA512" | "BLAKE2B" | "CHECK_SIGNATURE"
| "HASH_KEY" | "PACK" | "CONCAT"
| C_UNIT
| C_CAR | C_CDR | C_PAIR
| C_NIL | C_CONS
| C_NEG | C_OR | C_AND | C_XOR | C_NOT
| C_EQ | C_NEQ | C_LT | C_LE | C_GT | C_GE
| C_SOME
| C_UPDATE | C_MAP_GET | C_MAP_FIND_OPT | C_MAP_ADD | C_MAP_UPDATE
| C_INT | C_ABS | C_IS_NAT
| C_BALANCE | C_AMOUNT | C_ADDRESS | C_NOW | C_SOURCE | C_SENDER | C_CHAIN_ID
| C_SET_MEM | C_SET_ADD | C_SET_REMOVE | C_SLICE
| C_SHA256 | C_SHA512 | C_BLAKE2b | C_CHECK_SIGNATURE
| C_HASH_KEY | C_BYTES_PACK | C_CONCAT
-> true
(* unfortunately impure: *)
| "ADD"|"SUB"|"TIMES"|"DIV"|"MOD"
| C_ADD | C_SUB |C_MUL|C_DIV|C_MOD
(* impure: *)
| "ASSERT" | "ASSERT_INFERRED"
| "MAP_GET_FORCE" | "MAP_FIND"
| "FOLD_WHILE"
| "CALL"
| C_ASSERTION | C_ASSERT_INFERRED
| C_MAP_GET_FORCE | C_MAP_FIND
| C_FOLD_WHILE
| C_CALL
(* TODO... *)
| _
-> false
@ -80,12 +80,12 @@ let rec is_pure : expression -> bool = fun e ->
(* definitely not pure *)
| E_assignment _ -> false
let occurs_in : Var.t -> expression -> bool =
let occurs_in : expression_variable -> expression -> bool =
fun x e ->
let fvs = Free_variables.expression [] e in
Free_variables.mem x fvs
let occurs_count : Var.t -> expression -> int =
let occurs_count : expression_variable -> expression -> int =
fun x e ->
let fvs = Free_variables.expression [] e in
Free_variables.mem_count x fvs
@ -93,7 +93,7 @@ let occurs_count : Var.t -> expression -> int =
(* If `ignore_lambdas` is true, ignore assignments which occur inside
lambdas, which have no effect on the value of the variable outside
of the lambda. *)
let rec is_assigned : ignore_lambdas:bool -> Var.t -> expression -> bool =
let rec is_assigned : ignore_lambdas:bool -> expression_variable -> expression -> bool =
fun ~ignore_lambdas x e ->
let self = is_assigned ~ignore_lambdas x in
let selfs = List.exists self in
@ -165,7 +165,7 @@ let rec is_assigned : ignore_lambdas:bool -> Var.t -> expression -> bool =
- ?
*)
let can_inline : Var.t -> expression -> expression -> bool =
let can_inline : expression_variable -> expression -> expression -> bool =
fun x e1 e2 ->
is_pure e1 &&
(* if x does not occur in e2, there can be no other problems:
@ -177,7 +177,7 @@ let can_inline : Var.t -> expression -> expression -> bool =
(fun y -> not (is_assigned ~ignore_lambdas:true y e2))
(Free_variables.expression [] e2)))
let should_inline : Var.t -> expression -> bool =
let should_inline : expression_variable -> expression -> bool =
fun x e ->
occurs_count x e <= 1
@ -232,12 +232,12 @@ let beta : bool ref -> expression -> expression =
else e
(* also do CAR (PAIR x y) ↦ x, or CDR (PAIR x y) ↦ y, only if x and y are pure *)
| E_constant ("CAR"|"CDR" as const, [ { content = E_constant ("PAIR", [ e1 ; e2 ]) ; type_value = _ } ]) ->
| E_constant (C_CAR| C_CDR as const, [ { content = E_constant (C_PAIR, [ e1 ; e2 ]) ; type_value = _ } ]) ->
if is_pure e1 && is_pure e2
then (changed := true ;
match const with
| "CAR" -> e1
| "CDR" -> e2
| C_CAR -> e1
| C_CDR -> e2
| _ -> assert false)
else e
| _ -> e

6
src/passes/7-self_mini_c/subst.ml
View File

@ -317,7 +317,7 @@ let%expect_test _ =
(* iter shadowed *)
Var.reset_counter () ;
show_subst
~body:(wrap (E_iterator ("ITER", ((x , dummy_type) , var x) , var x)))
~body:(wrap (E_iterator (C_ITER, ((x , dummy_type) , var x) , var x)))
~x:x
~expr:unit ;
[%expect{|
@ -328,7 +328,7 @@ let%expect_test _ =
(* iter not shadowed *)
Var.reset_counter () ;
show_subst
~body:(wrap (E_iterator ("ITER", ((y , dummy_type) , var x) , var x)))
~body:(wrap (E_iterator (C_ITER, ((y , dummy_type) , var x) , var x)))
~x:x
~expr:unit ;
[%expect{|
@ -339,7 +339,7 @@ let%expect_test _ =
(* iter capture-avoiding *)
Var.reset_counter () ;
show_subst
~body:(wrap (E_iterator ("ITER", ((y , dummy_type) , app (var x) (var y)), app (var x) (var y))))
~body:(wrap (E_iterator (C_ITER, ((y , dummy_type) , app (var x) (var y)), app (var x) (var y))))
~x:x
~expr:(var y) ;
[%expect{|

9
src/passes/8-compiler/compiler_environment.ml
View File

@ -5,12 +5,13 @@ open Michelson
let empty : environment = []
let get : environment -> Var.t -> michelson result = fun e s ->
let get : environment -> expression_variable -> michelson result = fun e s ->
let%bind (_ , position) =
let error =
let title () = "Environment.get" in
let content () = Format.asprintf "%a in %a"
Var.pp s PP.environment e in
Stage_common.PP.name s
PP.environment e in
error title content in
generic_try error @@
(fun () -> Environment.get_i s e) in
@ -34,10 +35,10 @@ let get : environment -> Var.t -> michelson result = fun e s ->
ok code
let set : environment -> Var.t -> michelson result = fun e s ->
let set : environment -> expression_variable -> michelson result = fun e n ->
let%bind (_ , position) =
generic_try (simple_error "Environment.set") @@
(fun () -> Environment.get_i s e) in
(fun () -> Environment.get_i n e) in
let rec aux_bubble = fun n ->
match n with
| 0 -> dip i_drop

4
src/passes/8-compiler/compiler_environment.mli
View File

@ -7,8 +7,8 @@ open Michelson
module Stack = Meta_michelson.Stack
*)
val empty: environment
val get : environment -> Var.t -> michelson result
val set : environment -> Var.t -> michelson result
val get : environment -> expression_variable -> michelson result
val set : environment -> expression_variable -> michelson result
val pack_closure : environment -> selector -> michelson result
val unpack_closure : environment -> michelson result

43
src/passes/8-compiler/compiler_program.ml
View File

@ -26,32 +26,34 @@ them. please report this to the developers." in
end
open Errors
let get_operator : string -> type_value -> expression list -> predicate result = fun s ty lst ->
match Map.String.find_opt s Operators.Compiler.operators with
| Some x -> ok x
| None -> (
(* This does not makes sense to me *)
let get_operator : constant -> type_value -> expression list -> predicate result = fun s ty lst ->
match Operators.Compiler.get_operators s with
| Trace.Ok (x,_) -> ok x
| Trace.Error _ -> (
match s with
| "NONE" -> (
| C_NONE -> (
let%bind ty' = Mini_c.get_t_option ty in
let%bind m_ty = Compiler_type.type_ ty' in
ok @@ simple_constant @@ prim ~children:[m_ty] I_NONE
)
| "NIL" -> (
| C_NIL -> (
let%bind ty' = Mini_c.get_t_list ty in
let%bind m_ty = Compiler_type.type_ ty' in
ok @@ simple_unary @@ prim ~children:[m_ty] I_NIL
)
| "SET_EMPTY" -> (
| C_SET_EMPTY -> (
let%bind ty' = Mini_c.get_t_set ty in
let%bind m_ty = Compiler_type.type_ ty' in
ok @@ simple_constant @@ prim ~children:[m_ty] I_EMPTY_SET
)
| "UNPACK" -> (
| C_BYTES_UNPACK -> (
let%bind ty' = Mini_c.get_t_option ty in
let%bind m_ty = Compiler_type.type_ ty' in
ok @@ simple_unary @@ prim ~children:[m_ty] I_UNPACK
)
| "MAP_REMOVE" ->
| C_MAP_REMOVE ->
let%bind v = match lst with
| [ _ ; expr ] ->
let%bind (_, v) = Mini_c.Combinators.(bind_map_or (get_t_map , get_t_big_map) (Expression.get_type expr)) in
@ -59,26 +61,26 @@ let get_operator : string -> type_value -> expression list -> predicate result =
| _ -> simple_fail "mini_c . MAP_REMOVE" in
let%bind v_ty = Compiler_type.type_ v in
ok @@ simple_binary @@ seq [dip (i_none v_ty) ; prim I_UPDATE ]
| "LEFT" ->
| C_LEFT ->
let%bind r = match lst with
| [ _ ] -> get_t_right ty
| _ -> simple_fail "mini_c . LEFT" in
let%bind r_ty = Compiler_type.type_ r in
ok @@ simple_unary @@ prim ~children:[r_ty] I_LEFT
| "RIGHT" ->
| C_RIGHT ->
let%bind l = match lst with
| [ _ ] -> get_t_left ty
| _ -> simple_fail "mini_c . RIGHT" in
let%bind l_ty = Compiler_type.type_ l in
ok @@ simple_unary @@ prim ~children:[l_ty] I_RIGHT
| "CONTRACT" ->
| C_CONTRACT ->
let%bind r = get_t_contract ty in
let%bind r_ty = Compiler_type.type_ r in
ok @@ simple_unary @@ seq [
prim ~children:[r_ty] I_CONTRACT ;
i_assert_some_msg (i_push_string "bad address for get_contract") ;
]
| "CONTRACT_ENTRYPOINT" ->
| C_CONTRACT_ENTRYPOINT ->
let%bind r = get_t_contract ty in
let%bind r_ty = Compiler_type.type_ r in
let%bind entry = match lst with
@ -92,7 +94,7 @@ let get_operator : string -> type_value -> expression list -> predicate result =
prim ~annot:[entry] ~children:[r_ty] I_CONTRACT ;
i_assert_some_msg (i_push_string @@ Format.sprintf "bad address for get_entrypoint (%s)" entry) ;
]
| x -> simple_fail ("predicate \"" ^ x ^ "\" doesn't exist")
| x -> simple_fail (Format.asprintf "predicate \"%a\" doesn't exist" Stage_common.PP.constant x)
)
let rec translate_value (v:value) ty : michelson result = match v with
@ -159,7 +161,7 @@ let rec translate_value (v:value) ty : michelson result = match v with
and translate_expression (expr:expression) (env:environment) : michelson result =
let (expr' , ty) = Combinators.Expression.(get_content expr , get_type expr) in
let error_message () =
Format.asprintf "\n- expr: %a\n- type: %a\n" PP.expression expr PP.type_ ty
Format.asprintf "\n- expr: %a\n- type: %a\n" PP.expression expr PP.type_variable ty
in
let return code = ok code in
@ -227,7 +229,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result
pre_code ;
f ;
]
| _ -> simple_fail ("bad arity for " ^ str)
| _ -> simple_fail (Format.asprintf "bad arity for %a" Stage_common.PP.constant str)
in
let error =
let title () = "error compiling constant" in
@ -329,7 +331,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result
let%bind expr' = translate_expression expr env in
let%bind body' = translate_expression body (Environment.add v env) in
match name with
| "ITER" -> (
| C_ITER -> (
let%bind code = ok (seq [
expr' ;
i_iter (seq [body' ; i_drop ; i_drop]) ;
@ -337,7 +339,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result
]) in
return code
)
| "MAP" -> (
| C_MAP -> (
let%bind code = ok (seq [
expr' ;
i_map (seq [body' ; dip i_drop]) ;
@ -345,7 +347,8 @@ and translate_expression (expr:expression) (env:environment) : michelson result
return code
)
| s -> (
let error = error (thunk "bad iterator") (thunk s) in
let iter = Format.asprintf "iter %a" Stage_common.PP.constant s in
let error = error (thunk "bad iterator") (thunk iter) in
fail error
)
)
@ -454,7 +457,7 @@ type compiled_program = {
}
let get_main : program -> string -> (anon_function * _) result = fun p entry ->
let is_main (((name , expr), _):toplevel_statement) =
let is_main ((( name , expr), _):toplevel_statement) =
match Combinators.Expression.(get_content expr , get_type expr)with
| (E_closure content , T_function ty)
when Var.equal name (Var.of_name entry) ->

3
src/passes/8-compiler/compiler_program.mli
View File

@ -15,13 +15,14 @@ type compiled_program = {
body : michelson ;
}
val get_operator : string -> type_value -> expression list -> predicate result
val get_operator : constant -> type_value -> expression list -> predicate result
val translate_expression : expression -> environment -> michelson result
val translate_function_body : anon_function -> environment_element list -> type_value -> michelson result
val translate_value : value -> type_value -> michelson result
val translate_program : program -> string -> compiled_program result
val translate_contract : anon_function -> (type_value * type_value ) -> michelson result
val translate_entry : anon_function -> type_value * type_value -> compiled_program result

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

@ -63,7 +63,7 @@ module Ty = struct
| Base_void -> fail (not_comparable "void")
| Base_bool -> fail (not_comparable "bool")
| Base_nat -> return nat_k
| Base_tez -> return tez_k
| Base_mutez -> return tez_k
| Base_int -> return int_k
| Base_string -> return string_k
| Base_address -> return address_k
@ -96,7 +96,7 @@ module Ty = struct
| Base_bool -> return bool
| Base_int -> return int
| Base_nat -> return nat
| Base_tez -> return tez
| Base_mutez -> return tez
| Base_string -> return string
| Base_address -> return address
| Base_timestamp -> return timestamp
@ -181,7 +181,7 @@ let base_type : type_base -> O.michelson result =
| Base_bool -> ok @@ O.prim T_bool
| Base_int -> ok @@ O.prim T_int
| Base_nat -> ok @@ O.prim T_nat
| Base_tez -> ok @@ O.prim T_mutez
| Base_mutez -> ok @@ O.prim T_mutez
| Base_string -> ok @@ O.prim T_string
| Base_address -> ok @@ O.prim T_address
| Base_timestamp -> ok @@ O.prim T_timestamp

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

@ -21,90 +21,80 @@ module Typer = struct
end
open Errors
type type_result = string * type_value
type typer' = type_value list -> type_value option -> type_result result
type typer = string * typer'
type type_result = type_value
type typer = type_value list -> type_value option -> type_result result
let typer'_0 : name -> (type_value option -> type_value result) -> typer' = fun s f lst tv_opt ->
let typer_0 : string -> (type_value option -> type_value result) -> typer = fun s f lst tv_opt ->
match lst with
| [] -> (
let%bind tv' = f tv_opt in
ok (s , tv')
ok (tv')
)
| _ -> fail @@ wrong_param_number s 0 lst
let typer_0 name f : typer = (name , typer'_0 name f)
let typer'_1 : name -> (type_value -> type_value result) -> typer' = fun s f lst _ ->
let typer_1 : string -> (type_value -> type_value result) -> typer = fun s f lst _ ->
match lst with
| [ a ] -> (
let%bind tv' = f a in
ok (s , tv')
ok (tv')
)
| _ -> fail @@ wrong_param_number s 1 lst
let typer_1 name f : typer = (name , typer'_1 name f)
let typer'_1_opt : name -> (type_value -> type_value option -> type_value result) -> typer' = fun s f lst tv_opt ->
let typer_1_opt : string -> (type_value -> type_value option -> type_value result) -> typer = fun s f lst tv_opt ->
match lst with
| [ a ] -> (
let%bind tv' = f a tv_opt in
ok (s , tv')
ok (tv')
)
| _ -> fail @@ wrong_param_number s 1 lst
let typer_1_opt name f : typer = (name , typer'_1_opt name f)
let typer'_2 : name -> (type_value -> type_value -> type_value result) -> typer' = fun s f lst _ ->
let typer_2 : string -> (type_value -> type_value -> type_value result) -> typer = fun s f lst _ ->
match lst with
| [ a ; b ] -> (
let%bind tv' = f a b in
ok (s , tv')
ok (tv')
)
| _ -> fail @@ wrong_param_number s 2 lst
let typer_2 name f : typer = (name , typer'_2 name f)
let typer'_2_opt : name -> (type_value -> type_value -> type_value option -> type_value result) -> typer' = fun s f lst tv_opt ->
let typer_2_opt : string -> (type_value -> type_value -> type_value option -> type_value result) -> typer = fun s f lst tv_opt ->
match lst with
| [ a ; b ] -> (
let%bind tv' = f a b tv_opt in
ok (s , tv')
ok (tv')
)
| _ -> fail @@ wrong_param_number s 2 lst
let typer_2_opt name f : typer = (name , typer'_2_opt name f)
let typer'_3 : name -> (type_value -> type_value -> type_value -> type_value result) -> typer' = fun s f lst _ ->
let typer_3 : string -> (type_value -> type_value -> type_value -> type_value result) -> typer = fun s f lst _ ->
match lst with
| [ a ; b ; c ] -> (
let%bind tv' = f a b c in
ok (s , tv')
ok (tv')
)
| _ -> fail @@ wrong_param_number s 3 lst
let typer_3 name f : typer = (name , typer'_3 name f)
let typer'_4 : name -> (type_value -> type_value -> type_value -> type_value -> type_value result) -> typer' = fun s f lst _ ->
let typer_4 : string -> (type_value -> type_value -> type_value -> type_value -> type_value result) -> typer = fun s f lst _ ->
match lst with
| [ a ; b ; c ; d ] -> (
let%bind tv' = f a b c d in
ok (s , tv')
ok (tv')
)
| _ -> fail @@ wrong_param_number s 4 lst
let typer_4 name f : typer = (name , typer'_4 name f)
let typer'_5 : name -> (type_value -> type_value -> type_value -> type_value -> type_value -> type_value result) -> typer' = fun s f lst _ ->
let typer_5 : string -> (type_value -> type_value -> type_value -> type_value -> type_value -> type_value result) -> typer = fun s f lst _ ->
match lst with
| [ a ; b ; c ; d ; e ] -> (
let%bind tv' = f a b c d e in
ok (s , tv')
ok (tv')
)
| _ -> fail @@ wrong_param_number s 5 lst
let typer_5 name f : typer = (name , typer'_5 name f)
let typer'_6 : name -> (type_value -> type_value -> type_value -> type_value -> type_value -> type_value -> type_value result) -> typer' = fun s f lst _ ->
let typer_6 : string -> (type_value -> type_value -> type_value -> type_value -> type_value -> type_value -> type_value result) -> typer = fun s f lst _ ->
match lst with
| [ a ; b ; c ; d ; e ; f_ ] -> (
let%bind tv' = f a b c d e f_ in
ok (s , tv')
ok (tv')
)
| _ -> fail @@ wrong_param_number s 6 lst
let typer_6 name f : typer = (name , typer'_6 name f)
let constant name cst = typer_0 name (fun _ -> ok cst)

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

@ -3,56 +3,55 @@ module Typer : sig
open Ast_typed
module Errors : sig
val wrong_param_number : name -> int -> 'a list -> unit -> error
val wrong_param_number : string -> int -> 'a list -> unit -> error
val error_uncomparable_types : type_value -> type_value -> unit -> error
end
type type_result = string * type_value
type typer' = type_value list -> type_value option -> type_result result
type typer = string * typer'
type type_result = type_value
type typer = type_value list -> type_value option -> type_result result
(*
val typer'_0 : name -> (type_value option -> type_value result) -> typer'
*)
val typer_0 : name -> ( type_value option -> type_value result ) -> typer
val typer_0 : string -> ( type_value option -> type_value result ) -> typer
(*
val typer'_1 : name -> (type_value -> type_value result) -> typer'
*)
val typer_1 : name -> (type_value -> type_value result) -> typer
val typer_1 : string -> (type_value -> type_value result) -> typer
(*
val typer'_1_opt : name -> (type_value -> type_value option -> type_value result) -> typer'
*)
val typer_1_opt : name -> (type_value -> type_value option -> type_value result) -> typer
val typer_1_opt : string -> (type_value -> type_value option -> type_value result) -> typer
(*
val typer'_2 : name -> (type_value -> type_value -> type_value result) -> typer'
*)
val typer_2 : name -> (type_value -> type_value -> type_value result) -> typer
val typer_2_opt : name -> (type_value -> type_value -> type_value option -> type_value result) -> typer
val typer_2 : string -> (type_value -> type_value -> type_value result) -> typer
val typer_2_opt : string -> (type_value -> type_value -> type_value option -> type_value result) -> typer
(*
val typer'_3 : name -> (type_value -> type_value -> type_value -> type_value result) -> typer'
*)
val typer_3 : name -> (type_value -> type_value -> type_value -> type_value result) -> typer
val typer_3 : string -> (type_value -> type_value -> type_value -> type_value result) -> typer
(*
val typer'_4 : name -> (type_value -> type_value -> type_value -> type_value -> type_value result) -> typer'
*)
val typer_4 : name -> (type_value -> type_value -> type_value -> type_value -> type_value result) -> typer
val typer_4 : string -> (type_value -> type_value -> type_value -> type_value -> type_value result) -> typer
(*
val typer'_5 : name -> (type_value -> type_value -> type_value -> type_value -> type_value -> type_value result) -> typer'
*)
val typer_5 : name -> (type_value -> type_value -> type_value -> type_value -> type_value -> type_value result) -> typer
val typer_5 : string -> (type_value -> type_value -> type_value -> type_value -> type_value -> type_value result) -> typer
(*
val typer'_6 : name -> (type_value -> type_value -> type_value -> type_value -> type_value -> type_value -> type_value result) -> typer'
*)
val typer_6 : name -> (type_value -> type_value -> type_value -> type_value -> type_value -> type_value -> type_value result) -> typer
val typer_6 : string -> (type_value -> type_value -> type_value -> type_value -> type_value -> type_value -> type_value result) -> typer
val constant : name -> type_value -> typer
val constant : string -> type_value -> typer
val eq_1 : type_value -> type_value -> bool
val eq_2 : ( type_value * type_value ) -> type_value -> bool
val assert_eq_1 : ?msg:string -> type_value -> type_value -> unit result
val comparator : name -> typer
val boolean_operator_2 : name -> typer
val comparator : string -> typer
val boolean_operator_2 : string -> typer
end

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

@ -11,6 +11,7 @@ open Trace
module Simplify = struct
open Ast_simplified
(*
Each front-end has its owns constants.
@ -31,197 +32,236 @@ module Simplify = 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" -> ok TC_chain_id
| "unit" -> ok TC_unit
| "string" -> ok TC_string
| "bytes" -> ok TC_bytes
| "nat" -> ok TC_nat
| "int" -> ok TC_int
| "tez" -> ok TC_mutez
| "bool" -> ok TC_bool
| "operation" -> ok TC_operation
| "address" -> ok TC_address
| "key" -> ok TC_key
| "key_hash" -> ok TC_key_hash
| "signature" -> ok TC_signature
| "timestamp" -> ok TC_timestamp
| _ -> simple_fail @@ "Not a type_constant " ^ s
let type_operators s =
match s with
| "list" -> ok @@ TC_list unit_expr
| "option" -> ok @@ TC_option unit_expr
| "set" -> ok @@ TC_set unit_expr
| "map" -> ok @@ TC_map (unit_expr,unit_expr)
| "big_map" -> ok @@ TC_big_map (unit_expr,unit_expr)
| "contract" -> ok @@ TC_contract unit_expr
| _ -> simple_fail @@ "Not a typ_operator " ^ s
let type_constants = [
("unit" , "unit") ;
("string" , "string") ;
("bytes" , "bytes") ;
("nat" , "nat") ;
("int" , "int") ;
("tez" , "tez") ;
("bool" , "bool") ;
("operation" , "operation") ;
("address" , "address") ;
("key" , "key") ;
("key_hash" , "key_hash") ;
("signature" , "signature") ;
("timestamp" , "timestamp") ;
("contract" , "contract") ;
("list" , "list") ;
("option" , "option") ;
("set" , "set") ;
("map" , "map") ;
("big_map" , "big_map") ;
("chain_id" , "chain_id") ;
]
module Pascaligo = struct
let constants = [
("get_force" , "MAP_GET_FORCE") ;
("get_chain_id", "CHAIN_ID");
("transaction" , "CALL") ;
("get_contract" , "CONTRACT") ;
("get_entrypoint" , "CONTRACT_ENTRYPOINT") ;
("size" , "SIZE") ;
("int" , "INT") ;
("abs" , "ABS") ;
("is_nat", "ISNAT") ;
("amount" , "AMOUNT") ;
("balance", "BALANCE") ;
("now" , "NOW") ;
("unit" , "UNIT") ;
("source" , "SOURCE") ;
("sender" , "SENDER") ;
("address", "ADDRESS") ;
("self_address", "SELF_ADDRESS") ;
("implicit_account", "IMPLICIT_ACCOUNT") ;
("failwith" , "FAILWITH") ;
("bitwise_or" , "OR") ;
("bitwise_and" , "AND") ;
("bitwise_xor" , "XOR") ;
("string_concat" , "CONCAT") ;
("string_slice" , "SLICE") ;
("crypto_check", "CHECK_SIGNATURE") ;
("crypto_hash_key", "HASH_KEY") ;
("bytes_concat" , "CONCAT") ;
("bytes_slice" , "SLICE") ;
("bytes_pack" , "PACK") ;
("set_empty" , "SET_EMPTY") ;
("set_mem" , "SET_MEM") ;
("set_add" , "SET_ADD") ;
("set_remove" , "SET_REMOVE") ;
("set_iter" , "SET_ITER") ;
("set_fold" , "SET_FOLD") ;
("list_iter" , "LIST_ITER") ;
("list_fold" , "LIST_FOLD") ;
("list_map" , "LIST_MAP") ;
("map_iter" , "MAP_ITER") ;
("map_map" , "MAP_MAP") ;
("map_fold" , "MAP_FOLD") ;
("map_remove" , "MAP_REMOVE") ;
("map_update" , "MAP_UPDATE") ;
("map_get" , "MAP_GET") ;
("sha_256" , "SHA256") ;
("sha_512" , "SHA512") ;
("blake2b" , "BLAKE2b") ;
("cons" , "CONS") ;
]
let constants = function
| "get_force" -> ok C_MAP_GET_FORCE
| "get_chain_id" -> ok C_CHAIN_ID
| "transaction" -> ok C_CALL
| "get_contract" -> ok C_CONTRACT
| "get_entrypoint" -> ok C_CONTRACT_ENTRYPOINT
| "size" -> ok C_SIZE
| "int" -> ok C_INT
| "abs" -> ok C_ABS
| "is_nat" -> ok C_IS_NAT
| "amount" -> ok C_AMOUNT
| "balance" -> ok C_BALANCE
| "now" -> ok C_NOW
| "unit" -> ok C_UNIT
| "source" -> ok C_SOURCE
| "sender" -> ok C_SENDER
| "failwith" -> ok C_FAILWITH
| "bitwise_or" -> ok C_OR
| "bitwise_and" -> ok C_AND
| "bitwise_xor" -> ok C_XOR
| "string_concat" -> ok C_CONCAT
| "string_slice" -> ok C_SLICE
| "crypto_check" -> ok C_CHECK_SIGNATURE
| "crypto_hash_key" -> ok C_HASH_KEY
| "bytes_concat" -> ok C_CONCAT
| "bytes_slice" -> ok C_SLICE
| "bytes_pack" -> ok C_BYTES_PACK
| "set_empty" -> ok C_SET_EMPTY
| "set_mem" -> ok C_SET_MEM
| "set_add" -> ok C_SET_ADD
| "set_remove" -> ok C_SET_REMOVE
| "set_iter" -> ok C_SET_ITER
| "set_fold" -> ok C_SET_FOLD
| "list_iter" -> ok C_LIST_ITER
| "list_fold" -> ok C_LIST_FOLD
| "list_map" -> ok C_LIST_MAP
| "map_iter" -> ok C_MAP_ITER
| "map_map" -> ok C_MAP_MAP
| "map_fold" -> ok C_MAP_FOLD
| "map_remove" -> ok C_MAP_REMOVE
| "map_update" -> ok C_MAP_UPDATE
| "map_get" -> ok C_MAP_GET
| "sha_256" -> ok C_SHA256
| "sha_512" -> ok C_SHA512
| "blake2b" -> ok C_BLAKE2b
| "cons" -> ok C_CONS
| "EQ" -> ok C_EQ
| "NEQ" -> ok C_NEQ
| "NEG" -> ok C_NEG
| "ADD" -> ok C_ADD
| "SUB" -> ok C_SUB
| "TIMES" -> ok C_MUL
| "DIV" -> ok C_DIV
| "MOD" -> ok C_MOD
| "NOT" -> ok C_NOT
| "AND" -> ok C_AND
| "OR" -> ok C_OR
| "GT" -> ok C_GT
| "GE" -> ok C_GE
| "LT" -> ok C_LT
| "LE" -> ok C_LE
| "CONS" -> ok C_CONS
| "address" -> ok C_ADDRESS
| "self_address" -> ok C_SELF_ADDRESS
| "implicit_account"-> ok C_IMPLICIT_ACCOUNT
| _ -> simple_fail "Not a PascaLIGO constant"
let type_constants = type_constants
let type_operators = type_operators
end
module Camligo = struct
let constants = [
("Bytes.pack" , "PACK") ;
("Crypto.hash" , "HASH") ;
("Operation.transaction" , "CALL") ;
("Operation.get_contract" , "CONTRACT") ;
("sender" , "SENDER") ;
("unit" , "UNIT") ;
("source" , "SOURCE") ;
]
let constants = function
| "Bytes.pack" -> ok C_BYTES_PACK
| "Crypto.hash" -> ok C_HASH (* TODO : Check if right *)
| "Operation.transaction" -> ok C_CALL
| "Operation.get_contract" -> ok C_CONTRACT
| "sender" -> ok C_SENDER
| "unit" -> ok C_UNIT
| "source" -> ok C_SOURCE
| _ -> simple_fail "Not a CamLIGO constant"
let type_constants = type_constants
let type_operators = type_operators
end
module Ligodity = struct
let constants = [
("assert" , "ASSERT") ;
let constants = function
| "assert" -> ok C_ASSERTION
| "Current.balance" -> ok C_BALANCE
| "balance" -> ok C_BALANCE
| "Current.time" -> ok C_NOW
| "time" -> ok C_NOW
| "Current.amount" -> ok C_AMOUNT
| "amount" -> ok C_AMOUNT
| "Current.gas" -> ok C_STEPS_TO_QUOTA
| "gas" -> ok C_STEPS_TO_QUOTA
| "Current.sender" -> ok C_SENDER
| "Current.address" -> ok C_ADDRESS
| "Current.self_address" -> ok C_SELF_ADDRESS
| "Current.implicit_account" -> ok C_IMPLICIT_ACCOUNT
| "sender" -> ok C_SENDER
| "Current.source" -> ok C_SOURCE
| "source" -> ok C_SOURCE
| "Current.failwith" -> ok C_FAILWITH
| "failwith" -> ok C_FAILWITH
("Current.balance", "BALANCE") ;
("balance", "BALANCE") ;
("Current.time", "NOW") ;
("time", "NOW") ;
("Current.amount" , "AMOUNT") ;
("amount", "AMOUNT") ;
("Current.gas", "STEPS_TO_QUOTA") ;
("gas", "STEPS_TO_QUOTA") ;
("Current.sender" , "SENDER") ;
("sender", "SENDER") ;
("Current.address", "ADDRESS") ;
("Current.self_address", "SELF_ADDRESS") ;
("Current.implicit_account", "IMPLICIT_ACCOUNT") ;
("Current.source" , "SOURCE") ;
("source", "SOURCE") ;
("Current.failwith", "FAILWITH") ;
("failwith" , "FAILWITH") ;
| "Crypto.hash" -> ok C_HASH
| "Crypto.black2b" -> ok C_BLAKE2b
| "Crypto.sha256" -> ok C_SHA256
| "Crypto.sha512" -> ok C_SHA512
| "Crypto.hash_key" -> ok C_HASH_KEY
| "Crypto.check" -> ok C_CHECK_SIGNATURE
("Crypto.hash" , "HASH") ;
("Crypto.black2b", "BLAKE2B") ;
("Crypto.sha256", "SHA256") ;
("Crypto.sha512", "SHA512") ;
("Crypto.hash_key", "HASH_KEY") ;
("Crypto.check", "CHECK_SIGNATURE") ;
| "Bytes.pack" -> ok C_BYTES_PACK
| "Bytes.unpack" -> ok C_BYTES_UNPACK
| "Bytes.length" -> ok C_SIZE
| "Bytes.size" -> ok C_SIZE
| "Bytes.concat" -> ok C_CONCAT
| "Bytes.slice" -> ok C_SLICE
| "Bytes.sub" -> ok C_SLICE
("Bytes.pack" , "PACK") ;
("Bytes.unpack", "UNPACK") ;
("Bytes.length", "SIZE") ;
("Bytes.size" , "SIZE") ;
("Bytes.concat", "CONCAT") ;
("Bytes.slice", "SLICE") ;
("Bytes.sub", "SLICE") ;
| "Set.mem" -> ok C_SET_MEM
| "Set.empty" -> ok C_SET_EMPTY
| "Set.literal" -> ok C_SET_LITERAL
| "Set.add" -> ok C_SET_ADD
| "Set.remove" -> ok C_SET_REMOVE
| "Set.fold" -> ok C_SET_FOLD
| "Set.size" -> ok C_SIZE
("Set.mem" , "SET_MEM") ;
("Set.empty" , "SET_EMPTY") ;
("Set.literal" , "SET_LITERAL") ;
("Set.add" , "SET_ADD") ;
("Set.remove" , "SET_REMOVE") ;
("Set.fold" , "SET_FOLD") ;
("Set.size", "SIZE") ;
| "Map.find_opt" -> ok C_MAP_FIND_OPT
| "Map.find" -> ok C_MAP_FIND
| "Map.update" -> ok C_MAP_UPDATE
| "Map.add" -> ok C_MAP_ADD
| "Map.remove" -> ok C_MAP_REMOVE
| "Map.iter" -> ok C_MAP_ITER
| "Map.map" -> ok C_MAP_MAP
| "Map.fold" -> ok C_MAP_FOLD
| "Map.empty" -> ok C_MAP_EMPTY
| "Map.literal" -> ok C_MAP_LITERAL
| "Map.size" -> ok C_SIZE
("Map.find_opt" , "MAP_FIND_OPT") ;
("Map.find" , "MAP_FIND") ;
("Map.update" , "MAP_UPDATE") ;
("Map.add" , "MAP_ADD") ;
("Map.remove" , "MAP_REMOVE") ;
("Map.iter" , "MAP_ITER") ;
("Map.map" , "MAP_MAP") ;
("Map.fold" , "MAP_FOLD") ;
("Map.empty" , "MAP_EMPTY") ;
("Map.literal" , "MAP_LITERAL" ) ;
("Map.size" , "SIZE" ) ;
| "Big_map.find_opt" -> ok C_MAP_FIND_OPT
| "Big_map.find" -> ok C_MAP_FIND
| "Big_map.update" -> ok C_MAP_UPDATE
| "Big_map.add" -> ok C_MAP_ADD
| "Big_map.remove" -> ok C_MAP_REMOVE
| "Big_map.literal" -> ok C_BIG_MAP_LITERAL
| "Big_map.empty" -> ok C_BIG_MAP_EMPTY
("Big_map.find_opt" , "MAP_FIND_OPT") ;
("Big_map.find" , "MAP_FIND") ;
("Big_map.update" , "MAP_UPDATE") ;
("Big_map.add" , "MAP_ADD") ;
("Big_map.remove" , "MAP_REMOVE") ;
("Big_map.literal" , "BIG_MAP_LITERAL" ) ;
("Big_map.empty" , "BIG_MAP_EMPTY" ) ;
| "Bitwise.lor" -> ok C_OR
| "Bitwise.land" -> ok C_AND
| "Bitwise.lxor" -> ok C_XOR
("Bitwise.lor" , "OR") ;
("Bitwise.land" , "AND") ;
("Bitwise.lxor" , "XOR") ;
| "String.length" -> ok C_SIZE
| "String.size" -> ok C_SIZE
| "String.slice" -> ok C_SLICE
| "String.sub" -> ok C_SLICE
| "String.concat" -> ok C_CONCAT
("String.length", "SIZE") ;
("String.size", "SIZE") ;
("String.slice", "SLICE") ;
("String.sub", "SLICE") ;
("String.concat", "CONCAT") ;
| "List.length" -> ok C_SIZE
| "List.size" -> ok C_SIZE
| "List.iter" -> ok C_LIST_ITER
| "List.map" -> ok C_LIST_MAP
| "List.fold" -> ok C_LIST_FOLD
("List.length", "SIZE") ;
("List.size", "SIZE") ;
("List.iter", "LIST_ITER") ;
("List.map" , "LIST_MAP") ;
("List.fold" , "LIST_FOLD") ;
| "Loop.fold_while" -> ok C_FOLD_WHILE
| "continue" -> ok C_CONTINUE
| "stop" -> ok C_STOP
("Loop.fold_while" , "FOLD_WHILE") ;
("continue" , "CONTINUE") ;
("stop" , "STOP") ;
| "Operation.transaction" -> ok C_CALL
| "Operation.get_contract" -> ok C_CONTRACT
| "Operation.get_entrypoint" -> ok C_CONTRACT_ENTRYPOINT
| "int" -> ok C_INT
| "abs" -> ok C_ABS
| "unit" -> ok C_UNIT
("Operation.transaction" , "CALL") ;
("Operation.get_contract" , "CONTRACT") ;
("Operation.get_entrypoint" , "CONTRACT_ENTRYPOINT") ;
("int" , "INT") ;
("abs" , "ABS") ;
("unit" , "UNIT") ;
("source" , "SOURCE") ;
| "NEG" -> ok C_NEG
| "ADD" -> ok C_ADD
| "SUB" -> ok C_SUB
| "TIMES" -> ok C_MUL
| "DIV" -> ok C_DIV
| "MOD" -> ok C_MOD
| "EQ" -> ok C_EQ
| "NOT" -> ok C_NOT
| "AND" -> ok C_AND
| "OR" -> ok C_OR
| "GT" -> ok C_GT
| "LT" -> ok C_LT
| "LE" -> ok C_LE
| "CONS" -> ok C_CONS
("Michelson.is_nat" , "ISNAT") ;
]
| "Michelson.is_nat" -> ok C_IS_NAT
| _ -> simple_fail "Not a Ligodity constant"
let type_constants = type_constants
let type_operators = type_operators
end
end
@ -295,10 +335,10 @@ module Typer = struct
let t_sender = address
let t_source = address
let t_unit = unit
let t_amount = tez
let t_amount = mutez
let t_address = address
let t_now = timestamp
let t_transaction = forall "a" @@ fun a -> a --> tez --> contract a --> operation
let t_transaction = forall "a" @@ fun a -> a --> mutez --> contract a --> operation
let t_get_contract = forall "a" @@ fun a -> contract a
let t_abs = int --> nat
let t_cons = forall "a" @@ fun a -> a --> list a --> list a
@ -738,80 +778,93 @@ module Typer = struct
let%bind () = assert_eq_1 hd elt in
ok tl
let constant_typers = Map.String.of_list [
add ;
times ;
div ;
mod_ ;
sub ;
none ;
some ;
concat ;
slice ;
comparator "EQ" ;
comparator "NEQ" ;
comparator "LT" ;
comparator "GT" ;
comparator "LE" ;
comparator "GE" ;
or_ ;
and_ ;
xor ;
not_ ;
map_remove ;
map_add ;
map_update ;
map_mem ;
map_find ;
map_find_opt ;
map_map ;
map_fold ;
fold_while ;
continue ;
stop ;
map_iter ;
map_get_force ;
map_get ;
set_empty ;
set_mem ;
set_add ;
set_remove ;
set_iter ;
set_fold ;
list_iter ;
list_map ;
list_fold ;
int ;
size ;
failwith_ ;
bytes_pack ;
bytes_unpack ;
hash256 ;
hash512 ;
blake2b ;
hash_key ;
check_signature ;
sender ;
source ;
chain_id ;
unit ;
balance ;
amount ;
transaction ;
get_contract ;
get_entrypoint ;
neg ;
abs ;
is_nat ;
cons ;
now ;
slice ;
address ;
self_address ;
implicit_account ;
assertion ;
list_cons ;
]
let constant_typers c : typer result = match c with
| C_INT -> ok @@ int ;
| C_UNIT -> ok @@ unit ;
| C_NOW -> ok @@ now ;
| C_IS_NAT -> ok @@ is_nat ;
| C_SOME -> ok @@ some ;
| C_NONE -> ok @@ none ;
| C_ASSERTION -> ok @@ assertion ;
| C_FAILWITH -> ok @@ failwith_ ;
(* LOOPS *)
| C_FOLD_WHILE -> ok @@ fold_while ;
| C_CONTINUE -> ok @@ continue ;
| C_STOP -> ok @@ stop ;
(* MATH *)
| C_NEG -> ok @@ neg ;
| C_ABS -> ok @@ abs ;
| C_ADD -> ok @@ add ;
| C_SUB -> ok @@ sub ;
| C_MUL -> ok @@ times;
| C_DIV -> ok @@ div ;
| C_MOD -> ok @@ mod_ ;
(* LOGIC *)
| C_NOT -> ok @@ not_ ;
| C_AND -> ok @@ and_ ;
| C_OR -> ok @@ or_ ;
| C_XOR -> ok @@ xor ;
(* COMPARATOR *)
| C_EQ -> ok @@ comparator "EQ" ;
| C_NEQ -> ok @@ comparator "NEQ" ;
| C_LT -> ok @@ comparator "LT" ;
| C_GT -> ok @@ comparator "GT" ;
| C_LE -> ok @@ comparator "LE" ;
| C_GE -> ok @@ comparator "GE" ;
(* BYTES / STRING *)
| C_SIZE -> ok @@ size ;
| C_CONCAT -> ok @@ concat ;
| C_SLICE -> ok @@ slice ;
| C_BYTES_PACK -> ok @@ bytes_pack ;
| C_BYTES_UNPACK -> ok @@ bytes_unpack ;
| C_CONS -> ok @@ cons ;
(* SET *)
| C_SET_EMPTY -> ok @@ set_empty ;
| C_SET_ADD -> ok @@ set_add ;
| C_SET_REMOVE -> ok @@ set_remove ;
| C_SET_ITER -> ok @@ set_iter ;
| C_SET_FOLD -> ok @@ set_fold ;
| C_SET_MEM -> ok @@ set_mem ;
(* LIST *)
| C_LIST_ITER -> ok @@ list_iter ;
| C_LIST_MAP -> ok @@ list_map ;
| C_LIST_FOLD -> ok @@ list_fold ;
| C_LIST_CONS -> ok @@ list_cons ;
(* MAP *)
| C_MAP_GET -> ok @@ map_get ;
| C_MAP_GET_FORCE -> ok @@ map_get_force ;
| C_MAP_ADD -> ok @@ map_add ;
| C_MAP_REMOVE -> ok @@ map_remove ;
| C_MAP_UPDATE -> ok @@ map_update ;
| C_MAP_ITER -> ok @@ map_iter ;
| C_MAP_MAP -> ok @@ map_map ;
| C_MAP_FOLD -> ok @@ map_fold ;
| C_MAP_MEM -> ok @@ map_mem ;
| C_MAP_FIND -> ok @@ map_find ;
| C_MAP_FIND_OPT -> ok @@ map_find_opt ;
(* BIG MAP *)
(* CRYPTO *)
| C_SHA256 -> ok @@ hash256 ;
| C_SHA512 -> ok @@ hash512 ;
| C_BLAKE2b -> ok @@ blake2b ;
| C_HASH_KEY -> ok @@ hash_key ;
| C_CHECK_SIGNATURE -> ok @@ check_signature ;
| C_CHAIN_ID -> ok @@ chain_id ;
(*BLOCKCHAIN *)
| C_CONTRACT -> ok @@ get_contract ;
| C_CONTRACT_ENTRYPOINT -> ok @@ get_entrypoint ;
| C_AMOUNT -> ok @@ amount ;
| C_BALANCE -> ok @@ balance ;
| C_CALL -> ok @@ transaction ;
| C_SENDER -> ok @@ sender ;
| C_SOURCE -> ok @@ source ;
| C_ADDRESS -> ok @@ address ;
| C_SELF_ADDRESS -> ok @@ self_address;
| C_IMPLICIT_ACCOUNT -> ok @@ implicit_account;
| _ -> simple_fail @@ Format.asprintf "Typer not implemented for consant %a" Stage_common.PP.constant c
end
@ -832,74 +885,71 @@ module Compiler = struct
include Helpers.Compiler
open Tezos_utils.Michelson
open Mini_c
let get_operators c : predicate result =
match c with
| C_ADD -> ok @@ simple_binary @@ prim I_ADD
| C_SUB -> ok @@ simple_binary @@ prim I_SUB
| C_MUL -> ok @@ simple_binary @@ prim I_MUL
| C_DIV -> ok @@ simple_binary @@ seq [prim I_EDIV ; i_assert_some_msg (i_push_string "DIV by 0") ; i_car]
| C_MOD -> ok @@ simple_binary @@ seq [prim I_EDIV ; i_assert_some_msg (i_push_string "MOD by 0") ; i_cdr]
| C_NEG -> ok @@ simple_unary @@ prim I_NEG
| C_OR -> ok @@ simple_binary @@ prim I_OR
| C_AND -> ok @@ simple_binary @@ prim I_AND
| C_XOR -> ok @@ simple_binary @@ prim I_XOR
| C_NOT -> ok @@ simple_unary @@ prim I_NOT
| C_PAIR -> ok @@ simple_binary @@ prim I_PAIR
| C_CAR -> ok @@ simple_unary @@ prim I_CAR
| C_CDR -> ok @@ simple_unary @@ prim I_CDR
| C_EQ -> ok @@ simple_binary @@ seq [prim I_COMPARE ; prim I_EQ]
| C_NEQ -> ok @@ simple_binary @@ seq [prim I_COMPARE ; prim I_NEQ]
| C_LT -> ok @@ simple_binary @@ seq [prim I_COMPARE ; prim I_LT]
| C_LE -> ok @@ simple_binary @@ seq [prim I_COMPARE ; prim I_LE]
| C_GT -> ok @@ simple_binary @@ seq [prim I_COMPARE ; prim I_GT]
| C_GE -> ok @@ simple_binary @@ seq [prim I_COMPARE ; prim I_GE]
| C_UPDATE -> ok @@ simple_ternary @@ prim I_UPDATE
| C_SOME -> ok @@ simple_unary @@ prim I_SOME
| C_MAP_GET_FORCE -> ok @@ simple_binary @@ seq [prim I_GET ; i_assert_some_msg (i_push_string "GET_FORCE")]
| C_MAP_FIND -> ok @@ simple_binary @@ seq [prim I_GET ; i_assert_some_msg (i_push_string "MAP FIND")]
| C_MAP_GET -> ok @@ simple_binary @@ prim I_GET
| C_MAP_FIND_OPT -> ok @@ simple_binary @@ prim I_GET
| C_MAP_ADD -> ok @@ simple_ternary @@ seq [dip (i_some) ; prim I_UPDATE]
| C_MAP_UPDATE -> ok @@ simple_ternary @@ prim I_UPDATE
| C_FOLD_WHILE -> ok @@ simple_binary @@ seq [i_swap ; (i_push (prim T_bool) (prim D_True));prim ~children:[seq [dip i_dup; i_exec; i_unpair]] I_LOOP ;i_swap ; i_drop]
| C_CONTINUE -> ok @@ simple_unary @@ seq [(i_push (prim T_bool) (prim D_True)); i_pair]
| C_STOP -> ok @@ simple_unary @@ seq [(i_push (prim T_bool) (prim D_False)); i_pair]
| C_SIZE -> ok @@ simple_unary @@ prim I_SIZE
| C_FAILWITH -> ok @@ simple_unary @@ prim I_FAILWITH
| C_ASSERT_INFERRED -> ok @@ simple_binary @@ i_if (seq [i_failwith]) (seq [i_drop ; i_push_unit])
| C_ASSERTION -> ok @@ simple_unary @@ i_if (seq [i_push_unit]) (seq [i_push_unit ; i_failwith])
| C_INT -> ok @@ simple_unary @@ prim I_INT
| C_ABS -> ok @@ simple_unary @@ prim I_ABS
| C_IS_NAT -> ok @@ simple_unary @@ prim I_ISNAT
| C_CONS -> ok @@ simple_binary @@ prim I_CONS
| C_UNIT -> ok @@ simple_constant @@ prim I_UNIT
| C_BALANCE -> ok @@ simple_constant @@ prim I_BALANCE
| C_AMOUNT -> ok @@ simple_constant @@ prim I_AMOUNT
| C_ADDRESS -> ok @@ simple_constant @@ prim I_ADDRESS
| C_SELF_ADDRESS -> ok @@ simple_constant @@ seq [prim I_SELF; prim I_ADDRESS]
| C_NOW -> ok @@ simple_constant @@ prim I_NOW
| C_CALL -> ok @@ simple_ternary @@ prim I_TRANSFER_TOKENS
| C_SOURCE -> ok @@ simple_constant @@ prim I_SOURCE
| C_SENDER -> ok @@ simple_constant @@ prim I_SENDER
| C_SET_MEM -> ok @@ simple_binary @@ prim I_MEM
| C_SET_ADD -> ok @@ simple_binary @@ seq [dip (i_push (prim T_bool) (prim D_True)) ; prim I_UPDATE]
| C_SET_REMOVE -> ok @@ simple_binary @@ seq [dip (i_push (prim T_bool) (prim D_False)) ; prim I_UPDATE]
| C_SLICE -> ok @@ simple_ternary @@ seq [prim I_SLICE ; i_assert_some_msg (i_push_string "SLICE")]
| C_SHA256 -> ok @@ simple_unary @@ prim I_SHA256
| C_SHA512 -> ok @@ simple_unary @@ prim I_SHA512
| C_BLAKE2b -> ok @@ simple_unary @@ prim I_BLAKE2B
| C_CHECK_SIGNATURE -> ok @@ simple_ternary @@ prim I_CHECK_SIGNATURE
| C_HASH_KEY -> ok @@ simple_unary @@ prim I_HASH_KEY
| C_BYTES_PACK -> ok @@ simple_unary @@ prim I_PACK
| C_CONCAT -> ok @@ simple_binary @@ prim I_CONCAT
| C_CHAIN_ID -> ok @@ simple_constant @@ prim I_CHAIN_ID
| _ -> simple_fail @@ Format.asprintf "operator not implemented for %a" Stage_common.PP.constant c
let operators = Map.String.of_list [
("ADD" , simple_binary @@ prim I_ADD) ;
("SUB" , simple_binary @@ prim I_SUB) ;
("TIMES" , simple_binary @@ prim I_MUL) ;
("DIV" , simple_binary @@ seq [prim I_EDIV ; i_assert_some_msg (i_push_string "DIV by 0") ; i_car]) ;
("MOD" , simple_binary @@ seq [prim I_EDIV ; i_assert_some_msg (i_push_string "MOD by 0") ; i_cdr]) ;
("NEG" , simple_unary @@ prim I_NEG) ;
("OR" , simple_binary @@ prim I_OR) ;
("AND" , simple_binary @@ prim I_AND) ;
("XOR" , simple_binary @@ prim I_XOR) ;
("NOT" , simple_unary @@ prim I_NOT) ;
("PAIR" , simple_binary @@ prim I_PAIR) ;
("CAR" , simple_unary @@ prim I_CAR) ;
("CDR" , simple_unary @@ prim I_CDR) ;
("EQ" , simple_binary @@ seq [prim I_COMPARE ; prim I_EQ]) ;
("NEQ" , simple_binary @@ seq [prim I_COMPARE ; prim I_NEQ]) ;
("LT" , simple_binary @@ seq [prim I_COMPARE ; prim I_LT]) ;
("LE" , simple_binary @@ seq [prim I_COMPARE ; prim I_LE]) ;
("GT" , simple_binary @@ seq [prim I_COMPARE ; prim I_GT]) ;
("GE" , simple_binary @@ seq [prim I_COMPARE ; prim I_GE]) ;
("UPDATE" , simple_ternary @@ prim I_UPDATE) ;
("SOME" , simple_unary @@ prim I_SOME) ;
("MAP_GET_FORCE" , simple_binary @@ seq [prim I_GET ; i_assert_some_msg (i_push_string "GET_FORCE")]) ;
("MAP_FIND" , simple_binary @@ seq [prim I_GET ; i_assert_some_msg (i_push_string "MAP FIND")]) ;
("MAP_GET" , simple_binary @@ prim I_GET) ;
("MAP_FIND_OPT" , simple_binary @@ prim I_GET) ;
("MAP_ADD" , simple_ternary @@ seq [dip (i_some) ; prim I_UPDATE]) ;
("MAP_UPDATE" , simple_ternary @@ prim I_UPDATE) ;
("FOLD_WHILE" , simple_binary @@ seq [i_swap ; (i_push (prim T_bool) (prim D_True)) ;
prim ~children:[seq [dip i_dup; i_exec; i_unpair]] I_LOOP ;
i_swap ; i_drop]) ;
("CONTINUE" , simple_unary @@ seq [(i_push (prim T_bool) (prim D_True)) ;
i_pair]) ;
("STOP" , simple_unary @@ seq [(i_push (prim T_bool) (prim D_False)) ;
i_pair]) ;
("SIZE" , simple_unary @@ prim I_SIZE) ;
("FAILWITH" , simple_unary @@ prim I_FAILWITH) ;
("ASSERT_INFERRED" , simple_binary @@ i_if (seq [i_failwith]) (seq [i_drop ; i_push_unit])) ;
("ASSERT" , simple_unary @@ i_if (seq [i_push_unit]) (seq [i_push_unit ; i_failwith])) ;
("INT" , simple_unary @@ prim I_INT) ;
("ABS" , simple_unary @@ prim I_ABS) ;
("ISNAT", simple_unary @@ prim I_ISNAT) ;
("CONS" , simple_binary @@ prim I_CONS) ;
("UNIT" , simple_constant @@ prim I_UNIT) ;
("BALANCE" , simple_constant @@ prim I_BALANCE) ;
("AMOUNT" , simple_constant @@ prim I_AMOUNT) ;
("ADDRESS" , simple_unary @@ prim I_ADDRESS) ;
("SELF_ADDRESS", simple_constant @@ (seq [prim I_SELF ; prim I_ADDRESS])) ;
("IMPLICIT_ACCOUNT", simple_unary @@ prim I_IMPLICIT_ACCOUNT) ;
("NOW" , simple_constant @@ prim I_NOW) ;
("CALL" , simple_ternary @@ prim I_TRANSFER_TOKENS) ;
("SOURCE" , simple_constant @@ prim I_SOURCE) ;
("SENDER" , simple_constant @@ prim I_SENDER) ;
("SET_MEM" , simple_binary @@ prim I_MEM) ;
("SET_ADD" , simple_binary @@ seq [dip (i_push (prim T_bool) (prim D_True)) ; prim I_UPDATE]) ;
("SET_REMOVE" , simple_binary @@ seq [dip (i_push (prim T_bool) (prim D_False)) ; prim I_UPDATE]) ;
("SLICE" , simple_ternary @@ seq [prim I_SLICE ; i_assert_some_msg (i_push_string "SLICE")]) ;
("SHA256" , simple_unary @@ prim I_SHA256) ;
("SHA512" , simple_unary @@ prim I_SHA512) ;
("BLAKE2B" , simple_unary @@ prim I_BLAKE2B) ;
("CHECK_SIGNATURE" , simple_ternary @@ prim I_CHECK_SIGNATURE) ;
("HASH_KEY" , simple_unary @@ prim I_HASH_KEY) ;
("PACK" , simple_unary @@ prim I_PACK) ;
("CONCAT" , simple_binary @@ prim I_CONCAT) ;
("CONS" , simple_binary @@ prim I_CONS) ;
("CHAIN_ID", simple_constant @@ prim I_CHAIN_ID ) ;
]
(*
Some complex operators will need to be added in compiler/compiler_program.

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

@ -1,19 +1,24 @@
module Simplify : sig
open Ast_simplified
open Trace
module Pascaligo : sig
val constants : ( string * string ) list
val type_constants : ( string * string ) list
val constants : string -> constant result
val type_constants : string -> type_constant result
val type_operators : string -> type_expression type_operator result
end
module Camligo : sig
val constants : ( string * string ) list
val type_constants : ( string * string ) list
val constants : string -> constant result
val type_constants : string -> type_constant result
val type_operators : string -> type_expression type_operator result
end
module Ligodity : sig
val constants : ( string * string ) list
val type_constants : ( string * string ) list
val constants : string -> constant result
val type_constants : string -> type_constant result
val type_operators : string -> type_expression type_operator result
end
end
@ -21,6 +26,7 @@ end
module Typer : sig
open Helpers.Typer
open Ast_typed
open Trace
module Operators_types : sig
(* TODO: we need a map from type names to type values. Then, all
@ -169,7 +175,7 @@ module Typer : sig
val concat : typer
*)
val cons : typer
val constant_typers : typer' type_name_map
val constant_typers : constant -> typer result
end
@ -178,6 +184,8 @@ module Compiler : sig
include Helpers.Compiler
*)
open Tezos_utils.Michelson
open Mini_c
open Trace
type predicate =
| Constant of michelson
@ -187,7 +195,7 @@ module Compiler : sig
| Tetrary of michelson
| Pentary of michelson
| Hexary of michelson
val operators : predicate Map.String.t
val get_operators : constant -> predicate result
val simple_constant : t -> predicate
val simple_unary : t -> predicate
val simple_binary : t -> predicate

84
src/stages/ast_simplified/PP.ml
View File

@ -1,49 +1,27 @@
open Types
open PP_helpers
open Format
include Stage_common.PP
let list_sep_d x ppf lst = match lst with
| [] -> ()
| _ -> fprintf ppf "@; @[<v>%a@]@;" (list_sep x (tag "@;")) lst
let smap_sep_d x ppf m =
if Map.String.is_empty m
then ()
else fprintf ppf "@; @[<v>%a@]@;" (smap_sep x (tag "@;")) m
let rec te' ppf (te : type_expression type_expression') : unit =
type_expression' type_expression ppf te
let rec type_expression ppf (te:type_expression) = match te with
| T_tuple lst -> fprintf ppf "tuple[%a]" (list_sep_d type_expression) lst
| T_sum m -> fprintf ppf "sum[%a]" (smap_sep_d type_expression) m
| T_record m -> fprintf ppf "record[%a]" (smap_sep_d type_expression) m
| T_function (p, r) -> fprintf ppf "%a -> %a" type_expression p type_expression r
| T_variable name -> fprintf ppf "%s" name
| T_constant (name, lst) -> fprintf ppf "%s(%a)" name (list_sep_d type_expression) lst
let literal ppf (l:literal) = match l with
| Literal_unit -> fprintf ppf "Unit"
| Literal_bool b -> fprintf ppf "%b" b
| Literal_int n -> fprintf ppf "%d" n
| Literal_nat n -> fprintf ppf "+%d" n
| Literal_timestamp n -> fprintf ppf "+%d" n
| Literal_mutez n -> fprintf ppf "%dmutez" n
| Literal_string s -> fprintf ppf "%S" s
| Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b
| Literal_address s -> fprintf ppf "@%S" s
| Literal_signature s -> fprintf ppf "@%S" s
| Literal_key s -> fprintf ppf "@%S" s
| Literal_key_hash s -> fprintf ppf "@%S" s
| Literal_chain_id s -> fprintf ppf "@%S" s
| Literal_operation _ -> fprintf ppf "Operation(...bytes)"
and type_expression ppf (te: type_expression) : unit =
te' ppf te.type_expression'
let rec expression ppf (e:expression) = match e.expression with
| E_literal l -> literal ppf l
| E_variable name -> fprintf ppf "%s" name
| E_variable n -> fprintf ppf "%a" name n
| E_application (f, arg) -> fprintf ppf "(%a)@(%a)" expression f expression arg
| E_constructor (name, ae) -> fprintf ppf "%s(%a)" name expression ae
| E_constant (name, lst) -> fprintf ppf "%s(%a)" name (list_sep_d expression) lst
| E_constructor (c, ae) -> fprintf ppf "%a(%a)" constructor c expression ae
| E_constant (b, lst) -> fprintf ppf "%a(%a)" constant b (list_sep_d expression) lst
| E_tuple lst -> fprintf ppf "tuple[%a]" (list_sep_d expression) lst
| E_accessor (ae, p) -> fprintf ppf "%a.%a" expression ae access_path p
| E_record m -> fprintf ppf "record[%a]" (smap_sep_d expression) m
| E_record m -> fprintf ppf "record[%a]" (lmap_sep expression (const " , ")) m
| E_map m -> fprintf ppf "map[%a]" (list_sep_d assoc_expression) m
| E_big_map m -> fprintf ppf "big_map[%a]" (list_sep_d assoc_expression) m
| E_list lst -> fprintf ppf "list[%a]" (list_sep_d expression) lst
@ -64,28 +42,28 @@ let rec expression ppf (e:expression) = match e.expression with
fprintf ppf "%a ; %a"
expression expr
expression body
| E_assign (name , path , expr) ->
fprintf ppf "%s.%a := %a"
name
| E_assign (n , path , expr) ->
fprintf ppf "%a.%a := %a"
name n
PP_helpers.(list_sep access (const ".")) path
expression expr
| E_let_in { binder ; rhs ; result } ->
fprintf ppf "let %a = %a in %a" option_type_name binder expression rhs expression result
| E_skip -> fprintf ppf "skip"
| E_annotation (expr , ty) -> fprintf ppf "%a : %a" expression expr type_expression ty
| E_ascription (expr , ty) -> fprintf ppf "%a : %a" expression expr type_expression ty
and option_type_name ppf ((name , ty_opt) : string * type_expression option) =
and option_type_name ppf ((n , ty_opt) : expression_variable * type_expression option) =
match ty_opt with
| None -> fprintf ppf "%s" name
| Some ty -> fprintf ppf "%s : %a" name type_expression ty
| None -> fprintf ppf "%a" name n
| Some ty -> fprintf ppf "%a : %a" name n type_expression ty
and assoc_expression ppf : (expr * expr) -> unit = fun (a, b) ->
fprintf ppf "%a -> %a" expression a expression b
and access ppf (a:access) =
match a with
| Access_tuple n -> fprintf ppf "%d" n
| Access_record s -> fprintf ppf "%s" s
| Access_tuple i -> fprintf ppf "%d" i
| Access_record l -> fprintf ppf "%s" l
and access_path ppf (p:access_path) =
fprintf ppf "%a" (list_sep access (const ".")) p
@ -100,28 +78,28 @@ and single_record_patch ppf ((p, expr) : string * expr) =
and single_tuple_patch ppf ((p, expr) : int * expr) =
fprintf ppf "%d <- %a" p expression expr
and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor_name * name) * a -> unit =
and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor * expression_variable) * a -> unit =
fun f ppf ((c,n),a) ->
fprintf ppf "| %s %s -> %a" c n f a
fprintf ppf "| %a %a -> %a" constructor c name n f a
and matching : type a . (formatter -> a -> unit) -> formatter -> a matching -> unit =
and matching : type a . (formatter -> a -> unit) -> formatter -> (a,unit) matching -> unit =
fun f ppf m -> match m with
| Match_tuple (lst, b) ->
fprintf ppf "let (%a) = %a" (list_sep_d string) lst f b
| Match_variant lst ->
| Match_tuple ((lst, b), _) ->
fprintf ppf "let (%a) = %a" (list_sep_d name) lst f b
| Match_variant (lst, _) ->
fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst
| Match_bool {match_true ; match_false} ->
fprintf ppf "| True -> %a @.| False -> %a" f match_true f match_false
| Match_list {match_nil ; match_cons = (hd, tl, match_cons)} ->
fprintf ppf "| Nil -> %a @.| %s :: %s -> %a" f match_nil hd tl f match_cons
| Match_option {match_none ; match_some = (some, match_some)} ->
fprintf ppf "| None -> %a @.| Some %s -> %a" f match_none some f match_some
| Match_list {match_nil ; match_cons = (hd, tl, match_cons, _)} ->
fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil name hd name tl f match_cons
| Match_option {match_none ; match_some = (some, match_some, _)} ->
fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none name some f match_some
(* Shows the type expected for the matched value *)
and matching_type ppf m = match m with
| Match_tuple _ ->
fprintf ppf "tuple"
| Match_variant lst ->
| Match_variant (lst, _) ->
fprintf ppf "variant %a" (list_sep matching_variant_case_type (tag "@.")) lst
| Match_bool _ ->
fprintf ppf "boolean"
@ -131,11 +109,11 @@ and matching_type ppf m = match m with
fprintf ppf "option"
and matching_variant_case_type ppf ((c,n),_a) =
fprintf ppf "| %s %s" c n
fprintf ppf "| %a %a" constructor c name n
let declaration ppf (d:declaration) = match d with
| Declaration_type (type_name , te) ->
fprintf ppf "type %s = %a" type_name type_expression te
fprintf ppf "type %a = %a" type_variable (type_name) type_expression te
| Declaration_constant (name , ty_opt , expr) ->
fprintf ppf "const %a = %a" option_type_name (name , ty_opt) expression expr

2
src/stages/ast_simplified/PP.mli
View File

@ -35,7 +35,7 @@ val matching : (formatter -> 'a -> unit) -> formatter -> 'a matching -> unit
*)
(** Shows the type expected for the matched value *)
val matching_type : formatter -> 'a matching -> unit
val matching_type : formatter -> ('a, 'var) matching -> unit
(*
val matching_variant_case_type : formatter -> ( ( constructor_name * name) * 'a) -> unit

122
src/stages/ast_simplified/combinators.ml
View File

@ -15,47 +15,62 @@ module Errors = struct
end
open Errors
let t_bool : type_expression = T_constant ("bool", [])
let t_string : type_expression = T_constant ("string", [])
let t_bytes : type_expression = T_constant ("bytes", [])
let t_int : type_expression = T_constant ("int", [])
let t_operation : type_expression = T_constant ("operation", [])
let t_nat : type_expression = T_constant ("nat", [])
let t_tez : type_expression = T_constant ("tez", [])
let t_unit : type_expression = T_constant ("unit", [])
let t_address : type_expression = T_constant ("address", [])
let t_signature : type_expression = T_constant ("signature", [])
let t_key : type_expression = T_constant ("key", [])
let t_key_hash : type_expression = T_constant ("key_hash", [])
let t_option o : type_expression = T_constant ("option", [o])
let t_list t : type_expression = T_constant ("list", [t])
let t_variable n : type_expression = T_variable n
let t_tuple lst : type_expression = T_tuple lst
let t_pair (a , b) = t_tuple [a ; b]
let t_record m : type_expression = (T_record m)
let make_t type_expression' = {type_expression'}
let t_bool : type_expression = make_t @@ T_constant (TC_bool)
let t_string : type_expression = make_t @@ T_constant (TC_string)
let t_bytes : type_expression = make_t @@ T_constant (TC_bytes)
let t_int : type_expression = make_t @@ T_constant (TC_int)
let t_operation : type_expression = make_t @@ T_constant (TC_operation)
let t_nat : type_expression = make_t @@ T_constant (TC_nat)
let t_tez : type_expression = make_t @@ T_constant (TC_mutez)
let t_unit : type_expression = make_t @@ T_constant (TC_unit)
let t_address : type_expression = make_t @@ T_constant (TC_address)
let t_signature : type_expression = make_t @@ T_constant (TC_signature)
let t_key : type_expression = make_t @@ T_constant (TC_key)
let t_key_hash : type_expression = make_t @@ T_constant (TC_key_hash)
let t_option o : type_expression = make_t @@ T_operator (TC_option o)
let t_list t : type_expression = make_t @@ T_operator (TC_list t)
let t_variable n : type_expression = make_t @@ T_variable (Var.of_name n)
let t_tuple lst : type_expression = make_t @@ T_tuple lst
let t_pair (a , b) : type_expression = t_tuple [a ; b]
let t_record_ez lst =
let m = SMap.of_list lst in
t_record m
let lst = List.map (fun (k, v) -> (Label k, v)) lst in
let m = LMap.of_list lst in
make_t @@ T_record m
let t_record m : type_expression =
let lst = Map.String.to_kv_list m in
t_record_ez lst
let t_sum m : type_expression = T_sum m
let ez_t_sum (lst:(string * type_expression) list) : type_expression =
let aux prev (k, v) = SMap.add k v prev in
let map = List.fold_left aux SMap.empty lst in
T_sum map
let aux prev (k, v) = CMap.add (Constructor k) v prev in
let map = List.fold_left aux CMap.empty lst in
make_t @@ T_sum map
let t_sum m : type_expression =
let lst = Map.String.to_kv_list m in
ez_t_sum lst
let t_function param result : type_expression = T_function (param, result)
let t_map key value = (T_constant ("map", [key ; value]))
let t_big_map key value = (T_constant ("big_map", [key ; value]))
let t_set key = (T_constant ("set", [key]))
let t_function param result : type_expression = make_t @@ T_arrow (param, result)
let t_map key value : type_expression = make_t @@ T_operator (TC_map (key, value))
let t_big_map key value : type_expression = make_t @@ T_operator (TC_big_map (key , value))
let t_set key : type_expression = make_t @@ T_operator (TC_set key)
let t_contract contract : type_expression = make_t @@ T_operator (TC_contract contract)
let make_name (s : string) : name = s
(* TODO find a better way than using list*)
let t_operator op lst: type_expression =
match op with
| TC_set _ -> t_set (List.hd lst)
| TC_list _ -> t_list (List.hd lst)
| TC_option _ -> t_option (List.hd lst)
| TC_map (_,_) -> let tl = List.tl lst in t_map (List.hd lst) (List.hd tl)
| TC_big_map (_,_) -> let tl = List.tl lst in t_big_map (List.hd lst) (List.hd tl)
| TC_contract _ -> t_contract (List.hd lst)
let location_wrap ?(loc = Location.generated) expression =
let location = loc in
{ location ; expression }
let e_var ?loc (s : string) : expression = location_wrap ?loc @@ E_variable s
let e_var ?loc (n: string) : expression = location_wrap ?loc @@ E_variable (Var.of_name n)
let e_literal ?loc l : expression = location_wrap ?loc @@ E_literal l
let e_unit ?loc () : expression = location_wrap ?loc @@ E_literal (Literal_unit)
let e_int ?loc n : expression = location_wrap ?loc @@ E_literal (Literal_int n)
@ -80,15 +95,15 @@ let e_bytes_ofbytes ?loc (b: bytes) : expression =
let e_big_map ?loc lst : expression = location_wrap ?loc @@ E_big_map lst
let e_record ?loc map : expression = location_wrap ?loc @@ E_record map
let e_tuple ?loc lst : expression = location_wrap ?loc @@ E_tuple lst
let e_some ?loc s : expression = location_wrap ?loc @@ E_constant ("SOME", [s])
let e_none ?loc () : expression = location_wrap ?loc @@ E_constant ("NONE", [])
let e_string_cat ?loc sl sr : expression = location_wrap ?loc @@ E_constant ("CONCAT" , [sl ; sr ])
let e_map_add ?loc k v old : expression = location_wrap ?loc @@ E_constant ("MAP_ADD" , [k ; v ; old])
let e_some ?loc s : expression = location_wrap ?loc @@ E_constant (C_SOME, [s])
let e_none ?loc () : expression = location_wrap ?loc @@ E_constant (C_NONE, [])
let e_string_cat ?loc sl sr : expression = location_wrap ?loc @@ E_constant (C_CONCAT, [sl ; sr ])
let e_map_add ?loc k v old : expression = location_wrap ?loc @@ E_constant (C_MAP_ADD, [k ; v ; old])
let e_map ?loc lst : expression = location_wrap ?loc @@ E_map lst
let e_set ?loc lst : expression = location_wrap ?loc @@ E_set lst
let e_list ?loc lst : expression = location_wrap ?loc @@ E_list lst
let e_pair ?loc a b : expression = location_wrap ?loc @@ E_tuple [a; b]
let e_constructor ?loc s a : expression = location_wrap ?loc @@ E_constructor (s , a)
let e_constructor ?loc s a : expression = location_wrap ?loc @@ E_constructor (Constructor s , a)
let e_matching ?loc a b : expression = location_wrap ?loc @@ E_matching (a , b)
let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c})
let e_accessor ?loc a b = location_wrap ?loc @@ E_accessor (a , b)
@ -97,13 +112,18 @@ let e_variable ?loc v = location_wrap ?loc @@ E_variable v
let e_skip ?loc () = location_wrap ?loc @@ E_skip
let e_loop ?loc cond body = location_wrap ?loc @@ E_loop (cond , body)
let e_sequence ?loc a b = location_wrap ?loc @@ E_sequence (a , b)
let e_let_in ?loc binder rhs result = location_wrap ?loc @@ E_let_in { binder ; rhs ; result }
let e_annotation ?loc expr ty = location_wrap ?loc @@ E_annotation (expr , ty)
let e_let_in ?loc (binder, ascr) rhs result = location_wrap ?loc @@ E_let_in { binder = (binder, ascr) ; rhs ; result }
let e_annotation ?loc expr ty = location_wrap ?loc @@ E_ascription (expr , ty)
let e_application ?loc a b = location_wrap ?loc @@ E_application (a , b)
let e_binop ?loc name a b = location_wrap ?loc @@ E_constant (name , [a ; b])
let e_binop ?loc name a b = location_wrap ?loc @@ E_constant (name , [a ; b])
let e_constant ?loc name lst = location_wrap ?loc @@ E_constant (name , lst)
let e_look_up ?loc x y = location_wrap ?loc @@ E_look_up (x , y)
let e_assign ?loc a b c = location_wrap ?loc @@ E_assign (a , b , c)
let e_assign ?loc a b c = location_wrap ?loc @@ E_assign (Var.of_name a , b , c)
let ez_match_variant (lst : ((string * string) * 'a) list) =
let lst = List.map (fun ((c,n),a) -> ((Constructor c, Var.of_name n), a) ) lst in
Match_variant (lst,())
let e_matching_variant ?loc a (lst : ((string * string)* 'a) list) =
e_matching ?loc a (ez_match_variant lst)
let make_option_typed ?loc e t_opt =
match t_opt with
@ -111,9 +131,10 @@ let make_option_typed ?loc e t_opt =
| Some t -> e_annotation ?loc e t
let ez_e_record ?loc lst =
let aux prev (k, v) = SMap.add k v prev in
let map = List.fold_left aux SMap.empty lst in
let ez_e_record ?loc (lst : (string * expr) list) =
let aux prev (k, v) = LMap.add k v prev in
let lst = List.map (fun (k,v) -> (Label k, v)) lst in
let map = List.fold_left aux LMap.empty lst in
e_record ?loc map
let e_typed_none ?loc t_opt =
@ -128,23 +149,24 @@ let e_typed_big_map ?loc lst k v = e_annotation ?loc (e_big_map lst) (t_big_map
let e_typed_set ?loc lst k = e_annotation ?loc (e_set lst) (t_set k)
let e_lambda ?loc (binder : string)
let e_lambda ?loc (binder : expression_variable)
(input_type : type_expression option)
(output_type : type_expression option)
(result : expression)
: expression =
location_wrap ?loc @@ E_lambda {
binder = (make_name binder , input_type) ;
binder = (binder , input_type) ;
input_type = input_type ;
output_type = output_type ;
result ;
}
let e_record ?loc map = location_wrap ?loc @@ E_record map
let e_ez_record ?loc (lst : (string * expr) list) : expression =
let map = SMap.of_list lst in
e_record ?loc map
let map = List.fold_left (fun m (x, y) -> LMap.add (Label x) y m) LMap.empty lst in
location_wrap ?loc @@ E_record map
let e_record ?loc map =
let lst = Map.String.to_kv_list map in
e_ez_record ?loc lst
let get_e_accessor = fun t ->
match t with
@ -185,9 +207,9 @@ let extract_list : expression -> (expression list) result = fun e ->
| E_list lst -> ok lst
| _ -> fail @@ bad_kind "list" e.location
let extract_record : expression -> (string * expression) list result = fun e ->
let extract_record : expression -> (label * expression) list result = fun e ->
match e.expression with
| E_record lst -> ok @@ SMap.to_kv_list lst
| E_record lst -> ok @@ LMap.to_kv_list lst
| _ -> fail @@ bad_kind "record" e.location
let extract_map : expression -> (expression * expression) list result = fun e ->

34
src/stages/ast_simplified/combinators.mli
View File

@ -9,6 +9,7 @@ module Errors : sig
val bad_kind : name -> Location.t -> unit -> error
end
*)
val make_t : type_expression type_expression' -> type_expression
val t_bool : type_expression
val t_string : type_expression
val t_bytes : type_expression
@ -25,26 +26,25 @@ val t_signature : type_expression
val t_option : type_expression -> type_expression
*)
val t_list : type_expression -> type_expression
val t_variable : type_name -> type_expression
val t_variable : string -> type_expression
(*
val t_tuple : type_expression list -> type_expression
val t_record : te_map -> type_expression
*)
val t_pair : ( type_expression * type_expression ) -> type_expression
val t_record : type_expression Map.String.t -> type_expression
val t_record_ez : (string * type_expression) list -> type_expression
val t_sum : te_map -> type_expression
val t_sum : type_expression Map.String.t -> type_expression
val ez_t_sum : ( string * type_expression ) list -> type_expression
val t_function : type_expression -> type_expression -> type_expression
val t_map : type_expression -> type_expression -> type_expression
val t_operator : 'a type_operator -> type_expression list -> type_expression
val t_set : type_expression -> type_expression
(*
val make_name : string -> name
*)
val e_var : ?loc:Location.t -> string -> expression
val e_literal : ?loc:Location.t -> literal -> expression
val e_unit : ?loc:Location.t -> unit -> expression
@ -75,22 +75,24 @@ val e_map : ?loc:Location.t -> ( expression * expression ) list -> expression
val e_set : ?loc:Location.t -> expression list -> expression
val e_list : ?loc:Location.t -> expression list -> expression
val e_pair : ?loc:Location.t -> expression -> expression -> expression
val e_constructor : ?loc:Location.t -> name -> expression -> expression
val e_constructor : ?loc:Location.t -> string -> expression -> expression
val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression
val e_matching_bool : ?loc:Location.t -> expression -> expression -> expression -> expression
val e_accessor : ?loc:Location.t -> expression -> access_path -> expression
val e_accessor_props : ?loc:Location.t -> expression -> name list -> expression
val e_variable : ?loc:Location.t -> name -> expression
val e_accessor_props : ?loc:Location.t -> expression -> string list -> expression
val e_variable : ?loc:Location.t -> expression_variable -> expression
val e_skip : ?loc:Location.t -> unit -> expression
val e_loop : ?loc:Location.t -> expression -> expression -> expression
val e_sequence : ?loc:Location.t -> expression -> expression -> expression
val e_let_in : ?loc:Location.t -> ( name * type_expression option ) -> expression -> expression -> expression
val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> expression -> expression -> expression
val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression
val e_application : ?loc:Location.t -> expression -> expression -> expression
val e_binop : ?loc:Location.t -> name -> expression -> expression -> expression
val e_constant : ?loc:Location.t -> name -> expression list -> expression
val e_binop : ?loc:Location.t -> constant -> expression -> expression -> expression
val e_constant : ?loc:Location.t -> constant -> expression list -> expression
val e_look_up : ?loc:Location.t -> expression -> expression -> expression
val e_assign : ?loc:Location.t -> name -> access_path -> expression -> expression
val e_assign : ?loc:Location.t -> string -> access_path -> expression -> expression
val ez_match_variant : ((string * string ) * 'a ) list -> ('a,unit) matching
val e_matching_variant : ?loc:Location.t -> expression -> ((string * string) * expression) list -> expression
val make_option_typed : ?loc:Location.t -> expression -> type_expression option -> expression
val ez_e_record : ?loc:Location.t -> ( string * expression ) list -> expression
@ -104,8 +106,8 @@ val e_typed_big_map : ?loc:Location.t -> ( expression * expression ) list -> ty
val e_typed_set : ?loc:Location.t -> expression list -> type_expression -> expression
val e_lambda : ?loc:Location.t -> string -> type_expression option -> type_expression option -> expression -> expression
val e_record : ?loc:Location.t -> expr_map -> expression
val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option -> type_expression option -> expression -> expression
val e_record : ?loc:Location.t -> expr Map.String.t -> expression
val e_ez_record : ?loc:Location.t -> ( string * expr ) list -> expression
(*
@ -128,6 +130,6 @@ val extract_pair : expression -> ( expression * expression ) result
val extract_list : expression -> (expression list) result
val extract_record : expression -> (string * expression) list result
val extract_record : expression -> (label * expression) list result
val extract_map : expression -> (expression * expression) list result

1
src/stages/ast_simplified/dune
View File

@ -4,6 +4,7 @@
(libraries
simple-utils
tezos-utils
stage_common
)
(preprocess
(pps ppx_let)

6
src/stages/ast_simplified/misc.ml
View File

@ -126,7 +126,7 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
| Some a, Some b -> Some (assert_value_eq (a, b))
| _ -> Some (simple_fail "different record keys")
in
let%bind _all = bind_smap @@ Map.String.merge aux sma smb in
let%bind _all = bind_lmap @@ LMap.merge aux sma smb in
ok ()
)
| E_record _, _ ->
@ -170,8 +170,8 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
| E_set _, _ ->
simple_fail "comparing set with other stuff"
| (E_annotation (a , _) , _b') -> assert_value_eq (a , b)
| (_a' , E_annotation (b , _)) -> assert_value_eq (a , b)
| (E_ascription (a , _) , _b') -> assert_value_eq (a , b)
| (_a' , E_ascription (b , _)) -> assert_value_eq (a , b)
| (E_variable _, _) | (E_lambda _, _)
| (E_application _, _) | (E_let_in _, _)
| (E_accessor _, _)

82
src/stages/ast_simplified/types.ml
View File

@ -1,43 +1,28 @@
[@@@warning "-30"]
module Map = Simple_utils.Map
module Location = Simple_utils.Location
type name = string
type type_name = string
type constructor_name = string
type 'a name_map = 'a Map.String.t
type 'a type_name_map = 'a Map.String.t
include Stage_common.Types
type program = declaration Location.wrap list
and type_expression = {
type_expression' : type_expression type_expression'
}
and declaration =
| Declaration_type of (type_name * type_expression)
| Declaration_constant of (name * type_expression option * expression)
| Declaration_type of (type_variable * type_expression)
| Declaration_constant of (expression_variable * type_expression option * expression)
(* | Macro_declaration of macro_declaration *)
and expr = expression
and te = type_expression
and te_map = type_expression type_name_map
and expr_map = expression name_map
and type_expression =
| T_tuple of te list
| T_sum of te_map
| T_record of te_map
| T_function of te * te
| T_variable of type_name
| T_constant of type_name * te list
and lambda = {
binder : (name * type_expression option) ;
binder : (expression_variable * type_expression option) ;
input_type : type_expression option ;
output_type : type_expression option ;
result : expr ;
}
and let_in = {
binder : (name * type_expression option) ;
binder : (expression_variable * type_expression option) ;
rhs : expr ;
result : expr ;
}
@ -45,17 +30,17 @@ and let_in = {
and expression' =
(* Base *)
| E_literal of literal
| E_constant of (name * expr list) (* For language constants, like (Cons hd tl) or (plus i j) *)
| E_variable of name
| E_constant of (constant * expr list) (* For language constants, like (Cons hd tl) or (plus i j) *)
| E_variable of expression_variable
| E_lambda of lambda
| E_application of (expr * expr)
| E_let_in of let_in
(* E_Tuple *)
| E_tuple of expr list
(* Sum *)
| E_constructor of (name * expr) (* For user defined constructors *)
| E_constructor of (constructor * expr) (* For user defined constructors *)
(* E_record *)
| E_record of expr_map
| E_record of expr label_map
(* TODO: Change it to (expr * access) *)
| E_accessor of (expr * access_path)
(* Data Structures *)
@ -69,52 +54,15 @@ and expression' =
(* Replace Statements *)
| E_sequence of (expr * expr)
| E_loop of (expr * expr)
| E_assign of (name * access_path * expr)
| E_assign of (expression_variable * access_path * expr)
| E_skip
(* Annotate *)
| E_annotation of expr * type_expression
| E_ascription of expr * type_expression
and expression = {
expression : expression' ;
location : Location.t ;
}
and access =
| Access_tuple of int
| Access_record of string
and access_path = access list
and literal =
| Literal_unit
| Literal_bool of bool
| Literal_int of int
| Literal_nat of int
| Literal_mutez of int
| Literal_string of string
| Literal_bytes of bytes
| Literal_address of string
| Literal_timestamp of int
| Literal_signature of string
| Literal_key of string
| Literal_key_hash of string
| Literal_chain_id of string
| Literal_operation of Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation
and 'a matching =
| Match_bool of {
match_true : 'a ;
match_false : 'a ;
}
| Match_list of {
match_nil : 'a ;
match_cons : name * name * 'a ;
}
| Match_option of {
match_none : 'a ;
match_some : name * 'a ;
}
| Match_tuple of name list * 'a
| Match_variant of ((constructor_name * name) * 'a) list
and matching_expr = expression matching
and matching_expr = (expr,unit) matching

76
src/stages/ast_typed/PP.ml
View File

@ -1,20 +1,13 @@
open Types
open Format
open PP_helpers
include Stage_common.PP
let list_sep_d x = list_sep x (const " , ")
let smap_sep_d x = smap_sep x (const " , ")
let rec type_value' ppf (tv':type_value') : unit =
match tv' with
| T_tuple lst -> fprintf ppf "tuple[%a]" (list_sep_d type_value) lst
| T_sum m -> fprintf ppf "sum[%a]" (smap_sep_d type_value) m
| T_record m -> fprintf ppf "record[%a]" (smap_sep_d type_value) m
| T_function (a, b) -> fprintf ppf "%a -> %a" type_value a type_value b
| T_constant (Type_name c, []) -> fprintf ppf "%s" c
| T_constant (Type_name c, n) -> fprintf ppf "%s(%a)" c (list_sep_d type_value) n
| T_variable (Type_name name) -> fprintf ppf "%s" name
let rec type_value' ppf (tv':type_value type_expression') : unit =
type_expression' type_value ppf tv'
and type_value ppf (tv:type_value) : unit =
type_value' ppf tv.type_value'
@ -26,21 +19,22 @@ let rec annotated_expression ppf (ae:annotated_expression) : unit =
and lambda ppf l =
let ({ binder ; body } : lambda) = l in
fprintf ppf "lambda (%s) -> %a"
binder annotated_expression body
fprintf ppf "lambda (%a) -> %a"
name binder
annotated_expression body
and expression ppf (e:expression) : unit =
match e with
| E_literal l -> literal ppf l
| E_constant (c, lst) -> fprintf ppf "%s(%a)" c (list_sep_d annotated_expression) lst
| E_constructor (c, lst) -> fprintf ppf "%s(%a)" c annotated_expression lst
| E_variable a -> fprintf ppf "%s" a
| E_literal l -> Stage_common.PP.literal ppf l
| E_constant (b, lst) -> fprintf ppf "%a(%a)" constant b (list_sep_d annotated_expression) lst
| E_constructor (c, lst) -> fprintf ppf "%a(%a)" constructor c annotated_expression lst
| E_variable a -> fprintf ppf "%a" name a
| E_application (f, arg) -> fprintf ppf "(%a) (%a)" annotated_expression f annotated_expression arg
| E_lambda l -> fprintf ppf "%a" lambda l
| E_tuple_accessor (ae, i) -> fprintf ppf "%a.%d" annotated_expression ae i
| E_record_accessor (ae, s) -> fprintf ppf "%a.%s" annotated_expression ae s
| E_record_accessor (ae, l) -> fprintf ppf "%a.%a" annotated_expression ae label l
| E_tuple lst -> fprintf ppf "tuple[@; @[<v>%a@]@;]" (list_sep annotated_expression (tag ",@;")) lst
| E_record m -> fprintf ppf "record[%a]" (smap_sep_d annotated_expression) m
| E_record m -> fprintf ppf "record[%a]" (lmap_sep annotated_expression (const " , ")) m
| E_map m -> fprintf ppf "map[@; @[<v>%a@]@;]" (list_sep assoc_annotated_expression (tag ",@;")) m
| E_big_map m -> fprintf ppf "big_map[@; @[<v>%a@]@;]" (list_sep assoc_annotated_expression (tag ",@;")) m
| E_list m -> fprintf ppf "list[@; @[<v>%a@]@;]" (list_sep annotated_expression (tag ",@;")) m
@ -51,53 +45,35 @@ and expression ppf (e:expression) : unit =
| E_sequence (a , b) -> fprintf ppf "%a ; %a" annotated_expression a annotated_expression b
| E_loop (expr , body) -> fprintf ppf "while %a { %a }" annotated_expression expr annotated_expression body
| E_assign (name , path , expr) ->
fprintf ppf "%s.%a := %a"
name.type_name
fprintf ppf "%a.%a := %a"
Stage_common.PP.name name.type_name
PP_helpers.(list_sep pre_access (const ".")) path
annotated_expression expr
| E_let_in { binder; rhs; result } ->
fprintf ppf "let %s = %a in %a" binder annotated_expression rhs annotated_expression result
| E_let_in { binder; rhs; result } -> fprintf ppf "let %a = %a in %a" name binder annotated_expression rhs annotated_expression result
and value ppf v = annotated_expression ppf v
and assoc_annotated_expression ppf : (ae * ae) -> unit = fun (a, b) ->
fprintf ppf "%a -> %a" annotated_expression a annotated_expression b
and literal ppf (l:literal) : unit =
match l with
| Literal_unit -> fprintf ppf "unit"
| Literal_bool b -> fprintf ppf "%b" b
| Literal_int n -> fprintf ppf "%d" n
| Literal_nat n -> fprintf ppf "+%d" n
| Literal_timestamp n -> fprintf ppf "+%d" n
| Literal_mutez n -> fprintf ppf "%dmutez" n
| Literal_string s -> fprintf ppf "%s" s
| Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b
| Literal_address s -> fprintf ppf "@%s" s
| Literal_signature s -> fprintf ppf "@%s" s
| Literal_key s -> fprintf ppf "@%s" s
| Literal_key_hash s -> fprintf ppf "@%s" s
| Literal_operation _ -> fprintf ppf "Operation(...bytes)"
| Literal_chain_id s -> fprintf ppf "@%s" s
and single_record_patch ppf ((s, ae) : string * ae) =
fprintf ppf "%s <- %a" s annotated_expression ae
and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor_name * name) * a -> unit =
and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor * expression_variable) * a -> unit =
fun f ppf ((c,n),a) ->
fprintf ppf "| %s %s -> %a" c n f a
fprintf ppf "| %a %a -> %a" constructor c name n f a
and matching : type a . (formatter -> a -> unit) -> _ -> a matching -> unit = fun f ppf m -> match m with
| Match_tuple (lst, b) ->
fprintf ppf "let (%a) = %a" (list_sep_d (fun ppf -> fprintf ppf "%s")) lst f b
| Match_variant (lst , _) ->
and matching : type a . (formatter -> a -> unit) -> _ -> (a, 'var) matching -> unit = fun f ppf m -> match m with
| Match_tuple ((lst, b),_) ->
fprintf ppf "let (%a) = %a" (list_sep_d Stage_common.PP.name) lst f b
| Match_variant (lst, _) ->
fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst
| Match_bool {match_true ; match_false} ->
fprintf ppf "| True -> %a @.| False -> %a" f match_true f match_false
| Match_list {match_nil ; match_cons = (((hd_name , _), (tl_name , _)), match_cons)} ->
fprintf ppf "| Nil -> %a @.| %s :: %s -> %a" f match_nil hd_name tl_name f match_cons
| Match_option {match_none ; match_some = (some, match_some)} ->
fprintf ppf "| None -> %a @.| Some %s -> %a" f match_none (fst some) f match_some
| Match_list {match_nil ; match_cons = (hd_name, tl_name, match_cons, _)} ->
fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil Stage_common.PP.name hd_name Stage_common.PP.name tl_name f match_cons
| Match_option {match_none ; match_some = (some, match_some, _)} ->
fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none name some f match_some
and pre_access ppf (a:access) = match a with
| Access_record n -> fprintf ppf ".%s" n
@ -106,7 +82,7 @@ and pre_access ppf (a:access) = match a with
let declaration ppf (d:declaration) =
match d with
| Declaration_constant ({name ; annotated_expression = ae} , _) ->
fprintf ppf "const %s = %a" name annotated_expression ae
fprintf ppf "const %a = %a" Stage_common.PP.name name annotated_expression ae
let program ppf (p:program) =
fprintf ppf "@[<v>%a@]" (list_sep declaration (tag "@;")) (List.map Location.unwrap p)

2
src/stages/ast_typed/PP.mli
View File

@ -23,7 +23,7 @@ val lambda : formatter -> lambda -> unit
val assoc_annotated_expression : formatter -> (ae * ae) -> unit
val matching_variant_case : ( formatter -> 'a -> unit ) -> formatter -> ( constructor_name * name ) * 'a -> unit
val matching_variant_case : ( formatter -> 'a -> unit ) -> formatter -> ( T.constructor_name * name ) * 'a -> unit
val matching : ( formatter -> 'a -> unit ) -> formatter -> 'a matching -> unit

125
src/stages/ast_typed/combinators.ml
View File

@ -11,48 +11,48 @@ let make_a_e ?(location = Location.generated) expression type_annotation environ
let make_n_e name a_e = { name ; annotated_expression = a_e }
let make_n_t type_name type_value = { type_name ; type_value }
let t_bool ?s () : type_value = make_t (T_constant (Type_name "bool", [])) s
let t_string ?s () : type_value = make_t (T_constant (Type_name "string", [])) s
let t_bytes ?s () : type_value = make_t (T_constant (Type_name "bytes", [])) s
let t_key ?s () : type_value = make_t (T_constant (Type_name "key", [])) s
let t_key_hash ?s () : type_value = make_t (T_constant (Type_name "key_hash", [])) s
let t_signature ?s () : type_value = make_t (T_constant (Type_name "signature", [])) s
let t_int ?s () : type_value = make_t (T_constant (Type_name "int", [])) s
let t_address ?s () : type_value = make_t (T_constant (Type_name "address", [])) s
let t_chain_id ?s () : type_value = make_t (T_constant (Type_name "chain_id", [])) s
let t_operation ?s () : type_value = make_t (T_constant (Type_name "operation", [])) s
let t_nat ?s () : type_value = make_t (T_constant (Type_name "nat", [])) s
let t_mutez ?s () : type_value = make_t (T_constant (Type_name "tez", [])) s
let t_timestamp ?s () : type_value = make_t (T_constant (Type_name "timestamp", [])) s
let t_unit ?s () : type_value = make_t (T_constant (Type_name "unit", [])) s
let t_option o ?s () : type_value = make_t (T_constant (Type_name "option", [o])) s
let t_tuple lst ?s () : type_value = make_t (T_tuple lst) s
let t_signature ?s () : type_value = make_t (T_constant TC_signature) s
let t_chain_id ?s () : type_value = make_t (T_constant TC_chain_id) s
let t_bool ?s () : type_value = make_t (T_constant TC_bool) s
let t_string ?s () : type_value = make_t (T_constant TC_string) s
let t_bytes ?s () : type_value = make_t (T_constant TC_bytes) s
let t_key ?s () : type_value = make_t (T_constant TC_key) s
let t_key_hash ?s () : type_value = make_t (T_constant TC_key_hash) s
let t_int ?s () : type_value = make_t (T_constant TC_int) s
let t_address ?s () : type_value = make_t (T_constant TC_address) s
let t_operation ?s () : type_value = make_t (T_constant TC_operation) s
let t_nat ?s () : type_value = make_t (T_constant TC_nat) s
let t_mutez ?s () : type_value = make_t (T_constant TC_mutez) s
let t_timestamp ?s () : type_value = make_t (T_constant TC_timestamp) s
let t_unit ?s () : type_value = make_t (T_constant TC_unit) s
let t_option o ?s () : type_value = make_t (T_operator (TC_option o)) s
let t_tuple lst ?s () : type_value = make_t (T_tuple lst) s
let t_variable t ?s () : type_value = make_t (T_variable t) s
let t_list t ?s () : type_value = make_t (T_constant (Type_name "list", [t])) s
let t_set t ?s () : type_value = make_t (T_constant (Type_name "set", [t])) s
let t_contract t ?s () : type_value = make_t (T_constant (Type_name "contract", [t])) s
let t_pair a b ?s () = t_tuple [a ; b] ?s ()
let t_list t ?s () : type_value = make_t (T_operator (TC_list t)) s
let t_set t ?s () : type_value = make_t (T_operator (TC_set t)) s
let t_contract t ?s () : type_value = make_t (T_operator (TC_contract t)) s
let t_pair a b ?s () : type_value = t_tuple [a ; b] ?s ()
let t_record m ?s () : type_value = make_t (T_record m) s
let make_t_ez_record (lst:(string * type_value) list) : type_value =
let aux prev (k, v) = SMap.add k v prev in
let map = List.fold_left aux SMap.empty lst in
let make_t_ez_record (lst:(label * type_value) list) : type_value =
let aux prev (k, v) = LMap.add k v prev in
let map = List.fold_left aux LMap.empty lst in
make_t (T_record map) None
let ez_t_record lst ?s () : type_value =
let m = SMap.of_list lst in
let m = LMap.of_list lst in
t_record m ?s ()
let t_map key value ?s () = make_t (T_constant (Type_name "map", [key ; value])) s
let t_big_map key value ?s () = make_t (T_constant (Type_name "big_map", [key ; value])) s
let t_map key value ?s () = make_t (T_operator (TC_map (key , value))) s
let t_big_map key value ?s () = make_t (T_operator (TC_big_map (key , value))) s
let t_sum m ?s () : type_value = make_t (T_sum m) s
let make_t_ez_sum (lst:(string * type_value) list) : type_value =
let aux prev (k, v) = SMap.add k v prev in
let map = List.fold_left aux SMap.empty lst in
let make_t_ez_sum (lst:(constructor * type_value) list) : type_value =
let aux prev (k, v) = CMap.add k v prev in
let map = List.fold_left aux CMap.empty lst in
make_t (T_sum map) None
let t_function param result ?s () : type_value = make_t (T_function (param, result)) s
let t_shallow_closure param result ?s () : type_value = make_t (T_function (param, result)) s
let t_function param result ?s () : type_value = make_t (T_arrow (param, result)) s
let t_shallow_closure param result ?s () : type_value = make_t (T_arrow (param, result)) s
let get_type_annotation (x:annotated_expression) = x.type_annotation
let get_type' (x:type_value) = x.type_value'
@ -65,63 +65,63 @@ let get_lambda e : _ result = match e with
let get_lambda_with_type e =
match (e.expression , e.type_annotation.type_value') with
| E_lambda l , T_function io -> ok (l , io)
| E_lambda l , T_arrow (i,o) -> ok (l , (i,o))
| _ -> simple_fail "not a lambda with functional type"
let get_t_bool (t:type_value) : unit result = match t.type_value' with
| T_constant (Type_name "bool", []) -> ok ()
| T_constant (TC_bool) -> ok ()
| _ -> simple_fail "not a bool"
let get_t_int (t:type_value) : unit result = match t.type_value' with
| T_constant (Type_name "int", []) -> ok ()
| T_constant (TC_int) -> ok ()
| _ -> simple_fail "not a int"
let get_t_nat (t:type_value) : unit result = match t.type_value' with
| T_constant (Type_name "nat", []) -> ok ()
| T_constant (TC_nat) -> ok ()
| _ -> simple_fail "not a nat"
let get_t_unit (t:type_value) : unit result = match t.type_value' with
| T_constant (Type_name "unit", []) -> ok ()
| T_constant (TC_unit) -> ok ()
| _ -> simple_fail "not a unit"
let get_t_mutez (t:type_value) : unit result = match t.type_value' with
| T_constant (Type_name "tez", []) -> ok ()
| T_constant (TC_mutez) -> ok ()
| _ -> simple_fail "not a tez"
let get_t_bytes (t:type_value) : unit result = match t.type_value' with
| T_constant (Type_name "bytes", []) -> ok ()
| T_constant (TC_bytes) -> ok ()
| _ -> simple_fail "not a bytes"
let get_t_string (t:type_value) : unit result = match t.type_value' with
| T_constant (Type_name "string", []) -> ok ()
| T_constant (TC_string) -> ok ()
| _ -> simple_fail "not a string"
let get_t_contract (t:type_value) : type_value result = match t.type_value' with
| T_constant (Type_name "contract", [x]) -> ok x
| T_operator (TC_contract x) -> ok x
| _ -> simple_fail "not a contract"
let get_t_option (t:type_value) : type_value result = match t.type_value' with
| T_constant (Type_name "option", [o]) -> ok o
| T_operator (TC_option o) -> ok o
| _ -> simple_fail "not a option"
let get_t_list (t:type_value) : type_value result = match t.type_value' with
| T_constant (Type_name "list", [o]) -> ok o
| T_operator (TC_list l) -> ok l
| _ -> simple_fail "not a list"
let get_t_set (t:type_value) : type_value result = match t.type_value' with
| T_constant (Type_name "set", [o]) -> ok o
| T_operator (TC_set s) -> ok s
| _ -> simple_fail "not a set"
let get_t_key (t:type_value) : unit result = match t.type_value' with
| T_constant (Type_name "key", []) -> ok ()
| T_constant (TC_key) -> ok ()
| _ -> simple_fail "not a key"
let get_t_signature (t:type_value) : unit result = match t.type_value' with
| T_constant (Type_name "signature", []) -> ok ()
| T_constant (TC_signature) -> ok ()
| _ -> simple_fail "not a signature"
let get_t_key_hash (t:type_value) : unit result = match t.type_value' with
| T_constant (Type_name "key_hash", []) -> ok ()
| T_constant (TC_key_hash) -> ok ()
| _ -> simple_fail "not a key_hash"
let get_t_tuple (t:type_value) : type_value list result = match t.type_value' with
@ -137,25 +137,25 @@ let get_t_pair (t:type_value) : (type_value * type_value) result = match t.type_
| _ -> simple_fail "not a tuple"
let get_t_function (t:type_value) : (type_value * type_value) result = match t.type_value' with
| T_function ar -> ok ar
| T_arrow (a,r) -> ok (a,r)
| _ -> simple_fail "not a tuple"
let get_t_sum (t:type_value) : type_value SMap.t result = match t.type_value' with
let get_t_sum (t:type_value) : type_value constructor_map result = match t.type_value' with
| T_sum m -> ok m
| _ -> simple_fail "not a sum"
let get_t_record (t:type_value) : type_value SMap.t result = match t.type_value' with
let get_t_record (t:type_value) : type_value label_map result = match t.type_value' with
| T_record m -> ok m
| _ -> simple_fail "not a record type"
let get_t_map (t:type_value) : (type_value * type_value) result =
match t.type_value' with
| T_constant (Type_name "map", [k;v]) -> ok (k, v)
| T_operator (TC_map (k,v)) -> ok (k, v)
| _ -> simple_fail "get: not a map"
let get_t_big_map (t:type_value) : (type_value * type_value) result =
match t.type_value' with
| T_constant (Type_name "big_map", [k;v]) -> ok (k, v)
| T_operator (TC_big_map (k,v)) -> ok (k, v)
| _ -> simple_fail "get: not a big_map"
let get_t_map_key : type_value -> type_value result = fun t ->
@ -187,7 +187,7 @@ let assert_t_signature = get_t_signature
let assert_t_key_hash = get_t_key_hash
let assert_t_contract (t:type_value) : unit result = match t.type_value' with
| T_constant (Type_name "contract", _) -> ok ()
| T_operator (TC_contract _) -> ok ()
| _ -> simple_fail "not a contract"
let assert_t_list t =
@ -207,7 +207,7 @@ let assert_t_bytes = fun t ->
let assert_t_operation (t:type_value) : unit result =
match t.type_value' with
| T_constant (Type_name "operation" , []) -> ok ()
| T_constant (TC_operation) -> ok ()
| _ -> simple_fail "assert: not an operation"
let assert_t_list_operation (t : type_value) : unit result =
@ -215,23 +215,23 @@ let assert_t_list_operation (t : type_value) : unit result =
assert_t_operation t'
let assert_t_int : type_value -> unit result = fun t -> match t.type_value' with
| T_constant (Type_name "int", []) -> ok ()
| T_constant (TC_int) -> ok ()
| _ -> simple_fail "not an int"
let assert_t_nat : type_value -> unit result = fun t -> match t.type_value' with
| T_constant (Type_name "nat", []) -> ok ()
| T_constant (TC_nat) -> ok ()
| _ -> simple_fail "not an nat"
let assert_t_bool : type_value -> unit result = fun v -> get_t_bool v
let assert_t_unit : type_value -> unit result = fun v -> get_t_unit v
let e_record map : expression = E_record map
let ez_e_record (lst : (string * ae) list) : expression =
let aux prev (k, v) = SMap.add k v prev in
let map = List.fold_left aux SMap.empty lst in
let ez_e_record (lst : (label * ae) list) : expression =
let aux prev (k, v) = LMap.add k v prev in
let map = List.fold_left aux LMap.empty lst in
e_record map
let e_some s : expression = E_constant ("SOME", [s])
let e_none : expression = E_constant ("NONE", [])
let e_some s : expression = E_constant (C_SOME, [s])
let e_none : expression = E_constant (C_NONE, [])
let e_map lst : expression = E_map lst
@ -269,7 +269,7 @@ let e_a_some s = make_a_e (e_some s) (t_option s.type_annotation ())
let e_a_lambda l in_ty out_ty = make_a_e (e_lambda l) (t_function in_ty out_ty ())
let e_a_none t = make_a_e e_none (t_option t ())
let e_a_tuple lst = make_a_e (E_tuple lst) (t_tuple (List.map get_type_annotation lst) ())
let e_a_record r = make_a_e (e_record r) (t_record (SMap.map get_type_annotation r) ())
let e_a_record r = make_a_e (e_record r) (t_record (LMap.map get_type_annotation r) ())
let e_a_application a b = make_a_e (e_application a b) (get_type_annotation b)
let e_a_variable v ty = make_a_e (e_variable v) ty
let ez_e_a_record r = make_a_e (ez_e_record r) (ez_t_record (List.map (fun (x, y) -> x, y.type_annotation) r) ())
@ -301,8 +301,7 @@ let get_a_record_accessor = fun t ->
let get_declaration_by_name : program -> string -> declaration result = fun p name ->
let aux : declaration -> bool = fun declaration ->
match declaration with
| Declaration_constant (d , _) -> d.name = name
| Declaration_constant (d , _) -> d.name = Var.of_name name
in
trace_option (simple_error "no declaration with given name") @@
List.find_opt aux @@ List.map Location.unwrap p

37
src/stages/ast_typed/combinators.mli
View File

@ -1,8 +1,9 @@
open Trace
open Types
open Stage_common.Types
val make_n_e : name -> annotated_expression -> named_expression
val make_n_t : name -> type_value -> named_type_value
val make_n_e : expression_variable -> annotated_expression -> named_expression
val make_n_t : expression_variable -> type_value -> named_type_value
val make_t : type_value' -> S.type_expression option -> type_value
val make_a_e : ?location:Location.t -> expression -> type_value -> full_environment -> annotated_expression
@ -26,17 +27,17 @@ val t_option : type_value -> ?s:S.type_expression -> unit -> type_value
val t_pair : type_value -> type_value -> ?s:S.type_expression -> unit -> type_value
val t_list : type_value -> ?s:S.type_expression -> unit -> type_value
val t_tuple : type_value list -> ?s:S.type_expression -> unit -> type_value
val t_variable : type_name -> ?s:S.type_expression -> unit -> type_value
val t_record : tv_map -> ?s:S.type_expression -> unit -> type_value
val make_t_ez_record : (string * type_value) list -> type_value
val t_variable : type_variable -> ?s:S.type_expression -> unit -> type_value
val t_record : type_value label_map -> ?s:S.type_expression -> unit -> type_value
val make_t_ez_record : (label* type_value) list -> type_value
(*
val ez_t_record : ( string * type_value ) list -> ?s:S.type_expression -> unit -> type_value
*)
val t_map : type_value -> type_value -> ?s:S.type_expression -> unit -> type_value
val t_big_map : type_value -> type_value -> ?s:S.type_expression -> unit -> type_value
val t_sum : tv_map -> ?s:S.type_expression -> unit -> type_value
val make_t_ez_sum : ( string * type_value ) list -> type_value
val t_sum : type_value constructor_map -> ?s:S.type_expression -> unit -> type_value
val make_t_ez_sum : ( constructor * type_value ) list -> type_value
val t_function : type_value -> type_value -> ?s:S.type_expression -> unit -> type_value
val t_shallow_closure : type_value -> type_value -> ?s:S.type_expression -> unit -> type_value
val get_type_annotation : annotated_expression -> type_value
@ -44,7 +45,7 @@ val get_type' : type_value -> type_value'
val get_environment : annotated_expression -> full_environment
val get_expression : annotated_expression -> expression
val get_lambda : expression -> lambda result
val get_lambda_with_type : annotated_expression -> (lambda * ( tv * tv) ) result
val get_lambda_with_type : annotated_expression -> (lambda * ( type_value * type_value) ) result
val get_t_bool : type_value -> unit result
(*
val get_t_int : type_value -> unit result
@ -66,8 +67,8 @@ val get_t_key_hash : type_value -> unit result
val get_t_tuple : type_value -> type_value list result
val get_t_pair : type_value -> ( type_value * type_value ) result
val get_t_function : type_value -> ( type_value * type_value ) result
val get_t_sum : type_value -> type_value SMap.t result
val get_t_record : type_value -> type_value SMap.t result
val get_t_sum : type_value -> type_value constructor_map result
val get_t_record : type_value -> type_value label_map result
val get_t_map : type_value -> ( type_value * type_value ) result
val get_t_big_map : type_value -> ( type_value * type_value ) result
val get_t_map_key : type_value -> type_value result
@ -129,9 +130,9 @@ val e_operation : Memory_proto_alpha.Protocol.Alpha_context.packed_internal_oper
val e_lambda : lambda -> expression
val e_pair : value -> value -> expression
val e_application : value -> value -> expression
val e_variable : name -> expression
val e_variable : expression_variable -> expression
val e_list : value list -> expression
val e_let_in : string -> value -> value -> expression
val e_let_in : expression_variable -> value -> value -> expression
val e_tuple : value list -> expression
val e_a_unit : full_environment -> annotated_expression
@ -143,19 +144,19 @@ val e_a_string : string -> full_environment -> annotated_expression
val e_a_address : string -> full_environment -> annotated_expression
val e_a_pair : annotated_expression -> annotated_expression -> full_environment -> annotated_expression
val e_a_some : annotated_expression -> full_environment -> annotated_expression
val e_a_lambda : lambda -> tv -> tv -> full_environment -> annotated_expression
val e_a_lambda : lambda -> type_value -> type_value -> full_environment -> annotated_expression
val e_a_none : type_value -> full_environment -> annotated_expression
val e_a_tuple : annotated_expression list -> full_environment -> annotated_expression
val e_a_record : ae_map -> full_environment -> annotated_expression
val e_a_record : annotated_expression label_map -> full_environment -> annotated_expression
val e_a_application : annotated_expression -> annotated_expression -> full_environment -> annotated_expression
val e_a_variable : name -> type_value -> full_environment -> annotated_expression
val ez_e_a_record : ( name * annotated_expression ) list -> full_environment -> annotated_expression
val e_a_variable : expression_variable -> type_value -> full_environment -> annotated_expression
val ez_e_a_record : ( label * annotated_expression ) list -> full_environment -> annotated_expression
val e_a_map : ( annotated_expression * annotated_expression ) list -> type_value -> type_value -> full_environment -> annotated_expression
val e_a_list : annotated_expression list -> type_value -> full_environment -> annotated_expression
val e_a_let_in : name -> annotated_expression -> annotated_expression -> full_environment -> annotated_expression
val e_a_let_in : expression_variable -> annotated_expression -> annotated_expression -> full_environment -> annotated_expression
val get_a_int : annotated_expression -> int result
val get_a_unit : annotated_expression -> unit result
val get_a_bool : annotated_expression -> bool result
val get_a_record_accessor : annotated_expression -> (annotated_expression * name) result
val get_a_record_accessor : annotated_expression -> (annotated_expression * label) result
val get_declaration_by_name : program -> string -> declaration result

6
src/stages/ast_typed/combinators_environment.ml
View File

@ -23,6 +23,6 @@ let e_a_empty_lambda l i o = e_a_lambda l i o Environment.full_empty
open Environment
let env_sum_type ?(env = full_empty)
?(name = "a_sum_type")
(lst : (string * type_value) list) =
add_type name (make_t_ez_sum lst) env
?(type_name = Var.of_name "a_sum_type")
(lst : (constructor * type_value) list) =
add_type type_name (make_t_ez_sum lst) env

8
src/stages/ast_typed/combinators_environment.mli
View File

@ -13,10 +13,10 @@ val e_a_empty_pair : annotated_expression -> annotated_expression -> annotated_e
val e_a_empty_some : annotated_expression -> annotated_expression
val e_a_empty_none : type_value -> annotated_expression
val e_a_empty_tuple : annotated_expression list -> annotated_expression
val e_a_empty_record : ae_map -> annotated_expression
val e_a_empty_record : annotated_expression label_map -> annotated_expression
val e_a_empty_map : (annotated_expression * annotated_expression ) list -> type_value -> type_value -> annotated_expression
val e_a_empty_list : annotated_expression list -> type_value -> annotated_expression
val ez_e_a_empty_record : ( name * annotated_expression ) list -> annotated_expression
val e_a_empty_lambda : lambda -> tv -> tv -> annotated_expression
val ez_e_a_empty_record : ( label * annotated_expression ) list -> annotated_expression
val e_a_empty_lambda : lambda -> type_value -> type_value -> annotated_expression
val env_sum_type : ?env:full_environment -> ?name:name -> (name * type_value) list -> full_environment
val env_sum_type : ?env:full_environment -> ?type_name:type_variable -> (constructor * type_value) list -> full_environment

1
src/stages/ast_typed/dune
View File

@ -5,6 +5,7 @@
simple-utils
tezos-utils
ast_simplified ; Is that a good idea?
stage_common
)
(preprocess
(pps ppx_let)

33
src/stages/ast_typed/environment.ml
View File

@ -1,4 +1,5 @@
open Types
open Stage_common.Types
open Combinators
type element = environment_element
@ -20,31 +21,31 @@ module Small = struct
let map_environment : _ -> t -> t = fun f (a , b) -> (f a , b)
let map_type_environment : _ -> t -> t = fun f (a , b) -> (a , f b)
let add : string -> element -> t -> t = fun k v -> map_environment (fun x -> (k , v) :: x)
let add_type : string -> type_value -> t -> t = fun k v -> map_type_environment (fun x -> (k , v) :: x)
let get_opt : string -> t -> element option = fun k x -> List.assoc_opt k (get_environment x)
let get_type_opt : string -> t -> type_value option = fun k x -> List.assoc_opt k (get_type_environment x)
let add : expression_variable -> element -> t -> t = fun k v -> map_environment (fun x -> (k , v) :: x)
let add_type : type_variable -> type_value -> t -> t = fun k v -> map_type_environment (fun x -> (k , v) :: x)
let get_opt : expression_variable -> t -> element option = fun k x -> List.assoc_opt k (get_environment x)
let get_type_opt : type_variable -> t -> type_value option = fun k x -> List.assoc_opt k (get_type_environment x)
end
type t = full_environment
let empty : environment = Small.(get_environment empty)
let full_empty : t = List.Ne.singleton Small.empty
let add : string -> element -> t -> t = fun k v -> List.Ne.hd_map (Small.add k v)
let add_ez_binder : string -> type_value -> t -> t = fun k v e ->
let add : expression_variable -> element -> t -> t = fun k v -> List.Ne.hd_map (Small.add k v)
let add_ez_binder : expression_variable -> type_value -> t -> t = fun k v e ->
List.Ne.hd_map (Small.add k (make_element_binder v e)) e
let add_ez_declaration : string -> annotated_expression -> t -> t = fun k ae e ->
let add_ez_declaration : expression_variable -> annotated_expression -> t -> t = fun k ae e ->
List.Ne.hd_map (Small.add k (make_element_declaration e ae)) e
let add_ez_ae = add_ez_declaration
let add_type : string -> type_value -> t -> t = fun k v -> List.Ne.hd_map (Small.add_type k v)
let get_opt : string -> t -> element option = fun k x -> List.Ne.find_map (Small.get_opt k) x
let get_type_opt : string -> t -> type_value option = fun k x -> List.Ne.find_map (Small.get_type_opt k) x
let add_type : type_variable -> type_value -> t -> t = fun k v -> List.Ne.hd_map (Small.add_type k v)
let get_opt : expression_variable -> t -> element option = fun k x -> List.Ne.find_map (Small.get_opt k) x
let get_type_opt : type_variable -> t -> type_value option = fun k x -> List.Ne.find_map (Small.get_type_opt k) x
let get_constructor : string -> t -> (type_value * type_value) option = fun k x -> (* Left is the constructor, right is the sum type *)
let get_constructor : constructor -> t -> (type_value * type_value) option = fun k x -> (* Left is the constructor, right is the sum type *)
let aux = fun x ->
let aux = fun (_type_name , x) ->
match x.type_value' with
| T_sum m ->
(match Map.String.find_opt k m with
(match CMap.find_opt k m with
Some km -> Some (km , x)
| None -> None)
| _ -> None
@ -60,10 +61,10 @@ module PP = struct
let list_sep_scope x = list_sep x (const " | ")
let environment_element = fun ppf (k , (ele : environment_element)) ->
fprintf ppf "%s -> %a" k PP.type_value ele.type_value
fprintf ppf "%a -> %a" Stage_common.PP.name k PP.type_value ele.type_value
let type_environment_element = fun ppf (k , tv) ->
fprintf ppf "%s -> %a" k PP.type_value tv
fprintf ppf "%a -> %a" Stage_common.PP.type_variable k PP.type_value tv
let environment : _ -> environment -> unit = fun ppf lst ->
fprintf ppf "E[%a]" (list_sep environment_element (const " , ")) lst
@ -83,9 +84,9 @@ end
open Trace
let get_trace : string -> t -> element result = fun s env ->
let get_trace : expression_variable -> t -> element result = fun s env ->
let error =
let title () = "missing var not in env" in
let content () = Format.asprintf "\nvar: %s\nenv: %a\n" s PP.full_environment env in
let content () = Format.asprintf "\nvar: %a\nenv: %a\n" Stage_common.PP.name s PP.full_environment env in
error title content in
trace_option error @@ get_opt s env

18
src/stages/ast_typed/environment.mli
View File

@ -4,17 +4,17 @@ open Trace
type t = full_environment
type element = environment_element
val get_trace : string -> t -> element result
val get_trace : expression_variable -> t -> element result
val empty : environment
val full_empty : t
val add : string -> element -> t -> t
val add_ez_binder : string -> type_value -> t -> t
val add_ez_declaration : string -> annotated_expression -> t -> t
val add_ez_ae : string -> annotated_expression -> t -> t
val add_type : string -> type_value -> t -> t
val get_opt : string -> t -> element option
val get_type_opt : string -> t -> type_value option
val get_constructor : string -> t -> (type_value * type_value) option
val add : expression_variable -> element -> t -> t
val add_ez_binder : expression_variable -> type_value -> t -> t
val add_ez_declaration : expression_variable -> annotated_expression -> t -> t
val add_ez_ae : expression_variable -> annotated_expression -> t -> t
val add_type : type_variable -> type_value -> t -> t
val get_opt : expression_variable -> t -> element option
val get_type_opt : type_variable -> t -> type_value option
val get_constructor : constructor -> t -> (type_value * type_value) option
module Small : sig
type t = small_environment

86
src/stages/ast_typed/misc.ml
View File

@ -12,11 +12,19 @@ module Errors = struct
error ~data title message ()
let different_constants a b () =
let title = (thunk "different constants") in
let title = (thunk "different type constants") in
let message () = "" in
let data = [
("a" , fun () -> Format.asprintf "%s" a) ;
("b" , fun () -> Format.asprintf "%s" b )
("a" , fun () -> Format.asprintf "%a" Stage_common.PP.type_constant a) ;
("b" , fun () -> Format.asprintf "%a" Stage_common.PP.type_constant b )
] in
error ~data title message ()
let different_operators a b () =
let title = (thunk "different type operators") in
let message () = "" in
let data = [
("a" , fun () -> Format.asprintf "%a" (Stage_common.PP.type_operator PP.type_value) a) ;
("b" , fun () -> Format.asprintf "%a" (Stage_common.PP.type_operator PP.type_value) b)
] in
error ~data title message ()
@ -38,7 +46,7 @@ module Errors = struct
] in
error ~data title message ()
let different_size_constants = different_size_type "constants"
let _different_size_constants = different_size_type "constants"
let different_size_tuples = different_size_type "tuples"
@ -146,13 +154,13 @@ end
module Free_variables = struct
type bindings = string list
let mem : string -> bindings -> bool = List.mem
let singleton : string -> bindings = fun s -> [ s ]
type bindings = expression_variable list
let mem : expression_variable -> bindings -> bool = List.mem
let singleton : expression_variable -> bindings = fun s -> [ s ]
let union : bindings -> bindings -> bindings = (@)
let unions : bindings list -> bindings = List.concat
let empty : bindings = []
let of_list : string list -> bindings = fun x -> x
let of_list : expression_variable list -> bindings = fun x -> x
let rec expression : bindings -> expression -> bindings = fun b e ->
let self = annotated_expression b in
@ -168,7 +176,7 @@ module Free_variables = struct
| E_application (a, b) -> unions @@ List.map self [ a ; b ]
| E_tuple lst -> unions @@ List.map self lst
| E_constructor (_ , a) -> self a
| E_record m -> unions @@ List.map self @@ Map.String.to_list m
| E_record m -> unions @@ List.map self @@ LMap.to_list m
| E_record_accessor (a, _) -> self a
| E_tuple_accessor (a, _) -> self a
| E_list lst -> unions @@ List.map self lst
@ -192,16 +200,17 @@ module Free_variables = struct
and annotated_expression : bindings -> annotated_expression -> bindings = fun b ae ->
expression b ae.expression
and matching_variant_case : type a . (bindings -> a -> bindings) -> bindings -> ((constructor_name * name) * a) -> bindings = fun f b ((_,n),c) ->
and matching_variant_case : type a . (bindings -> a -> bindings) -> bindings -> ((constructor * expression_variable) * a) -> bindings = fun f b ((_,n),c) ->
f (union (singleton n) b) c
and matching : type a . (bindings -> a -> bindings) -> bindings -> a matching -> bindings = fun f b m ->
and matching : type a . (bindings -> a -> bindings) -> bindings -> (a,'var) matching -> bindings = fun f b m ->
match m with
| Match_bool { match_true = t ; match_false = fa } -> union (f b t) (f b fa)
| Match_list { match_nil = n ; match_cons = (((hd, _), (tl, _)), c) } -> union (f b n) (f (union (of_list [hd ; tl]) b) c)
| Match_option { match_none = n ; match_some = ((opt, _), s) } -> union (f b n) (f (union (singleton opt) b) s)
| Match_tuple (lst , a) -> f (union (of_list lst) b) a
| Match_variant (lst , _) -> unions @@ List.map (matching_variant_case f b) lst
| Match_list { match_nil = n ; match_cons = (hd, tl, c, _) } -> union (f b n) (f (union (of_list [hd ; tl]) b) c)
| Match_option { match_none = n ; match_some = (opt, s, _) } -> union (f b n) (f (union (singleton opt) b) s)
| Match_tuple ((lst , a), _) ->
f (union (of_list lst) b) a
| Match_variant (lst,_) -> unions @@ List.map (matching_variant_case f b) lst
and matching_expression = fun x -> matching annotated_expression x
@ -288,6 +297,7 @@ end
open Errors
let rec assert_type_value_eq (a, b: (type_value * type_value)) : unit result = match (a.type_value', b.type_value') with
| T_tuple ta, T_tuple tb -> (
let%bind _ =
@ -296,20 +306,28 @@ let rec assert_type_value_eq (a, b: (type_value * type_value)) : unit result = m
bind_list_iter assert_type_value_eq (List.combine ta tb)
)
| T_tuple _, _ -> fail @@ different_kinds a b
| T_constant (Type_name ca, lsta), T_constant (Type_name cb, lstb) -> (
let%bind _ =
trace_strong (different_size_constants a b)
@@ Assert.assert_true List.(length lsta = length lstb) in
let%bind _ =
trace_strong (different_constants ca cb)
@@ Assert.assert_true (ca = cb) in
trace (different_types "constant sub-expression" a b)
@@ bind_list_iter assert_type_value_eq (List.combine lsta lstb)
| T_constant ca, T_constant cb -> (
trace_strong (different_constants ca cb)
@@ Assert.assert_true (ca = cb)
)
| T_constant _, _ -> fail @@ different_kinds a b
| T_operator opa, T_operator opb -> (
let%bind (lsta, lstb) = match (opa, opb) with
| TC_option la, TC_option lb
| TC_list la, TC_list lb
| TC_contract la, TC_contract lb
| TC_set la, TC_set lb -> ok @@ ([la], [lb])
| TC_map (ka,va), TC_map (kb,vb)
| TC_big_map (ka,va), TC_big_map (kb,vb) -> ok @@ ([ka;va] ,[kb;vb])
| _,_ -> fail @@ different_operators opa opb
in
trace (different_types "constant sub-expression" a b)
@@ bind_list_iter (fun (a,b) -> assert_type_value_eq (a,b) )(List.combine lsta lstb)
)
| T_operator _, _ -> fail @@ different_kinds a b
| T_sum sa, T_sum sb -> (
let sa' = SMap.to_kv_list sa in
let sb' = SMap.to_kv_list sb in
let sa' = CMap.to_kv_list sa in
let sb' = CMap.to_kv_list sb in
let aux ((ka, va), (kb, vb)) =
let%bind _ =
Assert.assert_true ~msg:"different keys in sum types"
@ -324,11 +342,13 @@ let rec assert_type_value_eq (a, b: (type_value * type_value)) : unit result = m
)
| T_sum _, _ -> fail @@ different_kinds a b
| T_record ra, T_record rb -> (
let ra' = SMap.to_kv_list ra in
let rb' = SMap.to_kv_list rb in
let ra' = LMap.to_kv_list ra in
let rb' = LMap.to_kv_list rb in
let aux ((ka, va), (kb, vb)) =
let%bind _ =
trace (different_types "records" a b) @@
let Label ka = ka in
let Label kb = kb in
trace_strong (different_props_in_record ka kb) @@
Assert.assert_true (ka = kb) in
assert_type_value_eq (va, vb)
@ -341,11 +361,11 @@ let rec assert_type_value_eq (a, b: (type_value * type_value)) : unit result = m
)
| T_record _, _ -> fail @@ different_kinds a b
| T_function (param, result), T_function (param', result') ->
| T_arrow (param, result), T_arrow (param', result') ->
let%bind _ = assert_type_value_eq (param, param') in
let%bind _ = assert_type_value_eq (result, result') in
ok ()
| T_function _, _ -> fail @@ different_kinds a b
| T_arrow _, _ -> fail @@ different_kinds a b
| T_variable x, T_variable y -> let _ = (x = y) in failwith "TODO : we must check that the two types were bound at the same location (even if they have the same name), i.e. use something like De Bruijn indices or a propper graph encoding"
| T_variable _, _ -> fail @@ different_kinds a b
@ -441,12 +461,12 @@ let rec assert_value_eq (a, b: (value*value)) : unit result =
fail @@ different_values_because_different_types "tuple vs. non-tuple" a b
| E_record sma, E_record smb -> (
let aux k a b =
let aux (Label k) a b =
match a, b with
| Some a, Some b -> Some (assert_value_eq (a, b))
| _ -> Some (fail @@ missing_key_in_record_value k)
in
let%bind _all = bind_smap @@ SMap.merge aux sma smb in
let%bind _all = bind_lmap @@ LMap.merge aux sma smb in
ok ()
)
| E_record _, _ ->
@ -508,7 +528,7 @@ let get_entry (lst : program) (name : string) : annotated_expression result =
trace_option (Errors.missing_entry_point name) @@
let aux x =
let (Declaration_constant (an , _)) = Location.unwrap x in
if (an.name = name)
if (an.name = Var.of_name name)
then Some an.annotated_expression
else None
in

4
src/stages/ast_typed/misc.mli
View File

@ -11,7 +11,7 @@ val merge_annotation : type_value option -> type_value option -> error_thunk ->
val type_value_eq : ( type_value * type_value ) -> bool
module Free_variables : sig
type bindings = string list
type bindings = expression_variable list
val matching_expression : bindings -> matching_expr -> bindings
val lambda : bindings -> lambda -> bindings
@ -19,7 +19,7 @@ module Free_variables : sig
val annotated_expression : bindings -> annotated_expression -> bindings
val empty : bindings
val singleton : string -> bindings
val singleton : expression_variable -> bindings
(*
val mem : string -> bindings -> bool

29
src/stages/ast_typed/misc_smart.ml
View File

@ -2,12 +2,13 @@ open Trace
open Types
open Combinators
open Misc
open Stage_common.Types
let program_to_main : program -> string -> lambda result = fun p s ->
let%bind (main , input_type , _) =
let pred = fun d ->
match d with
| Declaration_constant (d , _) when d.name = s -> Some d.annotated_expression
| Declaration_constant (d , _) when d.name = Var.of_name s -> Some d.annotated_expression
| Declaration_constant _ -> None
in
let%bind main =
@ -15,7 +16,7 @@ let program_to_main : program -> string -> lambda result = fun p s ->
List.find_map (Function.compose pred Location.unwrap) p in
let%bind (input_ty , output_ty) =
match (get_type' @@ get_type_annotation main) with
| T_function (i , o) -> ok (i , o)
| T_arrow (i , o) -> ok (i , o)
| _ -> simple_fail "program main isn't a function" in
ok (main , input_ty , output_ty)
in
@ -24,10 +25,10 @@ let program_to_main : program -> string -> lambda result = fun p s ->
match d with
| Declaration_constant (_ , (_ , post_env)) -> post_env in
List.fold_left aux Environment.full_empty (List.map Location.unwrap p) in
let binder = "@contract_input" in
let binder = Var.of_name "@contract_input" in
let body =
let input_expr = e_a_variable binder input_type env in
let main_expr = e_a_variable s (get_type_annotation main) env in
let main_expr = e_a_variable (Var.of_name s) (get_type_annotation main) env in
e_a_application main_expr input_expr env in
ok {
binder ;
@ -36,13 +37,13 @@ let program_to_main : program -> string -> lambda result = fun p s ->
module Captured_variables = struct
type bindings = string list
let mem : string -> bindings -> bool = List.mem
let singleton : string -> bindings = fun s -> [ s ]
type bindings = expression_variable list
let mem : expression_variable -> bindings -> bool = List.mem
let singleton : expression_variable -> bindings = fun s -> [ s ]
let union : bindings -> bindings -> bindings = (@)
let unions : bindings list -> bindings = List.concat
let empty : bindings = []
let of_list : string list -> bindings = fun x -> x
let of_list : expression_variable list -> bindings = fun x -> x
let rec annotated_expression : bindings -> annotated_expression -> bindings result = fun b ae ->
let self = annotated_expression b in
@ -68,7 +69,7 @@ module Captured_variables = struct
ok @@ unions lst'
| E_constructor (_ , a) -> self a
| E_record m ->
let%bind lst' = bind_map_list self @@ Map.String.to_list m in
let%bind lst' = bind_map_list self @@ LMap.to_list m in
ok @@ unions lst'
| E_record_accessor (a, _) -> self a
| E_tuple_accessor (a, _) -> self a
@ -97,24 +98,24 @@ module Captured_variables = struct
let b' = union (singleton li.binder) b in
annotated_expression b' li.result
and matching_variant_case : type a . (bindings -> a -> bindings result) -> bindings -> ((constructor_name * name) * a) -> bindings result = fun f b ((_,n),c) ->
and matching_variant_case : type a . (bindings -> a -> bindings result) -> bindings -> ((constructor * expression_variable) * a) -> bindings result = fun f b ((_,n),c) ->
f (union (singleton n) b) c
and matching : type a . (bindings -> a -> bindings result) -> bindings -> a matching -> bindings result = fun f b m ->
and matching : type a . (bindings -> a -> bindings result) -> bindings -> (a, 'tv) matching -> bindings result = fun f b m ->
match m with
| Match_bool { match_true = t ; match_false = fa } ->
let%bind t' = f b t in
let%bind fa' = f b fa in
ok @@ union t' fa'
| Match_list { match_nil = n ; match_cons = (((hd, _), (tl, _)), c) } ->
| Match_list { match_nil = n ; match_cons = (hd, tl, c, _) } ->
let%bind n' = f b n in
let%bind c' = f (union (of_list [hd ; tl]) b) c in
ok @@ union n' c'
| Match_option { match_none = n ; match_some = ((opt, _), s) } ->
| Match_option { match_none = n ; match_some = (opt, s, _) } ->
let%bind n' = f b n in
let%bind s' = f (union (singleton opt) b) s in
ok @@ union n' s'
| Match_tuple (lst , a) ->
| Match_tuple ((lst , a),_) ->
f (union (of_list lst) b) a
| Match_variant (lst , _) ->
let%bind lst' = bind_map_list (matching_variant_case f b) lst in

11
src/stages/ast_typed/misc_smart.mli
View File

@ -1,22 +1,23 @@
open Trace
open Types
open Stage_common.Types
val program_to_main : program -> string -> lambda result
module Captured_variables : sig
type bindings = string list
val matching : (bindings -> 'a -> bindings result) -> bindings -> 'a matching -> bindings result
type bindings = expression_variable list
val matching : (bindings -> 'a -> bindings result) -> bindings -> ('a, type_value) matching -> bindings result
val matching_expression : bindings -> matching_expr -> bindings result
val mem : string -> bindings -> bool
val mem : expression_variable -> bindings -> bool
(*
val singleton : string -> bindings
val singleton : name -> bindings
val union : bindings -> bindings -> bindings
val unions : bindings list -> bindings
val empty : bindings
val of_list : string list -> bindings
val of_list : name list -> bindings
val annotated_expression : bindings -> annotated_expression -> bindings result
val matching_variant_case : (bindings -> 'a -> bindings result) -> bindings -> ((constructor_name * name) * 'a) -> bindings result

121
src/stages/ast_typed/types.ml
View File

@ -1,15 +1,7 @@
[@@@warning "-30"]
module S = Ast_simplified
module SMap = Map.String
type name = string
type type_name = Type_name of string
type constructor_name = string
type 'a name_map = 'a SMap.t
type 'a type_name_map = 'a SMap.t
include Stage_common.Types
type program = declaration Location.wrap list
@ -21,45 +13,34 @@ and environment_element_definition =
| ED_binder
| ED_declaration of (annotated_expression * free_variables)
and free_variables = name list
and free_variables = expression_variable list
and environment_element = {
type_value : type_value ; (* SUBST ??? *)
type_value : type_value ;
source_environment : full_environment ;
definition : environment_element_definition ;
}
and environment = (string * environment_element) list
and type_environment = (string * type_value) list (* SUBST ??? *)
and environment = (expression_variable * environment_element) list
and type_environment = (type_variable * type_value) list (* SUBST ??? *)
and small_environment = (environment * type_environment)
and full_environment = small_environment List.Ne.t
and annotated_expression = {
expression : expression ;
type_annotation : tv ; (* SUBST *)
type_annotation : type_value ; (* SUBST *)
environment : full_environment ;
location : Location.t ;
}
and named_expression = {
name: name ;
name: expression_variable ;
annotated_expression: ae ;
}
and tv = type_value
and ae = annotated_expression
and tv_map = type_value type_name_map
and ae_map = annotated_expression name_map
and type_value' =
| T_tuple of tv list
| T_sum of tv_map
| T_record of tv_map
| T_constant of type_name * tv list (* SUBST ??? I think not, at least not necessary for now and the types don't match *)
| T_variable of type_name (* SUBST *)
| T_function of (tv * tv)
and type_value' = type_value type_expression'
and type_value = {
type_value' : type_value' ;
type_value' : type_value';
simplified : S.type_expression option ; (* If we have the simplified this AST fragment comes from, it is stored here, for easier untyping. *)
}
@ -67,91 +48,55 @@ and type_value = {
In mini_c, we need the type associated with `x` in the assignment
expression `x.y.z := 42`, so it is stored here. *)
and named_type_value = {
type_name: name ;
type_name: expression_variable ;
type_value : type_value ;
}
(* E_lamba and other expressions are always wrapped as an annotated_expression. *)
and lambda = {
binder : name ;
binder : expression_variable ;
(* input_type: tv ;
* output_type: tv ; *)
body : ae ;
}
and let_in = {
binder: name;
binder: expression_variable;
rhs: ae;
result: ae;
}
and expression =
and 'a expression' =
(* Base *)
| E_literal of literal
| E_constant of (name * ae list) (* For language constants, like (Cons hd tl) or (plus i j) *)
| E_variable of name
| E_application of (ae * ae)
| E_constant of (constant * ('a) list) (* For language constants, like (Cons hd tl) or (plus i j) *)
| E_variable of expression_variable
| E_application of (('a) * ('a))
| E_lambda of lambda
| E_let_in of let_in
(* Tuple *)
| E_tuple of ae list
| E_tuple_accessor of (ae * int) (* Access n'th tuple's element *)
| E_tuple of ('a) list
| E_tuple_accessor of (('a) * int) (* Access n'th tuple's element *)
(* Sum *)
| E_constructor of (name * ae) (* For user defined constructors *)
| E_constructor of (constructor * ('a)) (* For user defined constructors *)
(* Record *)
| E_record of ae_map
| E_record_accessor of (ae * string)
| E_record of ('a) label_map
| E_record_accessor of (('a) * label)
(* Data Structures *)
| E_map of (ae * ae) list
| E_big_map of (ae * ae) list
| E_list of ae list
| E_set of ae list
| E_look_up of (ae * ae)
| E_map of (('a) * ('a)) list
| E_big_map of (('a) * ('a)) list
| E_list of ('a) list
| E_set of ('a) list
| E_look_up of (('a) * ('a))
(* Advanced *)
| E_matching of (ae * matching_expr)
| E_matching of (('a) * matching_expr)
(* Replace Statements *)
| E_sequence of (ae * ae)
| E_loop of (ae * ae)
| E_assign of (named_type_value * access_path * ae)
| E_sequence of (('a) * ('a))
| E_loop of (('a) * ('a))
| E_assign of (named_type_value * access_path * ('a))
and expression = ae expression'
and value = annotated_expression (* todo (for refactoring) *)
and literal =
| Literal_unit
| Literal_bool of bool
| Literal_int of int
| Literal_nat of int
| Literal_timestamp of int
| Literal_mutez of int
| Literal_string of string
| Literal_bytes of bytes
| Literal_address of string
| Literal_signature of string
| Literal_key of string
| Literal_key_hash of string
| Literal_chain_id of string
| Literal_operation of Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation
and access =
| Access_tuple of int
| Access_record of string
and access_path = access list
and 'a matching =
| Match_bool of {
match_true : 'a ;
match_false : 'a ;
}
| Match_list of {
match_nil : 'a ;
match_cons : ((name * type_value) * (name * type_value)) * 'a ;
}
| Match_option of {
match_none : 'a ;
match_some : (name * type_value) * 'a ;
}
| Match_tuple of (name list * 'a)
| Match_variant of (((constructor_name * name) * 'a) list * type_value)
and matching_expr = ae matching
and matching_expr = (ae,type_value) matching

192
src/stages/common/PP.ml Normal file
View File

@ -0,0 +1,192 @@
open Types
open Format
open PP_helpers
let name ppf (n:expression_variable) : unit =
fprintf ppf "%a" Var.pp n
let type_variable ppf (t:type_variable) : unit =
fprintf ppf "%a" Var.pp t
let constructor ppf (c:constructor) : unit =
let Constructor c = c in fprintf ppf "%s" c
let label ppf (l:label) : unit =
let Label l = l in fprintf ppf "%s" l
let constant ppf : constant -> unit = function
| C_INT -> fprintf ppf "INT"
| C_UNIT -> fprintf ppf "UNIT"
| C_NIL -> fprintf ppf "NIL"
| C_NOW -> fprintf ppf "NOW"
| C_IS_NAT -> fprintf ppf "IS_NAT"
| C_SOME -> fprintf ppf "SOME"
| C_NONE -> fprintf ppf "NONE"
| C_ASSERTION -> fprintf ppf "ASSERTION"
| C_ASSERT_INFERRED -> fprintf ppf "ASSERT_INFERRED"
| C_FAILWITH -> fprintf ppf "FAILWITH"
| C_UPDATE -> fprintf ppf "UPDATE"
(* Loops *)
| C_ITER -> fprintf ppf "ITER"
| C_FOLD -> fprintf ppf "FOLD"
| C_FOLD_WHILE -> fprintf ppf "FOLD_WHILE"
| C_CONTINUE -> fprintf ppf "CONTINUE"
| C_STOP -> fprintf ppf "STOP"
(* MATH *)
| C_NEG -> fprintf ppf "NEG"
| C_ABS -> fprintf ppf "ABS"
| C_ADD -> fprintf ppf "ADD"
| C_SUB -> fprintf ppf "SUB"
| C_MUL -> fprintf ppf "MUL"
| C_DIV -> fprintf ppf "DIV"
| C_MOD -> fprintf ppf "MOD"
(* LOGIC *)
| C_NOT -> fprintf ppf "NOT"
| C_AND -> fprintf ppf "AND"
| C_OR -> fprintf ppf "OR"
| C_XOR -> fprintf ppf "XOR"
(* COMPARATOR *)
| C_EQ -> fprintf ppf "EQ"
| C_NEQ -> fprintf ppf "NEQ"
| C_LT -> fprintf ppf "LT"
| C_GT -> fprintf ppf "GT"
| C_LE -> fprintf ppf "LE"
| C_GE -> fprintf ppf "GE"
(* Bytes/ String *)
| C_SIZE -> fprintf ppf "SIZE"
| C_CONCAT -> fprintf ppf "CONCAT"
| C_SLICE -> fprintf ppf "SLICE"
| C_BYTES_PACK -> fprintf ppf "BYTES_PACK"
| C_BYTES_UNPACK -> fprintf ppf "BYTES_UNPACK"
| C_CONS -> fprintf ppf "CONS"
(* Pair *)
| C_PAIR -> fprintf ppf "PAIR"
| C_CAR -> fprintf ppf "CAR"
| C_CDR -> fprintf ppf "CDR"
| C_LEFT -> fprintf ppf "LEFT"
| C_RIGHT -> fprintf ppf "RIGHT"
(* Set *)
| C_SET_EMPTY -> fprintf ppf "SET_EMPTY"
| C_SET_LITERAL -> fprintf ppf "SET_LITERAL"
| C_SET_ADD -> fprintf ppf "SET_ADD"
| C_SET_REMOVE -> fprintf ppf "SET_REMOVE"
| C_SET_ITER -> fprintf ppf "SET_ITER"
| C_SET_FOLD -> fprintf ppf "SET_FOLD"
| C_SET_MEM -> fprintf ppf "SET_MEM"
(* List *)
| C_LIST_ITER -> fprintf ppf "LIST_ITER"
| C_LIST_MAP -> fprintf ppf "LIST_MAP"
| C_LIST_FOLD -> fprintf ppf "LIST_FOLD"
| C_LIST_CONS -> fprintf ppf "LIST_CONS"
(* Maps *)
| C_MAP -> fprintf ppf "MAP"
| C_MAP_EMPTY -> fprintf ppf "MAP_EMPTY"
| C_MAP_LITERAL -> fprintf ppf "MAP_LITERAL"
| C_MAP_GET -> fprintf ppf "MAP_GET"
| C_MAP_GET_FORCE -> fprintf ppf "MAP_GET_FORCE"
| C_MAP_ADD -> fprintf ppf "MAP_ADD"
| C_MAP_REMOVE -> fprintf ppf "MAP_REMOVE"
| C_MAP_UPDATE -> fprintf ppf "MAP_UPDATE"
| C_MAP_ITER -> fprintf ppf "MAP_ITER"
| C_MAP_MAP -> fprintf ppf "MAP_MAP"
| C_MAP_FOLD -> fprintf ppf "MAP_FOLD"
| C_MAP_MEM -> fprintf ppf "MAP_MEM"
| C_MAP_FIND -> fprintf ppf "MAP_FIND"
| C_MAP_FIND_OPT -> fprintf ppf "MAP_FIND_OP"
(* Big Maps *)
| C_BIG_MAP -> fprintf ppf "BIG_MAP"
| C_BIG_MAP_EMPTY -> fprintf ppf "BIG_MAP_EMPTY"
| C_BIG_MAP_LITERAL -> fprintf ppf "BIG_MAP_LITERAL"
(* Crypto *)
| C_SHA256 -> fprintf ppf "SHA256"
| C_SHA512 -> fprintf ppf "SHA512"
| C_BLAKE2b -> fprintf ppf "BLAKE2b"
| C_HASH -> fprintf ppf "HASH"
| C_HASH_KEY -> fprintf ppf "HASH_KEY"
| C_CHECK_SIGNATURE -> fprintf ppf "CHECK_SIGNATURE"
| C_CHAIN_ID -> fprintf ppf "CHAIN_ID"
(* Blockchain *)
| C_CALL -> fprintf ppf "CALL"
| C_CONTRACT -> fprintf ppf "CONTRACT"
| C_CONTRACT_ENTRYPOINT -> fprintf ppf "CONTRACT_ENTRYPOINT"
| C_AMOUNT -> fprintf ppf "AMOUNT"
| C_BALANCE -> fprintf ppf "BALANCE"
| C_SOURCE -> fprintf ppf "SOURCE"
| C_SENDER -> fprintf ppf "SENDER"
| C_ADDRESS -> fprintf ppf "ADDRESS"
| C_SELF_ADDRESS -> fprintf ppf "SELF_ADDRESS"
| C_IMPLICIT_ACCOUNT -> fprintf ppf "IMPLICIT_ACCOUNT"
| C_STEPS_TO_QUOTA -> fprintf ppf "STEPS_TO_QUOTA"
let cmap_sep value sep ppf m =
let lst = Types.CMap.to_kv_list m in
let new_pp ppf (k, v) = fprintf ppf "%a -> %a" constructor k value v in
fprintf ppf "%a" (list_sep new_pp sep) lst
let lmap_sep value sep ppf m =
let lst = Types.LMap.to_kv_list m in
let new_pp ppf (k, v) = fprintf ppf "%a -> %a" label k value v in
fprintf ppf "%a" (list_sep new_pp sep) lst
let list_sep_d x = list_sep x (const " , ")
let cmap_sep_d x = cmap_sep x (const " , ")
let lmap_sep_d x = lmap_sep x (const " , ")
let rec type_expression' : type a . (formatter -> a -> unit) -> formatter -> a type_expression' -> unit =
fun f ppf te ->
match te with
| T_tuple lst -> fprintf ppf "tuple[%a]" (list_sep_d f) lst
| T_sum m -> fprintf ppf "sum[%a]" (cmap_sep_d f) m
| T_record m -> fprintf ppf "record[%a]" (lmap_sep_d f ) m
| T_arrow (a, b) -> fprintf ppf "%a -> %a" f a f b
| T_variable tv -> type_variable ppf tv
| T_constant tc -> type_constant ppf tc
| T_operator to_ -> type_operator f ppf to_
and type_constant ppf (tc:type_constant) : unit =
let s = match tc with
| TC_unit -> "unit"
| TC_string -> "string"
| TC_bytes -> "bytes"
| TC_nat -> "nat"
| TC_int -> "int"
| TC_mutez -> "mutez"
| TC_bool -> "bool"
| TC_operation -> "operation"
| TC_address -> "address"
| TC_key -> "key"
| TC_key_hash -> "key_hash"
| TC_signature -> "signatuer"
| TC_timestamp -> "timestamp"
| TC_chain_id -> "chain_id"
in
fprintf ppf "(TC %s)" s
and type_operator : type a . (formatter -> a -> unit) -> formatter -> a type_operator -> unit =
fun f ppf to_ ->
let s = match to_ with
| TC_option (tv) -> Format.asprintf "option(%a)" f tv
| TC_list (tv) -> Format.asprintf "list(%a)" f tv
| TC_set (tv) -> Format.asprintf "set(%a)" f tv
| 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 (c) -> Format.asprintf "Contract (%a)" f c
in
fprintf ppf "(TO_%s)" s
let literal ppf (l:literal) = match l with
| Literal_unit -> fprintf ppf "Unit"
| Literal_bool b -> fprintf ppf "%b" b
| Literal_int n -> fprintf ppf "%d" n
| Literal_nat n -> fprintf ppf "+%d" n
| Literal_timestamp n -> fprintf ppf "+%d" n
| Literal_mutez n -> fprintf ppf "%dmutez" n
| Literal_string s -> fprintf ppf "%S" s
| Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b
| Literal_address s -> fprintf ppf "@%S" s
| Literal_operation _ -> fprintf ppf "Operation(...bytes)"
| Literal_key s -> fprintf ppf "key %s" s
| Literal_key_hash s -> fprintf ppf "key_hash %s" s
| Literal_signature s -> fprintf ppf "Signature %s" s
| Literal_chain_id s -> fprintf ppf "Chain_id %s" s

14
src/stages/common/PP.mli Normal file
View File

@ -0,0 +1,14 @@
open Types
open Format
val name : formatter -> expression_variable -> unit
val type_variable : formatter -> type_variable -> unit
val constructor : formatter -> constructor -> unit
val label : formatter -> label -> unit
val constant : formatter -> constant -> unit
val cmap_sep : (formatter -> 'a -> unit) -> (formatter -> unit -> unit) -> formatter -> 'a CMap.t -> unit
val lmap_sep : (formatter -> 'a -> unit) -> (formatter -> unit -> unit) -> formatter -> 'a LMap.t -> unit
val type_expression' : (formatter -> 'a -> unit) -> formatter -> 'a type_expression' -> unit
val type_operator : (formatter -> 'a -> unit) -> formatter -> 'a type_operator -> unit
val type_constant : formatter -> type_constant -> unit
val literal : formatter -> literal -> unit

2
src/stages/common/ast_common.ml Normal file
View File

@ -0,0 +1,2 @@
module Types = Types
module PP = PP

12
src/stages/common/dune Normal file
View File

@ -0,0 +1,12 @@
(library
(name stage_common)
(public_name ligo.stage_common)
(libraries
simple-utils
tezos-utils
)
(preprocess
(pps ppx_let)
)
(flags (:standard -open Simple_utils))
)

235
src/stages/common/types.ml Normal file
View File

@ -0,0 +1,235 @@
type expression_
type type_
type expression_variable = expression_ Var.t
type type_variable = type_ Var.t
type constructor = Constructor of string
type label = Label of string
module CMap = Map.Make( struct type t = constructor let compare (Constructor a) (Constructor b) = compare a b end)
module LMap = Map.Make( struct type t = label let compare (Label a) (Label b) = String.compare a b end)
type 'a label_map = 'a LMap.t
type 'a constructor_map = 'a CMap.t
let bind_lmap (l:_ label_map) =
let open Trace in
let open LMap in
let aux k v prev =
prev >>? fun prev' ->
v >>? fun v' ->
ok @@ add k v' prev' in
fold aux l (ok empty)
let bind_cmap (c:_ constructor_map) =
let open Trace in
let open CMap in
let aux k v prev =
prev >>? fun prev' ->
v >>? fun v' ->
ok @@ add k v' prev' in
fold aux c (ok empty)
let bind_fold_lmap f init (lmap:_ LMap.t) =
let open Trace in
let aux k v prev =
prev >>? fun prev' ->
f prev' k v
in
LMap.fold aux lmap init
let bind_map_lmap f map = bind_lmap (LMap.map f map)
let bind_map_cmap f map = bind_cmap (CMap.map f map)
type access =
| Access_tuple of int
| Access_record of string
and access_path = access list
and literal =
| Literal_unit
| Literal_bool of bool
| Literal_int of int
| Literal_nat of int
| Literal_timestamp of int
| Literal_mutez of int
| Literal_string of string
| Literal_bytes of bytes
| Literal_address of string
| Literal_signature of string
| Literal_key of string
| Literal_key_hash of string
| Literal_chain_id of string
| Literal_operation of Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation
(* The ast is a tree of node, 'a is the type of the node (type_variable or {type_variable, previous_type}) *)
type 'a type_expression' =
| T_tuple of 'a list
| T_sum of 'a constructor_map
| T_record of 'a label_map
| T_arrow of 'a * 'a
| T_variable of type_variable
| T_constant of type_constant
| T_operator of 'a type_operator
and type_constant =
| TC_unit
| TC_string
| TC_bytes
| TC_nat
| TC_int
| TC_mutez
| TC_bool
| TC_operation
| TC_address
| TC_key
| TC_key_hash
| TC_chain_id
| TC_signature
| TC_timestamp
and 'a type_operator =
| TC_contract of 'a
| TC_option of 'a
| TC_list of 'a
| TC_set of 'a
| TC_map of 'a * 'a
| TC_big_map of 'a * 'a
type type_base =
| Base_unit
| Base_string
| Base_bytes
| Base_nat
| Base_int
| Base_mutez
| Base_bool
| Base_operation
| Base_address
| Base_void
| Base_timestamp
| Base_signature
| Base_key
| Base_key_hash
| Base_chain_id
and ('a,'tv) matching =
| Match_bool of {
match_true : 'a ;
match_false : 'a ;
}
| Match_list of {
match_nil : 'a ;
match_cons : expression_variable * expression_variable * 'a * 'tv;
}
| Match_option of {
match_none : 'a ;
match_some : expression_variable * 'a * 'tv;
}
| Match_tuple of (expression_variable list * 'a) * 'tv list
| Match_variant of ((constructor * expression_variable) * 'a) list * 'tv
type constant =
| C_INT
| C_UNIT
| C_NIL
| C_NOW
| C_IS_NAT
| C_SOME
| C_NONE
| C_ASSERTION
| C_ASSERT_INFERRED
| C_FAILWITH
| C_UPDATE
(* Loops *)
| C_ITER
| C_FOLD_WHILE
| C_CONTINUE
| C_STOP
| C_FOLD
(* MATH *)
| C_NEG
| C_ABS
| C_ADD
| C_SUB
| C_MUL
| C_DIV
| C_MOD
(* LOGIC *)
| C_NOT
| C_AND
| C_OR
| C_XOR
(* COMPARATOR *)
| C_EQ
| C_NEQ
| C_LT
| C_GT
| C_LE
| C_GE
(* Bytes/ String *)
| C_SIZE
| C_CONCAT
| C_SLICE
| C_BYTES_PACK
| C_BYTES_UNPACK
| C_CONS
(* Pair *)
| C_PAIR
| C_CAR
| C_CDR
| C_LEFT
| C_RIGHT
(* Set *)
| C_SET_EMPTY
| C_SET_LITERAL
| C_SET_ADD
| C_SET_REMOVE
| C_SET_ITER
| C_SET_FOLD
| C_SET_MEM
(* List *)
| C_LIST_ITER
| C_LIST_MAP
| C_LIST_FOLD
| C_LIST_CONS
(* Maps *)
| C_MAP
| C_MAP_EMPTY
| C_MAP_LITERAL
| C_MAP_GET
| C_MAP_GET_FORCE
| C_MAP_ADD
| C_MAP_REMOVE
| C_MAP_UPDATE
| C_MAP_ITER
| C_MAP_MAP
| C_MAP_FOLD
| C_MAP_MEM
| C_MAP_FIND
| C_MAP_FIND_OPT
(* Big Maps *)
| C_BIG_MAP
| C_BIG_MAP_EMPTY
| C_BIG_MAP_LITERAL
(* Crypto *)
| C_SHA256
| C_SHA512
| C_BLAKE2b
| C_HASH
| C_HASH_KEY
| C_CHECK_SIGNATURE
| C_CHAIN_ID
(* Blockchain *)
| C_CALL
| C_CONTRACT
| C_CONTRACT_ENTRYPOINT
| C_AMOUNT
| C_BALANCE
| C_SOURCE
| C_SENDER
| C_ADDRESS
| C_SELF_ADDRESS
| C_IMPLICIT_ACCOUNT
| C_STEPS_TO_QUOTA

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

@ -1,6 +1,7 @@
open Simple_utils.PP_helpers
open Types
open Format
include Stage_common.PP
let list_sep_d x = list_sep x (const " , ")
@ -14,7 +15,7 @@ let type_base ppf : type_base -> _ = function
| Base_bool -> fprintf ppf "bool"
| Base_int -> fprintf ppf "int"
| Base_nat -> fprintf ppf "nat"
| Base_tez -> fprintf ppf "tez"
| Base_mutez -> fprintf ppf "tez"
| Base_string -> fprintf ppf "string"
| Base_address -> fprintf ppf "address"
| Base_timestamp -> fprintf ppf "timestamp"
@ -25,24 +26,24 @@ let type_base ppf : type_base -> _ = function
| Base_key_hash -> fprintf ppf "key_hash"
| Base_chain_id -> fprintf ppf "chain_id"
let rec type_ ppf : type_value -> _ = function
let rec type_variable ppf : type_value -> _ = function
| T_or(a, b) -> fprintf ppf "(%a) | (%a)" annotated a annotated b
| T_pair(a, b) -> fprintf ppf "(%a) & (%a)" annotated a annotated b
| T_base b -> type_base ppf b
| T_function(a, b) -> fprintf ppf "(%a) -> (%a)" type_ a type_ b
| T_map(k, v) -> fprintf ppf "map(%a -> %a)" type_ k type_ v
| T_big_map(k, v) -> fprintf ppf "big_map(%a -> %a)" type_ k type_ v
| T_list(t) -> fprintf ppf "list(%a)" type_ t
| T_set(t) -> fprintf ppf "set(%a)" type_ t
| T_option(o) -> fprintf ppf "option(%a)" type_ o
| T_contract(t) -> fprintf ppf "contract(%a)" type_ t
| T_function(a, b) -> fprintf ppf "(%a) -> (%a)" type_variable a type_variable b
| T_map(k, v) -> fprintf ppf "map(%a -> %a)" type_variable k type_variable v
| T_big_map(k, v) -> fprintf ppf "big_map(%a -> %a)" type_variable k type_variable v
| T_list(t) -> fprintf ppf "list(%a)" type_variable t
| T_set(t) -> fprintf ppf "set(%a)" type_variable t
| T_option(o) -> fprintf ppf "option(%a)" type_variable o
| T_contract(t) -> fprintf ppf "contract(%a)" type_variable t
and annotated ppf : type_value annotated -> _ = function
| (Some ann, a) -> fprintf ppf "(%a %%%s)" type_ a ann
| (None, a) -> type_ ppf a
| (Some ann, a) -> fprintf ppf "(%a %%%s)" type_variable a ann
| (None, a) -> type_variable ppf a
and environment_element ppf ((s, tv) : environment_element) =
Format.fprintf ppf "%a : %a" Var.pp s type_ tv
and environment_element ppf ((n, tv) : environment_element) =
Format.fprintf ppf "%a : %a" Stage_common.PP.name n type_variable tv
and environment ppf (x:environment) =
fprintf ppf "Env[%a]" (list_sep_d environment_element) x
@ -75,9 +76,9 @@ and value_assoc ppf : (value * value) -> unit = fun (a, b) ->
and expression' ppf (e:expression') = match e with
| E_skip -> fprintf ppf "skip"
| E_closure x -> fprintf ppf "C(%a)" function_ x
| E_variable v -> fprintf ppf "V(%a)" Var.pp v
| E_variable v -> fprintf ppf "V(%a)" Stage_common.PP.name v
| E_application(a, b) -> fprintf ppf "(%a)@(%a)" expression a expression b
| E_constant(p, lst) -> fprintf ppf "%s %a" p (pp_print_list ~pp_sep:space_sep expression) lst
| E_constant(p, lst) -> fprintf ppf "%a %a" Stage_common.PP.constant p (pp_print_list ~pp_sep:space_sep expression) lst
| E_literal v -> fprintf ppf "L(%a)" value v
| E_make_empty_map _ -> fprintf ppf "map[]"
| E_make_empty_big_map _ -> fprintf ppf "big_map[]"
@ -85,25 +86,19 @@ and expression' ppf (e:expression') = match e with
| E_make_empty_set _ -> fprintf ppf "set[]"
| E_make_none _ -> fprintf ppf "none"
| E_if_bool (c, a, b) -> fprintf ppf "%a ? %a : %a" expression c expression a expression b
| E_if_none (c, n, ((name, _) , s)) ->
fprintf ppf "%a ?? %a : %a -> %a"
expression c expression n Var.pp name expression s
| E_if_cons (c, n, (((hd_name, _) , (tl_name, _)) , cons)) ->
fprintf ppf "%a ?? %a : (%a :: %a) -> %a"
expression c expression n Var.pp hd_name Var.pp tl_name expression cons
| E_if_none (c, n, ((name, _) , s)) -> fprintf ppf "%a ?? %a : %a -> %a" expression c expression n Stage_common.PP.name name expression s
| E_if_cons (c, n, (((hd_name, _) , (tl_name, _)) , cons)) -> fprintf ppf "%a ?? %a : (%a :: %a) -> %a" expression c expression n Stage_common.PP.name hd_name Stage_common.PP.name tl_name expression cons
| E_if_left (c, ((name_l, _) , l), ((name_r, _) , r)) ->
fprintf ppf "%a ?? %a -> %a : %a -> %a"
expression c Var.pp name_l expression l Var.pp name_r expression r
fprintf ppf "%a ?? %a -> %a : %a -> %a" expression c Stage_common.PP.name name_l expression l Stage_common.PP.name name_r expression r
| E_sequence (a , b) -> fprintf ppf "%a ;; %a" expression a expression b
| E_let_in ((name , _) , expr , body) ->
fprintf ppf "let %a = %a in ( %a )" Var.pp name expression expr expression body
| E_iterator (s , ((name , _) , body) , expr) ->
fprintf ppf "for_%s %a of %a do ( %a )" s Var.pp name expression expr expression body
fprintf ppf "let %a = %a in ( %a )" Stage_common.PP.name name expression expr expression body
| E_iterator (b , ((name , _) , body) , expr) ->
fprintf ppf "for_%a %a of %a do ( %a )" Stage_common.PP.constant b Stage_common.PP.name name expression expr expression body
| E_fold (((name , _) , body) , collection , initial) ->
fprintf ppf "fold %a on %a with %a do ( %a )"
expression collection expression initial Var.pp name expression body
fprintf ppf "fold %a on %a with %a do ( %a )" expression collection expression initial Stage_common.PP.name name expression body
| E_assignment (r , path , e) ->
fprintf ppf "%a.%a := %a" Var.pp r (list_sep lr (const ".")) path expression e
fprintf ppf "%a.%a := %a" Stage_common.PP.name r (list_sep lr (const ".")) path expression e
| E_while (e , b) ->
fprintf ppf "while (%a) %a" expression e expression b
@ -113,16 +108,16 @@ and expression : _ -> expression -> _ = fun ppf e ->
and expression_with_type : _ -> expression -> _ = fun ppf e ->
fprintf ppf "%a : %a"
expression' e.content
type_ e.type_value
type_variable e.type_value
and function_ ppf ({binder ; body}:anon_function) =
fprintf ppf "fun %a -> (%a)"
Var.pp binder
Stage_common.PP.name binder
expression body
and assignment ppf ((n, e):assignment) = fprintf ppf "%a = %a;" Var.pp n expression e
and assignment ppf ((n, e):assignment) = fprintf ppf "%a = %a;" Stage_common.PP.name n expression e
and declaration ppf ((n, e):assignment) = fprintf ppf "let %a = %a;" Var.pp n expression e
and declaration ppf ((n, e):assignment) = fprintf ppf "let %a = %a;" Stage_common.PP.name n expression e
let tl_statement ppf (ass, _) = assignment ppf ass

2
src/stages/mini_c/PP.mli
View File

@ -8,7 +8,7 @@ val lr : formatter -> [< `Left ] -> unit
val type_base : formatter -> type_base -> unit
*)
val type_ : formatter -> type_value -> unit
val type_variable : formatter -> type_value -> unit
val environment_element : formatter -> environment_element -> unit
val environment : formatter -> environment -> unit
val value : formatter -> value -> unit

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

@ -18,7 +18,7 @@ module Expression = struct
type_value = t ;
}
let pair : t -> t -> t' = fun a b -> E_constant ("PAIR" , [ a ; b ])
let pair : t -> t -> t' = fun a b -> E_constant (C_PAIR , [ a ; b ])
end
@ -136,7 +136,7 @@ let get_or (v:value) = match v with
let wrong_type name t =
let title () = "not a " ^ name in
let content () = Format.asprintf "%a" PP.type_ t in
let content () = Format.asprintf "%a" PP.type_variable t in
error title content
let get_t_left t = match t with

4
src/stages/mini_c/combinators.mli
View File

@ -66,8 +66,8 @@ val e_int : Expression.t' -> Expression.t
*)
val e_unit : Expression.t
val e_skip : Expression.t
val e_var_int : Var.t -> Expression.t
val e_let_in : Var.t -> type_value -> Expression.t -> Expression.t -> Expression.t
val e_var_int : expression_variable -> Expression.t
val e_let_in : expression_variable -> type_value -> Expression.t -> Expression.t -> Expression.t
val ez_e_sequence : Expression.t' -> Expression.t -> expression
(*

6
src/stages/mini_c/combinators_smart.ml Normal file
View File

@ -0,0 +1,6 @@
open Types
open Combinators
let basic_int_quote_env : environment =
let e = Environment.empty in
Environment.add (Var.of_name "input", t_int) e

1
src/stages/mini_c/dune
View File

@ -4,6 +4,7 @@
(libraries
simple-utils
tezos-utils
stage_common
)
(inline_tests)
(preprocess (pps ppx_expect ppx_let))

10
src/stages/mini_c/environment.ml
View File

@ -21,18 +21,18 @@ module Environment (* : ENVIRONMENT *) = struct
let empty : t = []
let add : element -> t -> t = List.cons
let concat : t list -> t = List.concat
let get_opt : Var.t -> t -> type_value option = List.assoc_opt ~compare:Var.compare
let has : Var.t -> t -> bool = fun s t ->
let get_opt : expression_variable -> t -> type_value option = List.assoc_opt ~compare:Var.compare
let has : expression_variable -> t -> bool = fun s t ->
match get_opt s t with
| None -> false
| Some _ -> true
let get_i : Var.t -> t -> (type_value * int) = List.assoc_i ~compare:Var.compare
let get_i : expression_variable -> t -> (type_value * int) = List.assoc_i ~compare:Var.compare
let of_list : element list -> t = fun x -> x
let to_list : t -> element list = fun x -> x
let get_names : t -> Var.t list = List.map fst
let get_names : t -> expression_variable list = List.map fst
let remove : int -> t -> t = List.remove
let select ?(rev = false) ?(keep = true) : Var.t list -> t -> t = fun lst env ->
let select ?(rev = false) ?(keep = true) : expression_variable list -> t -> t = fun lst env ->
let e_lst =
let e_lst = to_list env in
let aux selector (s , _) =

10
src/stages/mini_c/environment.mli
View File

@ -14,12 +14,12 @@ module Environment : sig
val get_opt : Var.t -> t -> type_value option
val has : Var.t -> t -> bool
*)
val get_i : Var.t -> t -> (type_value * int)
val get_i : expression_variable -> t -> (type_value * int)
val of_list : element list -> t
val to_list : t -> element list
val get_names : t -> Var.t list
val get_names : t -> expression_variable list
val remove : int -> t -> t
val select : ?rev:bool -> ?keep:bool -> Var.t list -> t -> t
val select : ?rev:bool -> ?keep:bool -> expression_variable list -> t -> t
(*
val fold : ('a -> element -> 'a ) -> 'a -> t -> 'a
val filter : ( element -> bool ) -> t -> t
@ -38,7 +38,7 @@ val concat : t list -> t
(*
val get_opt : Var.t -> t -> type_value option
*)
val has : Var.t -> t -> bool
val has : expression_variable -> t -> bool
(*
val get_i : Var.t -> t -> (type_value * int)
*)
@ -49,7 +49,7 @@ val get_names : t -> Var.t list
val remove : int -> t -> t
*)
val select : ?rev:bool -> ?keep:bool -> Var.t list -> t -> t
val select : ?rev:bool -> ?keep:bool -> expression_variable list -> t -> t
val fold : ('a -> element -> 'a ) -> 'a -> t -> 'a
val filter : ( element -> bool ) -> t -> t

10
src/stages/mini_c/misc.ml
View File

@ -24,16 +24,16 @@ end
module Free_variables = struct
type bindings = Var.t list
let mem : Var.t -> bindings -> bool = List.memq ~eq:Var.equal
let mem_count : Var.t -> bindings -> int =
type bindings = expression_variable list
let mem : expression_variable -> bindings -> bool = List.mem
let singleton : expression_variable -> bindings = fun s -> [ s ]
let mem_count : expression_variable -> bindings -> int =
fun x fvs ->
List.length (List.filter (Var.equal x) fvs)
let singleton : Var.t -> bindings = fun s -> [ s ]
let union : bindings -> bindings -> bindings = (@)
let unions : bindings list -> bindings = List.concat
let empty : bindings = []
let of_list : Var.t list -> bindings = fun x -> x
let of_list : expression_variable list -> bindings = fun x -> x
let rec expression : bindings -> expression -> bindings = fun b e ->
let self = expression b in

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

@ -1,13 +1,5 @@
type type_name = string
include Stage_common.Types
type type_base =
| Base_unit | Base_void
| Base_bool
| Base_int | Base_nat | Base_tez
| Base_timestamp
| Base_string | Base_bytes | Base_address | Base_key
| Base_operation | Base_signature
| Base_chain_id | Base_key_hash
type 'a annotated = string option * 'a
@ -23,7 +15,7 @@ type type_value =
| T_contract of type_value
| T_option of type_value
and environment_element = Var.t * type_value
and environment_element = expression_variable * type_value
and environment = environment_element list
@ -32,8 +24,8 @@ type environment_wrap = {
post_environment : environment ;
}
type var_name = Var.t
type fun_name = Var.t
type var_name = expression_variable
type fun_name = expression_variable
type value =
| D_unit
@ -62,7 +54,7 @@ and expression' =
| E_literal of value
| E_closure of anon_function
| E_skip
| E_constant of string * expression list
| E_constant of constant * expression list
| E_application of (expression * expression)
| E_variable of var_name
| E_make_empty_map of (type_value * type_value)
@ -70,7 +62,7 @@ and expression' =
| E_make_empty_list of type_value
| E_make_empty_set of type_value
| E_make_none of type_value
| E_iterator of (string * ((var_name * type_value) * expression) * expression)
| E_iterator of (constant * ((var_name * type_value) * expression) * expression)
| E_fold of (((var_name * type_value) * expression) * expression * expression)
| E_if_bool of (expression * expression * expression)
| E_if_none of expression * expression * ((var_name * type_value) * expression)
@ -78,7 +70,7 @@ and expression' =
| E_if_left of expression * ((var_name * type_value) * expression) * ((var_name * type_value) * expression)
| E_let_in of ((var_name * type_value) * expression * expression)
| E_sequence of (expression * expression)
| E_assignment of (var_name * [`Left | `Right] list * expression)
| E_assignment of (expression_variable * [`Left | `Right] list * expression)
| E_while of (expression * expression)
and expression = {
@ -91,7 +83,7 @@ and assignment = var_name * expression
and toplevel_statement = assignment * environment_wrap
and anon_function = {
binder : var_name ;
binder : expression_variable ;
body : expression ;
}

17
src/stages/typesystem/core.ml
View File

@ -1,14 +1,9 @@
type type_variable = (*Type_variable *) string
include Stage_common.Types
(* generate a new type variable and gave it an id *)
let fresh_type_variable : ?name:string -> unit -> type_variable =
let id = ref 0 in
let inc () = id := !id + 1 in
fun ?name () ->
inc () ;
match name with
| None -> (*Type_variable*) "type_variable_" ^ (string_of_int !id)
| Some name -> (*Type_variable*)"tv_" ^ name ^ "_" ^ (string_of_int !id)
Var.fresh
(* add information on the type or the kind for operator*)
@ -26,7 +21,7 @@ type constant_tag =
| C_bool (* * *)
| C_string (* * *)
| C_nat (* * *)
| C_tez (* * *)
| C_mutez (* * *)
| C_timestamp (* * *)
| C_int (* * *)
| C_address (* * *)
@ -37,7 +32,7 @@ type constant_tag =
| C_operation (* * *)
| C_contract (* * -> * *)
type label =
type accessor =
| L_int of int
| L_string of string
@ -60,7 +55,7 @@ and simple_c_constant = (constant_tag) (* for type constructors that do not take
and c_const = (type_variable * type_value)
and c_equation = (type_value * type_value)
and c_typeclass = (type_value list * typeclass)
and c_access_label = (type_value * label * type_variable)
and c_access_label = (type_value * accessor * type_variable)
(*What i was saying just before *)
and type_constraint =

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

@ -8,7 +8,7 @@ module Substitution = struct
open Trace
module T = Ast_typed
module TSMap = Trace.TMap(String)
(* module TSMap = Trace.TMap(String) *)
type 'a w = 'a -> 'a result
@ -17,17 +17,15 @@ module Substitution = struct
| T.ED_binder -> ok @@ T.ED_binder
| T.ED_declaration (val_, free_variables) ->
let%bind val_ = s_annotated_expression ~v ~expr val_ in
let%bind free_variables = bind_map_list (s_type_variable ~v ~expr) free_variables in
let%bind free_variables = bind_map_list (s_variable ~v ~expr) free_variables in
ok @@ T.ED_declaration (val_, free_variables)
and s_environment ~v ~expr = fun lst ->
bind_map_list (fun (type_variable, T.{ type_value; source_environment; definition }) ->
let _ = type_value in
let%bind type_variable = s_type_variable ~v ~expr type_variable in
and s_environment ~v ~expr : T.environment w = fun env ->
bind_map_list (fun (variable, T.{ type_value; source_environment; definition }) ->
let%bind variable = s_variable ~v ~expr variable in
let%bind type_value = s_type_value ~v ~expr type_value in
let%bind source_environment = s_full_environment ~v ~expr source_environment in
let%bind definition = s_environment_element_definition ~v ~expr definition in
ok @@ (type_variable, T.{ type_value; source_environment; definition })
) lst
ok @@ (variable, T.{ type_value; source_environment; definition })) env
and s_type_environment ~v ~expr : T.type_environment w = fun tenv ->
bind_map_list (fun (type_variable , type_value) ->
let%bind type_variable = s_type_variable ~v ~expr type_variable in
@ -42,11 +40,11 @@ module Substitution = struct
let%bind b = bind_map_list (s_small_environment ~v ~expr) b in
ok (a , b)
and s_variable ~v ~expr : T.name w = fun var ->
and s_variable ~v ~expr : T.expression_variable w = fun var ->
let () = ignore (v, expr) in
ok var
and s_type_variable ~v ~expr : T.name w = fun tvar ->
and s_type_variable ~v ~expr : T.type_variable w = fun tvar ->
let _TODO = ignore (v, expr) in
Printf.printf "TODO: subst: unimplemented case s_type_variable";
ok @@ tvar
@ -54,8 +52,19 @@ module Substitution = struct
* expr
* else
* ok tvar *)
and s_label ~v ~expr : T.label w = fun l ->
let () = ignore (v, expr) in
ok l
and s_type_name_constant ~v ~expr : T.type_name w = fun type_name ->
and s_build_in ~v ~expr : T.constant w = fun b ->
let () = ignore (v, expr) in
ok b
and s_constructor ~v ~expr : T.constructor w = fun c ->
let () = ignore (v, expr) in
ok c
and s_type_name_constant ~v ~expr : T.type_constant w = fun type_name ->
(* TODO: we don't need to subst anything, right? *)
let () = ignore (v , expr) in
ok @@ type_name
@ -66,24 +75,26 @@ module Substitution = struct
ok @@ T.T_tuple type_value_list
| T.T_sum _ -> failwith "TODO: T_sum"
| T.T_record _ -> failwith "TODO: T_record"
| T.T_constant (type_name, type_value_list) ->
| T.T_constant (type_name) ->
let%bind type_name = s_type_name_constant ~v ~expr type_name in
let%bind type_value_list = bind_map_list (s_type_value ~v ~expr) type_value_list in
ok @@ T.T_constant (type_name, type_value_list)
ok @@ T.T_constant (type_name)
| T.T_variable _ -> failwith "TODO: T_variable"
| T.T_function _ ->
| T.T_operator _ -> failwith "TODO: T_operator"
| T.T_arrow _ ->
let _TODO = (v, expr) in
failwith "TODO: T_function"
and s_type_expression ~v ~expr : Ast_simplified.type_expression w = function
| Ast_simplified.T_tuple _ -> failwith "TODO: subst: unimplemented case s_type_expression"
| Ast_simplified.T_sum _ -> failwith "TODO: subst: unimplemented case s_type_expression"
| Ast_simplified.T_record _ -> failwith "TODO: subst: unimplemented case s_type_expression"
| Ast_simplified.T_function (_, _) -> failwith "TODO: subst: unimplemented case s_type_expression"
| Ast_simplified.T_variable _ -> failwith "TODO: subst: unimplemented case s_type_expression"
| Ast_simplified.T_constant (_, _) ->
let _TODO = (v, expr) in
failwith "TODO: subst: unimplemented case s_type_expression"
and s_type_expression ~v ~expr : Ast_simplified.type_expression w = fun {type_expression'} ->
match type_expression' with
| Ast_simplified.T_tuple _ -> failwith "TODO: subst: unimplemented case s_type_expression"
| Ast_simplified.T_sum _ -> failwith "TODO: subst: unimplemented case s_type_expression"
| Ast_simplified.T_record _ -> failwith "TODO: subst: unimplemented case s_type_expression"
| Ast_simplified.T_arrow (_, _) -> failwith "TODO: subst: unimplemented case s_type_expression"
| Ast_simplified.T_variable _ -> failwith "TODO: subst: unimplemented case s_type_expression"
| Ast_simplified.T_operator _ -> failwith "TODO: subst: unimplemented case s_type_expression"
| Ast_simplified.T_constant _ ->
let _TODO = (v, expr) in
failwith "TODO: subst: unimplemented case s_type_expression"
and s_type_value ~v ~expr : T.type_value w = fun { type_value'; simplified } ->
let%bind type_value' = s_type_value' ~v ~expr type_value' in
@ -122,7 +133,7 @@ module Substitution = struct
let%bind x = s_literal ~v ~expr x in
ok @@ T.E_literal x
| T.E_constant (var, vals) ->
let%bind var = s_variable ~v ~expr var in
let%bind var = s_build_in ~v ~expr var in
let%bind vals = bind_map_list (s_annotated_expression ~v ~expr) vals in
ok @@ T.E_constant (var, vals)
| T.E_variable tv ->
@ -149,7 +160,7 @@ module Substitution = struct
let i = i in
ok @@ T.E_tuple_accessor (val_, i)
| T.E_constructor (tvar, val_) ->
let%bind tvar = s_type_variable ~v ~expr tvar in
let%bind tvar = s_constructor ~v ~expr tvar in
let%bind val_ = s_annotated_expression ~v ~expr val_ in
ok @@ T.E_constructor (tvar, val_)
| T.E_record aemap ->
@ -160,10 +171,10 @@ module Substitution = struct
* let val_ = s_annotated_expression ~v ~expr val_ in
* ok @@ (key , val_)) aemap in
* ok @@ T.E_record aemap *)
| T.E_record_accessor (val_, tvar) ->
| T.E_record_accessor (val_, l) ->
let%bind val_ = s_annotated_expression ~v ~expr val_ in
let%bind tvar = s_type_variable ~v ~expr tvar in
ok @@ T.E_record_accessor (val_, tvar)
let%bind l = s_label ~v ~expr l in
ok @@ T.E_record_accessor (val_, l)
| T.E_map val_val_list ->
let%bind val_val_list = bind_map_list (fun (val1 , val2) ->
let%bind val1 = s_annotated_expression ~v ~expr val1 in
@ -214,7 +225,7 @@ module Substitution = struct
ok T.{ expression; type_annotation; environment; location }
and s_named_expression ~v ~expr : T.named_expression w = fun { name; annotated_expression } ->
let%bind name = s_type_variable ~v ~expr name in
let%bind name = s_variable ~v ~expr name in
let%bind annotated_expression = s_annotated_expression ~v ~expr annotated_expression in
ok T.{ name; annotated_expression }
@ -231,7 +242,7 @@ module Substitution = struct
(* Replace the type variable ~v with ~expr everywhere within the
program ~p. TODO: issues with scoping/shadowing. *)
and program ~(p : Ast_typed.program) ~(v:string (* this string is a type_name or type_variable I think *)) ~expr : Ast_typed.program Trace.result =
and program ~(p : Ast_typed.program) ~(v:type_variable) ~expr : Ast_typed.program Trace.result =
Trace.bind_map_list (s_declaration_wrap ~v ~expr) p
(*

2
src/stages/typesystem/shorthands.ml
View File

@ -50,7 +50,7 @@ let set t = P_constant (C_set , [t])
let bool = P_constant (C_bool , [])
let string = P_constant (C_string , [])
let nat = P_constant (C_nat , [])
let tez = P_constant (C_tez , [])
let mutez = P_constant (C_mutez , [])
let timestamp = P_constant (C_timestamp , [])
let int = P_constant (C_int , [])
let address = P_constant (C_address , [])

2
src/test/multisig_tests.ml
View File

@ -38,7 +38,7 @@ let init_storage threshold counter pkeys =
let empty_op_list =
(e_typed_list [] t_operation)
let empty_message = e_lambda "arguments"
let empty_message = e_lambda (Var.of_name "arguments")
(Some t_unit) (Some (t_list t_operation))
empty_op_list
let chain_id_zero = e_chain_id @@ Tezos_crypto.Base58.simple_encode

6
src/test/multisig_v2_tests.ml
View File

@ -25,12 +25,12 @@ open Ast_simplified
let empty_op_list =
(e_typed_list [] t_operation)
let empty_message = e_lambda "arguments"
let empty_message = e_lambda (Var.of_name "arguments")
(Some t_bytes) (Some (t_list t_operation))
empty_op_list
let empty_message2 = e_lambda "arguments"
let empty_message2 = e_lambda (Var.of_name "arguments")
(Some t_bytes) (Some (t_list t_operation))
( e_let_in ("foo",Some t_unit) (e_unit ()) empty_op_list)
( e_let_in ((Var.of_name "foo"),Some t_unit) (e_unit ()) empty_op_list)
let send_param msg = e_constructor "Send" msg
let withdraw_param = e_constructor "Withdraw" empty_message

9
src/test/typer_tests.ml
View File

@ -23,7 +23,7 @@ module TestExpressions = struct
let test_expression ?(env = Typer.Environment.full_empty)
?(state = Typer.Solver.initial_state)
(expr : expression)
(test_expected_ty : Typed.tv) =
(test_expected_ty : Typed.type_value) =
let pre = expr in
let open Typer in
let open! Typed in
@ -46,7 +46,7 @@ module TestExpressions = struct
let lambda () : unit result =
test_expression
I.(e_lambda "x" (Some t_int) (Some t_int) (e_var "x"))
I.(e_lambda (Var.of_name "x") (Some t_int) (Some t_int) (e_var "x"))
O.(t_function (t_int ()) (t_int ()) ())
let tuple () : unit result =
@ -56,7 +56,7 @@ module TestExpressions = struct
let constructor () : unit result =
let variant_foo_bar =
O.[("foo", t_int ()); ("bar", t_string ())]
O.[(Constructor "foo", t_int ()); (Constructor "bar", t_string ())]
in test_expression
~env:(E.env_sum_type variant_foo_bar)
I.(e_constructor "foo" (e_int 32))
@ -65,7 +65,8 @@ module TestExpressions = struct
let record () : unit result =
test_expression
I.(ez_e_record [("foo", e_int 32); ("bar", e_string "foo")])
O.(make_t_ez_record [("foo", t_int ()); ("bar", t_string ())])
O.(make_t_ez_record [(Label "foo", t_int ()); (Label "bar", t_string ())])
end
(* TODO: deep types (e.g. record of record)

2
src/test/vote_tests.ml
View File

@ -45,7 +45,7 @@ let init_vote () =
let%bind result = Test_helpers.run_typed_program_with_simplified_input program "main" (e_pair (vote "Yes") (init_storage "basic")) in
let%bind (_ , storage) = extract_pair result in
let%bind storage' = extract_record storage in
let votes = List.assoc "candidates" storage' in
let votes = List.assoc (Label "candidates") storage' in
let%bind votes' = extract_map votes in
let%bind (_ , yess) =
trace_option (simple_error "") @@

12
vendors/ligo-utils/simple-utils/var.ml vendored
View File

@ -1,4 +1,4 @@
type t = {
type 'a t = {
name : string ;
counter : int option ;
}
@ -30,6 +30,16 @@ let of_name name =
counter = None
}
(* This exception indicates that some code tried to throw away the
counter of a generated variable. It is not supposed to happen. *)
exception Tried_to_unfreshen_variable
(* TODO delete this *)
let to_name var =
match var.counter with
| None -> var.name
| Some _ -> raise Tried_to_unfreshen_variable
let fresh ?name () =
let name = Option.unopt ~default:"" name in
let counter = incr global_counter ; Some !global_counter in

17
vendors/ligo-utils/simple-utils/var.mli vendored
View File

@ -15,27 +15,30 @@
does not accept names like "foo#121" as possible variable names, so
this confusion should not arise for us. *)
type t
type 'a t
val equal : t -> t -> bool
val compare : t -> t -> int
val equal : 'a t -> 'a t -> bool
val compare : 'a t -> 'a t -> int
(* Prints vars as %s or %s#%d *)
val pp : Format.formatter -> t -> unit
val pp : Format.formatter -> 'a t -> unit
(* Construct a user variable directly from a string. This should only
be used for embedding user variable names. For programmatically
generated variables, use `fresh`. Take care not to cause
shadowing/capture except as the user intended. *)
val of_name : string -> t
val of_name : string -> 'a t
(* TODO don't use this, this should not exist. *)
val to_name : 'a t -> string
(* Generate a variable, using a counter value from a _global_
counter. If the name is not provided, it will be empty. *)
val fresh : ?name:string -> unit -> t
val fresh : ?name:string -> unit -> 'a t
(* Generate a variable as with `fresh`, reusing the name part of the
given variable. *)
val fresh_like : t -> t
val fresh_like : 'a t -> 'a t
(* Reset the global counter. Danger, do not use... Provided for tests
only. *)