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

Merge branch 'ast/main' into 'dev'

Browse Source 
ADT for type

See merge request ligolang/ligo!206
This commit is contained in:
Pierre-Emmanuel Wulfman 2019-12-04 11:40:58 +00:00
commit cc0e94de64
74 changed files with 2248 additions and 1786 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

77
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 match te with
TPar x -> simpl_type_expression x.value.inside TPar x -> simpl_type_expression x.value.inside
| TVar v -> ( | TVar v -> (
match List.assoc_opt v.value type_constants with match type_constants v.value with
Some s -> ok @@ T_constant (s , []) | Ok (s,_) -> ok @@ make_t @@ T_constant s
| None -> ok @@ T_variable v.value | Error _ -> ok @@ make_t @@ T_variable (Var.of_name v.value)
) )
| TFun x -> ( | TFun x -> (
let%bind (a , b) = 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 let%bind b = simpl_type_expression b in
ok (a , b) ok (a , b)
in in
ok @@ T_function (a , b) ok @@ make_t @@ T_arrow (a , b)
) )
| TApp x -> ( | TApp x -> (
let (name, tuple) = x.value in let (name, tuple) = x.value in
let lst = npseq_to_list tuple.value.inside 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 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 -> ( | TProd p -> (
let%bind tpl = simpl_list_type_expression @@ npseq_to_list p.value in 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 aux
@@ List.map apply @@ List.map apply
@@ npseq_to_list r.value.ne_elements in @@ 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 let m = List.fold_left (fun m (x, y) -> LMap.add (Label x) y m) LMap.empty lst in
ok @@ T_record m ok @@ make_t @@ T_record m
| TSum s -> | TSum s ->
let aux (v:Raw.variant Raw.reg) = let aux (v:Raw.variant Raw.reg) =
let args = let args =
@ -219,8 +218,8 @@ let rec simpl_type_expression : Raw.type_expr -> type_expression result = fun te
let%bind lst = bind_list let%bind lst = bind_list
@@ List.map aux @@ List.map aux
@@ npseq_to_list s.value in @@ npseq_to_list s.value in
let m = List.fold_left (fun m (x, y) -> SMap.add x y m) SMap.empty lst in let m = List.fold_left (fun m (x, y) -> CMap.add (Constructor x) y m) CMap.empty lst in
ok @@ T_sum m ok @@ make_t @@ T_sum m
and simpl_list_type_expression (lst:Raw.type_expr list) : type_expression result = and simpl_list_type_expression (lst:Raw.type_expr list) : type_expression result =
match lst with 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 | [hd] -> simpl_type_expression hd
| lst -> | lst ->
let%bind lst = bind_map_list simpl_type_expression lst in 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 : let rec simpl_expression :
Raw.expr -> expr result = fun t -> Raw.expr -> expr result = fun t ->
@ -236,7 +235,7 @@ let rec simpl_expression :
let simpl_projection = fun (p:Raw.projection Region.reg) -> let simpl_projection = fun (p:Raw.projection Region.reg) ->
let (p , loc) = r_split p in let (p , loc) = r_split p in
let var = let var =
let name = p.struct_name.value in let name = Var.of_name p.struct_name.value in
e_variable name in e_variable name in
let path = p.field_path in let path = p.field_path in
let path' = let path' =
@ -263,7 +262,7 @@ let rec simpl_expression :
None -> rhs None -> rhs
| Some ty -> e_annotation rhs ty in | Some ty -> e_annotation rhs ty in
let%bind body = simpl_expression body 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 -> | Raw.EAnnot a ->
let (expr , type_expr), loc = r_split a in let (expr , type_expr), loc = r_split a in
let%bind expr' = simpl_expression expr in let%bind expr' = simpl_expression expr in
@ -271,21 +270,21 @@ let rec simpl_expression :
return @@ e_annotation ~loc expr' type_expr' return @@ e_annotation ~loc expr' type_expr'
| EVar c -> | EVar c ->
let c' = c.value in let c' = c.value in
(match List.assoc_opt c' constants with (match constants c' with
None -> return @@ e_variable c.value | Error _ -> return @@ e_variable (Var.of_name c.value)
| Some s -> return @@ e_constant s []) | Ok (s,_) -> return @@ e_constant s [])
| ECall x -> ( | ECall x -> (
let ((e1 , e2) , loc) = r_split x in let ((e1 , e2) , loc) = r_split x in
let%bind args = bind_map_list simpl_expression (nseq_to_list e2) in let%bind args = bind_map_list simpl_expression (nseq_to_list e2) in
match e1 with match e1 with
| EVar f -> ( | EVar f -> (
let (f , f_loc) = r_split f in let (f , f_loc) = r_split f in
match List.assoc_opt f constants with match constants f with
| None -> ( | Error _ -> (
let%bind arg = simpl_tuple_expression (nseq_to_list e2) in 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 -> | e1 ->
let%bind e1' = simpl_expression e1 in let%bind e1' = simpl_expression e1 in
@ -312,7 +311,7 @@ let rec simpl_expression :
| EConstr (ESomeApp a) -> | EConstr (ESomeApp a) ->
let (_, args), loc = r_split a in let (_, args), loc = r_split a in
let%bind arg = simpl_expression args in let%bind arg = simpl_expression args in
return @@ e_constant ~loc "SOME" [arg] return @@ e_constant ~loc C_SOME [arg]
| EConstr (ENone reg) -> | EConstr (ENone reg) ->
let loc = Location.lift reg in let loc = Location.lift reg in
return @@ e_none ~loc () return @@ e_none ~loc ()
@ -391,7 +390,7 @@ let rec simpl_expression :
let x' = x.value in let x' = x.value in
match x'.pattern with match x'.pattern with
| Raw.PVar y -> | 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 let%bind type_expr = simpl_type_expression x'.type_expr in
return @@ e_let_in (var_name , Some type_expr) e rhs return @@ e_let_in (var_name , Some type_expr) e rhs
| _ -> default_action () | _ -> default_action ()
@ -433,7 +432,7 @@ and simpl_fun lamb' : expr result =
let aux ((var : Raw.variable) , ty_opt) = let aux ((var : Raw.variable) , ty_opt) =
match var.value , ty_opt with match var.value , ty_opt with
| "storage" , None -> | "storage" , None ->
ok (var , T_variable "storage") ok (var , t_variable "storage")
| _ , None -> | _ , None ->
fail @@ untyped_fun_param var fail @@ untyped_fun_param var
| _ , Some ty -> ( | _ , Some ty -> (
@ -446,7 +445,7 @@ and simpl_fun lamb' : expr result =
match args' with match args' with
| [ single ] -> ( | [ single ] -> (
let (binder , input_type) = 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 (body , body_type) = expr_to_typed_expr lamb.body in
let%bind output_type = let%bind output_type =
bind_map_option simpl_type_expression body_type in 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 (binder , input_type) =
let type_expression = T_tuple (List.map snd args') in let type_expression = T_tuple (List.map snd args') in
(arguments_name , type_expression) in (arguments_name , type_expression) in
@ -466,11 +465,11 @@ and simpl_fun lamb' : expr result =
let wrapped_result = let wrapped_result =
let aux = fun i ((name : Raw.variable) , ty) wrapped -> let aux = fun i ((name : Raw.variable) , ty) wrapped ->
let accessor = e_accessor (e_variable arguments_name) [ Access_tuple i ] in 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 in
let wraps = List.mapi aux args' in let wraps = List.mapi aux args' in
List.fold_right' (fun x f -> f x) result wraps 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 (args , loc) = r_split t in
let%bind a = simpl_expression args.arg1 in let%bind a = simpl_expression args.arg1 in
let%bind b = simpl_expression args.arg2 in let%bind b = simpl_expression args.arg2 in
let%bind name = constants name in
return @@ e_constant ~loc name [ a ; b ] return @@ e_constant ~loc name [ a ; b ]
and simpl_unop (name:string) (t:_ Raw.un_op Region.reg) : expression result = and simpl_unop (name:string) (t:_ Raw.un_op Region.reg) : expression result =
let return x = ok @@ x in let return x = ok @@ x in
let (t , loc) = r_split t in let (t , loc) = r_split t in
let%bind a = simpl_expression t.arg in let%bind a = simpl_expression t.arg in
let%bind name = constants name in
return @@ e_constant ~loc name [ a ] return @@ e_constant ~loc name [ a ]
and simpl_tuple_expression ?loc (lst:Raw.expr list) : expression result = 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 -> | TypeDecl x ->
let {name;type_expr} : Raw.type_decl = x.value in let {name;type_expr} : Raw.type_decl = x.value in
let%bind type_expression = simpl_type_expression type_expr 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 x -> (
let binding, _ = r_split x in let binding, _ = r_split x in
let binding = snd binding 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 | None -> fail @@ wrong_pattern "typed var tuple" par_var in
let%bind v_type_expression = v_type_expression in let%bind v_type_expression = v_type_expression in
let%bind simpl_rhs_expr = simpl_expression rhs_expr 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 variables = ok @@ npseq_to_list pt.value
in let%bind expr_bind_lst = in let%bind expr_bind_lst =
match let_rhs with match let_rhs with
@ -626,7 +627,7 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result
let%bind lhs_type' = let%bind lhs_type' =
bind_map_option (fun (_,te) -> simpl_type_expression te) lhs_type in bind_map_option (fun (_,te) -> simpl_type_expression te) lhs_type in
let%bind rhs' = simpl_expression let_rhs in let%bind rhs' = simpl_expression let_rhs in
ok @@ [loc x @@ Declaration_constant (var.value , lhs_type' , rhs')] ok @@ [loc x @@ (Declaration_constant (Var.of_name var.value , lhs_type' , rhs'))]
| param1::others -> | param1::others ->
let fun_ = { let fun_ = {
kwd_fun = Region.ghost; kwd_fun = Region.ghost;
@ -636,10 +637,10 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result
body = let_rhs} in body = let_rhs} in
let rhs = Raw.EFun {region=Region.ghost ; value=fun_} in let rhs = Raw.EFun {region=Region.ghost ; value=fun_} in
let%bind rhs' = simpl_expression rhs in let%bind rhs' = simpl_expression rhs in
ok @@ [loc x @@ Declaration_constant (var.value , None , rhs')] 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 -> fun t ->
let open Raw in let open Raw in
let rec get_var (t:Raw.pattern) = 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 a = get_var a in
let%bind b = get_var b in let%bind b = get_var b in
ok (a, 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 -> | lst ->
let error x = let error x =
let title () = "Pattern" in 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 let%bind x' = trace (error x) @@ get_constr x
in ok (x', y) in ok (x', y)
in bind_map_list aux lst in bind_map_list aux lst
in ok @@ Match_variant constrs in in ok @@ ez_match_variant constrs in
let as_option () = let as_option () =
let aux (x, y) = let aux (x, y) =
let%bind x' = trace (error x) @@ get_constr_opt x 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); | [ (("None", None), none_expr);
(("Some", Some some_var), some_expr) ] -> (("Some", Some some_var), some_expr) ] ->
ok @@ Match_option { ok @@ Match_option {
match_some = (some_var, some_expr); match_some = (Var.of_name some_var, some_expr, ());
match_none = none_expr } match_none = none_expr }
| _ -> simple_fail "bad option pattern" | _ -> simple_fail "bad option pattern"
in bind_or (as_option () , as_variant ()) 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 -> [] | None -> []
| Some lst -> npseq_to_list lst | Some lst -> npseq_to_list lst
let get_value : 'a Raw.reg -> 'a = fun x -> x.value 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 detect_local_declarations (for_body : expression) =
let%bind aux = Self_ast_simplified.fold_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 if cur_loop then
match ass_exp.expression with match ass_exp.expression with
| E_let_in {binder;rhs = _;result = _} -> | E_let_in {binder;rhs = _;result = _} ->
let (name,_) = binder in let (name,_) = binder in
ok (name::nlist, cur_loop) ok (name::nlist, cur_loop)
| E_constant ("MAP_FOLD", _) | E_constant (C_MAP_FOLD, _)
| E_constant ("SET_FOLD", _) | E_constant (C_SET_FOLD, _)
| E_constant ("LIST_FOLD", _) -> ok @@ (nlist, false) | E_constant (C_LIST_FOLD, _) -> ok @@ (nlist, false)
| _ -> ok (nlist, cur_loop) | _ -> ok (nlist, cur_loop)
else else
ok @@ (nlist, cur_loop) ok @@ (nlist, cur_loop)
@ -34,16 +34,16 @@ let detect_local_declarations (for_body : expression) =
for_body in for_body in
ok @@ fst aux 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 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 match ass_exp.expression with
| E_assign ( name , _ , _ ) -> | E_assign ( name , _ , _ ) ->
if is_compiler_generated name then ok prev if is_compiler_generated name then ok prev
else ok (name::prev) else ok (name::prev)
| E_constant (n, [a;b]) | E_constant (n, [a;b])
when n="OR" || n="AND" || n="LT" || n="GT" || when n=C_OR || n=C_AND || n=C_LT || n=C_GT ||
n="LE" || n="GE" || n="EQ" || n="NEQ" -> ( n=C_LE || n=C_GE || n=C_EQ || n=C_NEQ -> (
match (a.expression,b.expression) with match (a.expression,b.expression) with
| E_variable na , E_variable nb -> | E_variable na , E_variable nb ->
let ret = [] in let ret = [] in
@ -60,6 +60,8 @@ let detect_free_variables (for_body : expression) (local_decl_names : string lis
| _ -> ok prev ) | _ -> ok prev )
[] []
for_body in 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 ok @@ SSet.elements
@@ SSet.diff (SSet.of_list captured_names) (SSet.of_list local_decl_names) @@ 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 match t with
TPar x -> simpl_type_expression x.value.inside TPar x -> simpl_type_expression x.value.inside
| TVar v -> ( | TVar v -> (
match List.assoc_opt v.value type_constants with match type_constants v.value with
| Some s -> ok @@ T_constant (s , []) | Ok (s,_) -> ok @@ make_t @@ T_constant s
| None -> ok @@ T_variable v.value | Error _ -> ok @@ make_t @@ T_variable (Var.of_name v.value)
) )
| TFun x -> ( | TFun x -> (
let%bind (a , b) = let%bind (a , b) =
let (a , _ , b) = x.value in let (a , _ , b) = x.value in
bind_map_pair simpl_type_expression (a , b) in bind_map_pair simpl_type_expression (a , b) in
ok @@ T_function (a , b) ok @@ make_t @@ T_arrow (a , b)
) )
| TApp x -> | TApp x ->
let (name, tuple) = x.value in let (name, tuple) = x.value in
let lst = npseq_to_list tuple.value.inside 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 = let%bind cst =
trace_option (unknown_predefined_type name) @@ trace (unknown_predefined_type name) @@
List.assoc_opt name.value type_constants in type_operators name.value in
ok @@ T_constant (cst , lst') ok @@ t_operator cst lst
| TProd p -> | TProd p ->
let%bind tpl = simpl_list_type_expression let%bind tpl = simpl_list_type_expression
@@ npseq_to_list p.value in @@ 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 aux
@@ List.map apply @@ List.map apply
@@ npseq_to_list r.value.ne_elements in @@ 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 let m = List.fold_left (fun m (x, y) -> LMap.add (Label x) y m) LMap.empty lst in
ok @@ T_record m ok @@ make_t @@ T_record m
| TSum s -> | TSum s ->
let aux (v:Raw.variant Raw.reg) = let aux (v:Raw.variant Raw.reg) =
let args = let args =
@ -275,8 +277,8 @@ let rec simpl_type_expression (t:Raw.type_expr) : type_expression result =
let%bind lst = bind_list let%bind lst = bind_list
@@ List.map aux @@ List.map aux
@@ npseq_to_list s.value in @@ npseq_to_list s.value in
let m = List.fold_left (fun m (x, y) -> SMap.add x y m) SMap.empty lst in let m = List.fold_left (fun m (x, y) -> CMap.add (Constructor x) y m) CMap.empty lst in
ok @@ T_sum m ok @@ make_t @@ T_sum m
and simpl_list_type_expression (lst:Raw.type_expr list) : type_expression result = and simpl_list_type_expression (lst:Raw.type_expr list) : type_expression result =
match lst with 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 | [hd] -> simpl_type_expression hd
| lst -> | lst ->
let%bind lst = bind_list @@ List.map simpl_type_expression lst in 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 simpl_projection : Raw.projection Region.reg -> _ = fun p ->
let (p' , loc) = r_split p in let (p' , loc) = r_split p in
let var = let var =
let name = p'.struct_name.value in let name = Var.of_name p'.struct_name.value in
e_variable name in e_variable name in
let path = p'.field_path in let path = p'.field_path in
let path' = let path' =
@ -313,9 +315,9 @@ let rec simpl_expression (t:Raw.expr) : expr result =
) )
| EVar c -> ( | EVar c -> (
let (c' , loc) = r_split c in let (c' , loc) = r_split c in
match List.assoc_opt c' constants with match constants c' with
| None -> return @@ e_variable ~loc c.value | Error _ -> return @@ e_variable ~loc (Var.of_name c.value)
| Some s -> return @@ e_constant ~loc s [] | Ok (s,_) -> return @@ e_constant ~loc s []
) )
| ECall x -> ( | ECall x -> (
let ((f, args) , loc) = r_split x in let ((f, args) , loc) = r_split x in
@ -324,11 +326,11 @@ let rec simpl_expression (t:Raw.expr) : expr result =
match f with match f with
| EVar name -> ( | EVar name -> (
let (f_name , f_loc) = r_split name in let (f_name , f_loc) = r_split name in
match List.assoc_opt f_name constants with match constants f_name with
| None -> | Error _ ->
let%bind arg = simpl_tuple_expression ~loc:args_loc args' in let%bind arg = simpl_tuple_expression ~loc:args_loc args' in
return @@ e_application ~loc (e_variable ~loc:f_loc f_name) arg return @@ e_application ~loc (e_variable ~loc:f_loc (Var.of_name f_name)) arg
| Some s -> | Ok (s,_) ->
let%bind lst = bind_map_list simpl_expression args' in let%bind lst = bind_map_list simpl_expression args' in
return @@ e_constant ~loc s lst return @@ e_constant ~loc s lst
) )
@ -373,7 +375,7 @@ let rec simpl_expression (t:Raw.expr) : expr result =
let%bind arg = let%bind arg =
simpl_tuple_expression ~loc:args_loc simpl_tuple_expression ~loc:args_loc
@@ npseq_to_list args.inside in @@ npseq_to_list args.inside in
return @@ e_constant ~loc "SOME" [arg] return @@ e_constant ~loc C_SOME [arg]
| EConstr (NoneExpr reg) -> ( | EConstr (NoneExpr reg) -> (
let loc = Location.lift reg in let loc = Location.lift reg in
return @@ e_none ~loc () return @@ e_none ~loc ()
@ -468,7 +470,7 @@ let rec simpl_expression (t:Raw.expr) : expr result =
let%bind path = match lu.path with let%bind path = match lu.path with
| Name v -> ( | Name v -> (
let (v , loc) = r_split v in 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 | Path p -> simpl_projection p
in in
@ -534,7 +536,7 @@ and simpl_set_expression (t:Raw.set_expr) : expression result =
let (x' , loc) = r_split x in let (x' , loc) = r_split x in
let%bind set' = simpl_expression x'.set in let%bind set' = simpl_expression x'.set in
let%bind element' = simpl_expression x'.element 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 -> ( | SetInj x -> (
let (x' , loc) = r_split x in 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 (t , loc) = r_split t in
let%bind a = simpl_expression t.arg1 in let%bind a = simpl_expression t.arg1 in
let%bind b = simpl_expression t.arg2 in let%bind b = simpl_expression t.arg2 in
let%bind name = constants name in
return @@ e_constant ~loc name [ a ; b ] return @@ e_constant ~loc name [ a ; b ]
and simpl_unop (name:string) (t:_ Raw.un_op Region.reg) : expression result = and simpl_unop (name:string) (t:_ Raw.un_op Region.reg) : expression result =
let return x = ok x in let return x = ok x in
let (t , loc) = r_split t in let (t , loc) = r_split t in
let%bind a = simpl_expression t.arg in let%bind a = simpl_expression t.arg in
let%bind name = constants name in
return @@ e_constant ~loc name [ a ] return @@ e_constant ~loc name [ a ]
and simpl_tuple_expression ?loc (lst:Raw.expr list) : expression result = 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 name = x.name.value in
let%bind t = simpl_type_expression x.var_type in let%bind t = simpl_type_expression x.var_type in
let%bind expression = simpl_expression x.init 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 -> | LocalConst x ->
let (x , loc) = r_split x in let (x , loc) = r_split x in
let name = x.name.value in let name = x.name.value in
let%bind t = simpl_type_expression x.const_type in let%bind t = simpl_type_expression x.const_type in
let%bind expression = simpl_expression x.init 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 -> | LocalFun f ->
let (f , loc) = r_split f in 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_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 let%bind name = trace_option (unexpected_anonymous_function loc) name_opt in
return_let_in ~loc (name , ty_opt) e 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 -> fun t ->
match t with match t with
| ParamConst c -> | ParamConst c ->
let c = c.value in 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 let%bind type_expression = simpl_type_expression c.param_type in
ok (type_name , type_expression) ok (type_name , type_expression)
| ParamVar v -> | ParamVar v ->
let c = v.value in 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 let%bind type_expression = simpl_type_expression c.param_type in
ok (type_name , type_expression) ok (type_name , type_expression)
and simpl_fun_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 -> fun ~loc x ->
let open! Raw in let open! Raw in
let {name;param;ret_type;local_decls;block;return} : fun_expr = x 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 (match param.value.inside with
a, [] -> ( a, [] -> (
let%bind input = simpl_param a in 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 (binder , input_type) = input in
let%bind local_declarations = let%bind local_declarations =
bind_map_list simpl_local_declaration local_decls in 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 bind_fold_right_list aux result body in
let expression : expression = e_lambda ~loc binder (Some input_type) let expression : expression = e_lambda ~loc binder (Some input_type)
(Some output_type) result in (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) ok ((name , type_annotation) , expression)
) )
| lst -> ( | lst -> (
let lst = npseq_to_list lst in 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%bind params = bind_map_list simpl_param lst in
let (binder , input_type) = let (binder , input_type) =
let type_expression = T_tuple (List.map snd params) in let type_expression = T_tuple (List.map snd params) in
@ -645,8 +649,8 @@ and simpl_fun_expression :
let%bind tpl_declarations = let%bind tpl_declarations =
let aux = fun i x -> let aux = fun i x ->
let expr = e_accessor (e_variable arguments_name) [Access_tuple i] in let expr = e_accessor (e_variable arguments_name) [Access_tuple i] in
let type_ = Some (snd x) in let type_variable = Some (snd x) in
let ass = return_let_in (fst x , type_) expr in let ass = return_let_in (fst x , type_variable) expr in
ass ass
in in
bind_list @@ List.mapi aux params in bind_list @@ List.mapi aux params in
@ -662,9 +666,9 @@ and simpl_fun_expression :
let aux prec cur = cur (Some prec) in let aux prec cur = cur (Some prec) in
bind_fold_right_list aux result body in bind_fold_right_list aux result body in
let expression = let expression =
e_lambda ~loc binder (Some input_type) (Some output_type) result in e_lambda ~loc binder (Some (make_t @@ 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 (make_t input_type, output_type)) 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
ok ((name , type_annotation) , expression) 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 (x , loc) = r_split x in
let {name;type_expr} : Raw.type_decl = x in let {name;type_expr} : Raw.type_decl = x in
let%bind type_expression = simpl_type_expression type_expr 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 -> | ConstDecl x ->
let simpl_const_decl = fun {name;const_type;init} -> let simpl_const_decl = fun {name;const_type;init} ->
let%bind expression = simpl_expression init in let%bind expression = simpl_expression init in
let%bind t = simpl_type_expression const_type in let%bind t = simpl_type_expression const_type in
let type_annotation = Some t 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 in
bind_map_location simpl_const_decl (Location.lift_region x) bind_map_location simpl_const_decl (Location.lift_region x)
| FunDecl x -> ( | FunDecl x -> (
@ -709,11 +713,11 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
match f with match f with
| EVar name -> ( | EVar name -> (
let (f_name , f_loc) = r_split name in let (f_name , f_loc) = r_split name in
match List.assoc_opt f_name constants with match constants f_name with
| None -> | Error _ ->
let%bind arg = simpl_tuple_expression ~loc:args_loc args' in let%bind arg = simpl_tuple_expression ~loc:args_loc args' in
return_statement @@ e_application ~loc (e_variable ~loc:f_loc f_name) arg return_statement @@ e_application ~loc (e_variable ~loc:f_loc (Var.of_name f_name)) arg
| Some s -> | Ok (s,_) ->
let%bind lst = bind_map_list simpl_expression args' in let%bind lst = bind_map_list simpl_expression args' in
return_statement @@ e_constant ~loc s lst return_statement @@ e_constant ~loc s lst
) )
@ -777,7 +781,7 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
| MapPath v -> ( | MapPath v -> (
let v' = v.value in let v' = v.value in
let%bind (varname,map,path) = match v'.path with 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 -> | Path p ->
let (name,p') = simpl_path v'.path in let (name,p') = simpl_path v'.path in
let%bind accessor = simpl_projection p 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 let assigns = List.fold_right
(fun (key, value) map -> (e_map_add key value map)) (fun (key, value) map -> (e_map_add key value map))
inj 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 e_assign ~loc name access_path assigns
in return_statement @@ expr in return_statement @@ expr
) )
@ -875,8 +879,8 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
| [] -> e_skip ~loc () | [] -> e_skip ~loc ()
| _ :: _ -> | _ :: _ ->
let assigns = List.fold_right let assigns = List.fold_right
(fun hd s -> e_constant "SET_ADD" [hd ; s]) (fun hd s -> e_constant C_SET_ADD [hd ; s])
inj (e_accessor ~loc (e_variable name) access_path) in inj (e_accessor ~loc (e_variable (Var.of_name name)) access_path) in
e_assign ~loc name access_path assigns in e_assign ~loc name access_path assigns in
return_statement @@ expr return_statement @@ expr
) )
@ -884,27 +888,27 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
let (v , loc) = r_split r in let (v , loc) = r_split r in
let key = v.key in let key = v.key in
let%bind (varname,map,path) = match v.map with 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 -> | Path p ->
let (name,p') = simpl_path v.map in let (name,p') = simpl_path v.map in
let%bind accessor = simpl_projection p in let%bind accessor = simpl_projection p in
ok @@ (name , accessor , p') ok @@ (name , accessor , p')
in in
let%bind key' = simpl_expression key 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 return_statement @@ e_assign ~loc varname path expr
) )
| SetRemove r -> ( | SetRemove r -> (
let (set_rm, loc) = r_split r in let (set_rm, loc) = r_split r in
let%bind (varname, set, path) = match set_rm.set with 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 -> | Path path ->
let(name, p') = simpl_path set_rm.set in let(name, p') = simpl_path set_rm.set in
let%bind accessor = simpl_projection path in let%bind accessor = simpl_projection path in
ok @@ (name, accessor, p') ok @@ (name, accessor, p')
in in
let%bind removed' = simpl_expression set_rm.element 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 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') (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 open Raw in
let get_var (t:Raw.pattern) = let get_var (t:Raw.pattern) =
match t with 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 let%bind v = match v.value.inside with
| PVar v -> ok v.value | PVar v -> ok v.value
| p -> fail @@ unsupported_deep_Some_patterns p in | 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 PCons c, cons) ; (PList (PNil _), nil)]
| [(PList (PNil _), nil) ; (PList PCons c, cons)] -> | [(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 let%bind b = get_var b in
ok (a, b) ok (a, b)
| _ -> fail @@ unsupported_deep_list_patterns c | _ -> fail @@ unsupported_deep_list_patterns c
in 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 -> | lst ->
trace (simple_info "currently, only booleans, options, lists and \ trace (simple_info "currently, only booleans, options, lists and \
user-defined constructors are supported in patterns") @@ 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 get_constr x in
ok (x' , y) in ok (x' , y) in
bind_map_list aux lst in bind_map_list aux lst in
ok @@ Match_variant constrs ok @@ ez_match_variant constrs
and simpl_instruction : Raw.instruction -> (_ -> expression result) result = and simpl_instruction : Raw.instruction -> (_ -> expression result) result =
fun t -> 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 -> and simpl_for_int : Raw.for_int -> (_ -> expression result) result = fun fi ->
(* cond part *) (* 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 value = simpl_expression fi.assign.value.expr in
let%bind bound = simpl_expression fi.bound 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 in
(* body part *) (* body part *)
let%bind body = simpl_block fi.block.value in let%bind body = simpl_block fi.block.value in
let%bind body = body None in let%bind body = body None in
let step = e_int 1 in let step = e_int 1 in
let ctrl = e_assign 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 let rec add_to_seq expr = match expr.expression with
| E_sequence (_,a) -> add_to_seq a | E_sequence (_,a) -> add_to_seq a
| _ -> e_sequence body ctrl in | _ -> e_sequence body ctrl in
let body' = add_to_seq body in let body' = add_to_seq body in
let loop = e_loop comp 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 (** simpl_for_collect
For loops over collections, like 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 | Some v -> "#COMPILER#elt_"^(snd v).value
| None -> "#COMPILER#elt_unused" in | None -> "#COMPILER#elt_unused" in
let element_names = ok @@ match fc.bind_to with let element_names = ok @@ match fc.bind_to with
| Some v -> [fc.var.value;(snd v).value] | Some v -> [Var.of_name fc.var.value;Var.of_name (snd v).value]
| None -> [fc.var.value] in | None -> [Var.of_name fc.var.value] in
(* STEP 1 *) (* STEP 1 *)
let%bind for_body = simpl_block fc.block.value in let%bind for_body = simpl_block fc.block.value in
let%bind for_body = for_body None 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 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 let%bind captured_name_list = detect_free_variables for_body local_decl_name_list in
(* STEP 3 *) (* STEP 3 *)
let add_to_record (prev: expression type_name_map) (captured_name: string) = let add_to_record (prev: expression SMap.t) (captured_name: string) =
SMap.add captured_name (e_variable captured_name) prev in 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 let init_record = e_record (List.fold_left add_to_record SMap.empty captured_name_list) in
(* STEP 4 *) (* STEP 4 *)
let replace exp = 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 if (List.mem name local_decl_name_list ) then
ok @@ exp ok @@ exp
else else
let name = Var.to_name name in
let path' = List.filter let path' = List.filter
( fun el -> ( fun el ->
match el with match el with
| Access_record name -> not @@ is_compiler_generated name | Access_record name -> not @@ is_compiler_generated (Var.of_name name)
| _ -> true ) | _ -> true )
((Access_record name)::path) in ((Access_record name)::path) in
ok @@ e_assign "#COMPILER#acc" path' expr ) ok @@ e_assign "#COMPILER#acc" path' expr )
| E_variable name -> ( | E_variable name -> (
let name = Var.to_name name in
if (List.mem name captured_name_list) then if (List.mem name captured_name_list) then
(* replace references to fold accumulator as rhs *) (* 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 else match fc.collection with
(* loop on map *) (* loop on map *)
| 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 if ( name = fc.var.value ) then
ok @@ k' (* replace references to the the key *) ok @@ k' (* replace references to the the key *)
else ( else (
match fc.bind_to with match fc.bind_to with
| Some (_,v) -> | 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 if ( name = v.value ) then
ok @@ v' (* replace references to the the value *) ok @@ v' (* replace references to the the value *)
else ok @@ exp else ok @@ exp
@ -1191,7 +1198,7 @@ and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun
| (Set _ | List _) -> | (Set _ | List _) ->
if (name = fc.var.value ) then if (name = fc.var.value ) then
(* replace references to the collection element *) (* replace references to the collection element *)
ok @@ (e_variable elt_name) ok @@ (e_variable (Var.of_name elt_name))
else ok @@ exp else ok @@ exp
) )
| _ -> ok @@ exp in | _ -> ok @@ exp in
@ -1199,34 +1206,34 @@ and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun
(* STEP 5 *) (* STEP 5 *)
let rec add_return (expr : expression) = match expr.expression with let rec add_return (expr : expression) = match expr.expression with
| E_sequence (a,b) -> e_sequence a (add_return b) | 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 let for_body = add_return for_body in
(* STEP 6 *) (* STEP 6 *)
let for_body = 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 ( match fc.collection with
| Map _ -> | Map _ ->
let acc = arg_access [Access_tuple 0 ] in let acc = arg_access [Access_tuple 0 ] in
let collec_elt_v = arg_access [Access_tuple 1 ; 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 let collec_elt_k = arg_access [Access_tuple 1 ; Access_tuple 1] in
e_let_in ("#COMPILER#acc", None) acc @@ e_let_in (Var.of_name "#COMPILER#acc", None) acc @@ (* TODO fresh *)
e_let_in (elt_name, None) collec_elt_v @@ e_let_in (Var.of_name elt_name, None) collec_elt_v @@
e_let_in (elt_v_name, None) collec_elt_k (for_body) e_let_in (Var.of_name elt_v_name, None) collec_elt_k (for_body)
| _ -> | _ ->
let acc = arg_access [Access_tuple 0] in let acc = arg_access [Access_tuple 0] in
let collec_elt = arg_access [Access_tuple 1] in let collec_elt = arg_access [Access_tuple 1] in
e_let_in ("#COMPILER#acc", None) acc @@ e_let_in (Var.of_name "#COMPILER#acc", None) acc @@ (* TODO fresh *)
e_let_in (elt_name, None) collec_elt (for_body) e_let_in (Var.of_name elt_name, None) collec_elt (for_body)
) in ) in
(* STEP 7 *) (* STEP 7 *)
let%bind collect = simpl_expression fc.expr in 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 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 let fold = e_constant op_name [lambda; collect ; init_record] in
(* STEP 8 *) (* STEP 8 *)
let assign_back (prev : expression option) (captured_varname : string) : expression option = 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 [Access_record captured_varname] in
let assign = e_assign captured_varname [] access in let assign = e_assign captured_varname [] access in
match prev with 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 let final_sequence = match reassign_sequence with
(* None case means that no variables were captured *) (* None case means that no variables were captured *)
| None -> e_skip () | 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 return_statement @@ final_sequence
let simpl_program : Raw.ast -> program result = fun t -> 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 ok res
) )
| E_lambda { binder = _ ; input_type = _ ; output_type = _ ; result = e } | 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 let%bind res = self init' e in
ok res 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 let%bind res = fold_expression self init'' expr in
ok res ok res
in 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 ok res
) )
| E_let_in { binder = _ ; rhs ; result } -> ( | 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 let%bind res = fold_expression f res match_false in
ok res 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 init match_nil in
let%bind res = fold_expression f res cons in let%bind res = fold_expression f res cons in
ok res 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 init match_none in
let%bind res = fold_expression f res some in let%bind res = fold_expression f res some in
ok res ok res
) )
| Match_tuple (_ , e) -> ( | Match_tuple ((_ , e), _) -> (
let%bind res = fold_expression f init e in let%bind res = fold_expression f init e in
ok res ok res
) )
| Match_variant lst -> ( | Match_variant (lst, _) -> (
let aux init' ((_ , _) , e) = let aux init' ((_ , _) , e) =
let%bind res' = fold_expression f init' e in let%bind res' = fold_expression f init' e in
ok res' 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 let%bind ab' = bind_map_pair self ab in
return @@ E_loop ab' return @@ E_loop ab'
) )
| E_annotation (e , t) -> ( | E_ascription (e , t) -> (
let%bind e' = self e in let%bind e' = self e in
return @@ E_annotation (e' , t) return @@ E_ascription (e' , t)
) )
| E_assign (name , path , e) -> ( | E_assign (name , path , e) -> (
let%bind e' = self e in 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) return @@ E_accessor (e' , path)
) )
| E_record m -> ( | 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' return @@ E_record m'
) )
| E_constructor (name , e) -> ( | 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 let%bind match_false = map_expression f match_false in
ok @@ Match_bool { match_true ; match_false } 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 match_nil = map_expression f match_nil in
let%bind cons = map_expression f cons 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 match_none = map_expression f match_none in
let%bind some = map_expression f some 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 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 aux ((a , b) , e) =
let%bind e' = map_expression f e in let%bind e' = map_expression f e in
ok ((a , b) , e') ok ((a , b) , e')
in in
let%bind lst' = bind_map_list aux lst 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 -> 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 peephole_expression : expression -> expression result = fun e ->
let return expression = ok { e with expression } in let return expression = ok { e with expression } in
match e.expression with match e.expression with
| E_constant ("BIG_MAP_LITERAL" , lst) -> ( | E_constant (C_BIG_MAP_LITERAL , lst) -> (
let%bind elt = let%bind elt =
trace_option (simple_error "big_map literal expects a single parameter") @@ trace_option (simple_error "big_map literal expects a single parameter") @@
List.to_singleton lst 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 let%bind pairs = bind_map_list aux lst in
return @@ E_big_map pairs return @@ E_big_map pairs
) )
| E_constant ("MAP_LITERAL" , lst) -> ( | E_constant (C_MAP_LITERAL, lst) -> (
let%bind elt = let%bind elt =
trace_option (simple_error "map literal expects a single parameter") @@ trace_option (simple_error "map literal expects a single parameter") @@
List.to_singleton lst 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 let%bind pairs = bind_map_list aux lst in
return @@ E_map pairs return @@ E_map pairs
) )
| E_constant ("BIG_MAP_EMPTY" , lst) -> ( | E_constant (C_BIG_MAP_EMPTY, lst) -> (
let%bind () = let%bind () =
trace_strong (simple_error "BIG_MAP_EMPTY expects no parameter") @@ trace_strong (simple_error "BIG_MAP_EMPTY expects no parameter") @@
Assert.assert_list_empty lst Assert.assert_list_empty lst
in in
return @@ E_big_map [] return @@ E_big_map []
) )
| E_constant ("MAP_EMPTY" , lst) -> ( | E_constant (C_MAP_EMPTY, lst) -> (
let%bind () = let%bind () =
trace_strong (simple_error "MAP_EMPTY expects no parameter") @@ trace_strong (simple_error "MAP_EMPTY expects no parameter") @@
Assert.assert_list_empty lst Assert.assert_list_empty lst
in in
return @@ E_map [] return @@ E_map []
) )
| E_constant ("SET_LITERAL" , lst) -> ( | E_constant (C_SET_LITERAL, lst) -> (
let%bind elt = let%bind elt =
trace_option (simple_error "map literal expects a single parameter") @@ trace_option (simple_error "map literal expects a single parameter") @@
List.to_singleton lst List.to_singleton lst
@ -71,7 +71,7 @@ let peephole_expression : expression -> expression result = fun e ->
in in
return @@ E_set lst return @@ E_set lst
) )
| E_constant ("SET_EMPTY" , lst) -> ( | E_constant (C_SET_EMPTY, lst) -> (
let%bind () = let%bind () =
trace_strong (simple_error "SET_EMPTY expects no parameter") @@ trace_strong (simple_error "SET_EMPTY expects no parameter") @@
Assert.assert_list_empty lst 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 peephole_expression : expression -> expression result = fun e ->
let return expression = ok { e with expression } in let return expression = ok { e with expression } in
match e.expression with match e.expression with
| E_constructor ("Some" , e) -> return @@ E_constant ("SOME" , [ e ]) | E_constructor (Constructor "Some" , e) -> return @@ E_constant (C_SOME , [ e ])
| E_constructor ("None" , _) -> return @@ E_constant ("NONE" , [ ]) | E_constructor (Constructor "None" , _) -> return @@ E_constant (C_NONE , [ ])
| e -> return e | 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 peephole_expression : expression -> expression result = fun e ->
let return expression = ok { e with expression } in let return expression = ok { e with expression } in
match e.expression with match e.expression with
| E_annotation (e' , t) as e -> ( | E_ascription (e' , t) as e -> (
match (e'.expression , t) with match (e'.expression , t.type_expression') with
| (E_literal (Literal_string str) , T_constant ("address" , [])) -> return @@ E_literal (Literal_address str) | (E_literal (Literal_string str) , T_constant (TC_address)) -> return @@ E_literal (Literal_address str)
| (E_literal (Literal_string str) , T_constant ("bytes" , [])) -> ( | (E_literal (Literal_string str) , T_constant (TC_bytes)) -> (
let%bind e' = e'_bytes str in let%bind e' = e'_bytes str in
return e' return e'
) )

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

@ -37,83 +37,88 @@ module Wrap = struct
| T_tuple types -> | T_tuple types ->
P_constant (C_tuple, List.map type_expression_to_type_value types) P_constant (C_tuple, List.map type_expression_to_type_value types)
| T_sum kvmap -> | 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 -> | T_record kvmap ->
P_constant (C_record, Map.String.to_list @@ Map.String.map type_expression_to_type_value kvmap) P_constant (C_record, T.LMap.to_list @@ T.LMap.map type_expression_to_type_value kvmap)
| T_function (arg , ret) -> | T_arrow (arg , ret) ->
P_constant (C_arrow, List.map type_expression_to_type_value [ 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_variable (type_name) -> P_variable type_name
| T_constant (Type_name type_name , args) -> | T_constant (type_name) ->
let csttag = Core.(match type_name with let csttag = Core.(match type_name with
| "arrow" -> C_arrow | TC_unit -> C_unit
| "option" -> C_option | TC_bool -> C_bool
| "tuple" -> C_tuple | TC_string -> C_string
(* record *) | TC_nat -> C_nat
(* variant *) | TC_mutez -> C_mutez
| "map" -> C_map | TC_timestamp -> C_timestamp
| "big_map" -> C_map | TC_int -> C_int
| "list" -> C_list | TC_address -> C_address
| "set" -> C_set | TC_bytes -> C_bytes
| "unit" -> C_unit | TC_key_hash -> C_key_hash
| "bool" -> C_bool | TC_key -> C_key
| "string" -> C_string | TC_signature -> C_signature
| "nat" -> C_nat | TC_operation -> C_operation
| "mutez" -> C_tez (* TODO: rename tez to mutez*) | TC_chain_id -> C_unit (* TODO : replace with chain_id*)
| "timestamp" -> C_timestamp )
| "int" -> C_int in
| "address" -> C_address P_constant (csttag, [])
| "bytes" -> C_bytes | T_operator (type_operator) ->
| "key_hash" -> C_key_hash let (csttag, args) = Core.(match type_operator with
| "key" -> C_key | TC_option o -> (C_option, [o])
| "signature" -> C_signature | TC_set s -> (C_set, [s])
| "operation" -> C_operation | TC_map (k,v) -> (C_map, [k;v])
| "contract" -> C_contract | TC_big_map (k,v) -> (C_big_map, [k;v])
| unknown -> | TC_list l -> (C_list, [l])
(* TODO: return a Trace.result *) | TC_contract c -> (C_contract, [c])
let _ = fail (fun () -> Errors.unknown_type_constructor unknown te ()) in )
failwith ("unknown type constructor " ^ unknown))
in in
P_constant (csttag, List.map type_expression_to_type_value args) 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 -> 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 -> | T_tuple types ->
P_constant (C_tuple, List.map type_expression_to_type_value_copypasted types) P_constant (C_tuple, List.map type_expression_to_type_value_copypasted types)
| T_sum kvmap -> | 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 -> | T_record kvmap ->
P_constant (C_record, Map.String.to_list @@ Map.String.map type_expression_to_type_value_copypasted kvmap) P_constant (C_record, I.LMap.to_list @@ I.LMap.map type_expression_to_type_value_copypasted kvmap)
| T_function (arg , ret) -> | T_arrow (arg , ret) ->
P_constant (C_arrow, List.map type_expression_to_type_value_copypasted [ 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_variable type_name -> P_variable type_name
| T_constant (type_name , args) -> | T_constant (type_name) ->
let csttag = Core.(match type_name with let csttag = Core.(match type_name with
| "arrow" -> C_arrow | TC_unit -> C_unit
| "option" -> C_option | TC_bool -> C_bool
| "tuple" -> C_tuple | TC_string -> C_string
| "map" -> C_map
| "list" -> C_list
| "set" -> C_set
| "unit" -> C_unit
| "bool" -> C_bool
| "string" -> C_string
| _ -> failwith "unknown type constructor") | _ -> failwith "unknown type constructor")
in 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) P_constant (csttag, List.map type_expression_to_type_value_copypasted args)
let failwith_ : unit -> (constraints * O.type_variable) = fun () -> let failwith_ : unit -> (constraints * O.type_variable) = fun () ->
let type_name = Core.fresh_type_variable () in let type_name = Core.fresh_type_variable () in
[] , type_name [] , 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 pattern = type_expression_to_type_value expr in
let type_name = Core.fresh_type_variable () 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 pattern = type_expression_to_type_value t in
let type_name = Core.fresh_type_variable () 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 () -> 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 [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 patterns = List.map type_expression_to_type_value tys in
let pattern = O.(P_constant (C_tuple , patterns)) in let pattern = O.(P_constant (C_tuple , patterns)) in
let type_name = Core.fresh_type_variable () 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_tuple = ('label:int, 'v) … -> record ('label : 'v) … *)
(* let t_constructor = ('label:string, 'v) -> variant ('label : 'v) *) (* let t_constructor = ('label:string, 'v) -> variant ('label : 'v) *)
@ -157,16 +162,16 @@ module Wrap = struct
end end
(* TODO: I think we should take an I.expression for the base+label *) (* 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 base' = type_expression_to_type_value base in
let expr_type = Core.fresh_type_variable () 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_int ~base ~index = access_label ~base ~label:(L_int index)
let access_string ~base ~property = access_label ~base ~label:(L_string property) let access_string ~base ~property = access_label ~base ~label:(L_string property)
let constructor 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 -> = fun t_arg c_arg sum ->
let t_arg = type_expression_to_type_value t_arg in let t_arg = type_expression_to_type_value t_arg in
let c_arg = type_expression_to_type_value c_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 (P_variable (whole_expr) , sum) ;
C_equation (t_arg , c_arg) 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 record_type = type_expression_to_type_value (T.t_record fields ()) in
let whole_expr = Core.fresh_type_variable () 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 -> fun ctor element_tys ->
let elttype = O.P_variable (Core.fresh_type_variable ()) in let elttype = O.P_variable (Core.fresh_type_variable ()) in
let aux elt = let aux elt =
@ -192,12 +197,12 @@ module Wrap = struct
let whole_expr = Core.fresh_type_variable () in let whole_expr = Core.fresh_type_variable () in
O.[ O.[
C_equation (P_variable whole_expr , O.P_constant (ctor , [elttype])) 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 list = collection O.C_list
let set = collection O.C_set 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 -> fun kv_tys ->
let k_type = O.P_variable (Core.fresh_type_variable ()) in let k_type = O.P_variable (Core.fresh_type_variable ()) in
let v_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 let whole_expr = Core.fresh_type_variable () in
O.[ O.[
C_equation (P_variable whole_expr , O.P_constant (C_map , [k_type ; v_type])) 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 -> fun kv_tys ->
let k_type = O.P_variable (Core.fresh_type_variable ()) in let k_type = O.P_variable (Core.fresh_type_variable ()) in
let v_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 (* TODO: this doesn't tag big_maps uniquely (i.e. if two
big_map have the same type, they can be swapped. *) 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])) 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 -> fun f arg ->
let whole_expr = Core.fresh_type_variable () in let whole_expr = Core.fresh_type_variable () in
let f' = type_expression_to_type_value f in let f' = type_expression_to_type_value f in
let arg' = type_expression_to_type_value arg in let arg' = type_expression_to_type_value arg in
O.[ O.[
C_equation (f' , P_constant (C_arrow , [arg' ; P_variable whole_expr])) 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 -> fun ds ind ->
let ds' = type_expression_to_type_value ds in let ds' = type_expression_to_type_value ds in
let ind' = type_expression_to_type_value ind in let ind' = type_expression_to_type_value ind in
@ -251,9 +256,9 @@ module Wrap = struct
O.[ O.[
C_equation (ds' , P_constant (C_map, [ind' ; P_variable v])) ; C_equation (ds' , P_constant (C_map, [ind' ; P_variable v])) ;
C_equation (P_variable whole_expr , P_constant (C_option , [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 -> fun a b ->
let a' = type_expression_to_type_value a in let a' = type_expression_to_type_value a in
let b' = type_expression_to_type_value b in let b' = type_expression_to_type_value b in
@ -261,9 +266,9 @@ module Wrap = struct
O.[ O.[
C_equation (a' , P_constant (C_unit , [])) ; C_equation (a' , P_constant (C_unit , [])) ;
C_equation (b' , P_variable whole_expr) 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 -> fun expr body ->
let expr' = type_expression_to_type_value expr in let expr' = type_expression_to_type_value expr in
let body' = type_expression_to_type_value body 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 (expr' , P_constant (C_bool , [])) ;
C_equation (body' , P_constant (C_unit , [])) ; C_equation (body' , P_constant (C_unit , [])) ;
C_equation (P_variable whole_expr , 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 -> fun rhs rhs_tv_opt result ->
let rhs' = type_expression_to_type_value rhs in let rhs' = type_expression_to_type_value rhs in
let result' = type_expression_to_type_value result 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 let whole_expr = Core.fresh_type_variable () in
O.[ O.[
C_equation (result' , P_variable whole_expr) 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 -> fun v e ->
let v' = type_expression_to_type_value v in let v' = type_expression_to_type_value v in
let e' = type_expression_to_type_value e in let e' = type_expression_to_type_value e in
@ -294,9 +299,9 @@ module Wrap = struct
O.[ O.[
C_equation (v' , e') ; C_equation (v' , e') ;
C_equation (P_variable whole_expr , P_constant (C_unit , [])) 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 -> fun e annot ->
let e' = type_expression_to_type_value e in let e' = type_expression_to_type_value e in
let annot' = type_expression_to_type_value annot in let annot' = type_expression_to_type_value annot in
@ -304,14 +309,14 @@ module Wrap = struct
O.[ O.[
C_equation (e' , annot') ; C_equation (e' , annot') ;
C_equation (e' , P_variable whole_expr) 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 -> fun es ->
let whole_expr = Core.fresh_type_variable () in let whole_expr = Core.fresh_type_variable () in
let type_values = (List.map type_expression_to_type_value es) 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 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 () = let fresh_binder () =
Core.fresh_type_variable () Core.fresh_type_variable ()
@ -320,7 +325,7 @@ module Wrap = struct
: T.type_value -> : T.type_value ->
T.type_value option -> T.type_value option ->
T.type_value option -> T.type_value option ->
(constraints * T.type_name) = (constraints * T.type_variable) =
fun fresh arg body -> fun fresh arg body ->
let whole_expr = Core.fresh_type_variable () in let whole_expr = Core.fresh_type_variable () in
let unification_arg = 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 , C_equation (P_variable whole_expr ,
P_constant (C_arrow , [P_variable unification_arg ; P_constant (C_arrow , [P_variable unification_arg ;
P_variable unification_body])) P_variable unification_body]))
] @ arg' @ body' , Type_name whole_expr ] @ arg' @ body' , whole_expr
end end
(* begin unionfind *) (* begin unionfind *)
module TV = module TypeVariable =
struct struct
type t = Core.type_variable type t = Core.type_variable
let compare = String.compare let compare a b= Var.compare a b
let to_string = (fun s -> s) let to_string = (fun s -> Format.asprintf "%a" Var.pp s)
end end
module UF = Union_find.Partition0.Make(TV) module UF = Union_find.Partition0.Make(TypeVariable)
type unionfind = UF.t type unionfind = UF.t
(* end unionfind *) (* end unionfind *)
(* representant for an equivalence class of type variables *) (* representant for an equivalence class of type variables *)
module TypeVariable = String
module TypeVariableMap = Map.Make(TypeVariable) module TypeVariableMap = Map.Make(TypeVariable)
@ -716,7 +721,7 @@ let rec compare_list f = function
compare_list f tl1 tl2) compare_list f tl1 tl2)
| [] -> (function [] -> 0 | _::_ -> -1) (* This follows the behaviour of Pervasives.compare for lists of different length *) | [] -> (function [] -> 0 | _::_ -> -1) (* This follows the behaviour of Pervasives.compare for lists of different length *)
let compare_type_variable a b = let compare_type_variable a b =
String.compare a b Var.compare a b
let compare_label = function let compare_label = function
| L_int a -> (function L_int b -> Int.compare a b | L_string _ -> -1) | 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) | 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 | C_arrow -> (function
(* N/A -> 1 *) (* N/A -> 1 *)
| C_arrow -> 0 | 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_option -> (function
| C_arrow -> 1 | C_arrow -> 1
| C_option -> 0 | 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_tuple -> (function
| C_arrow | C_option -> 1 | C_arrow | C_option -> 1
| C_tuple -> 0 | 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_record -> (function
| C_arrow | C_option | C_tuple -> 1 | C_arrow | C_option | C_tuple -> 1
| C_record -> 0 | 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_variant -> (function
| C_arrow | C_option | C_tuple | C_record -> 1 | C_arrow | C_option | C_tuple | C_record -> 1
| C_variant -> 0 | 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_map -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant -> 1 | C_arrow | C_option | C_tuple | C_record | C_variant -> 1
| C_map -> 0 | 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_big_map -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map -> 1 | C_arrow | C_option | C_tuple | C_record | C_variant | C_map -> 1
| C_big_map -> 0 | 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_list -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map -> 1 | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map -> 1
| C_list -> 0 | 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_set -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list -> 1 | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list -> 1
| C_set -> 0 | 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_unit -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set -> 1 | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set -> 1
| C_unit -> 0 | 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_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_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_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_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_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_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_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_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_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_mutez | 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 -> (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_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 | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_timestamp -> (function | 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_timestamp -> 0
| C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_int -> (function | 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_int -> 0
| C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_address -> (function | 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_address -> 0
| C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_bytes -> (function | 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_bytes -> 0
| C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_key_hash -> (function | 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_hash -> 0
| C_key | C_signature | C_operation | C_contract -> -1) | C_key | C_signature | C_operation | C_contract -> -1)
| C_key -> (function | 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_key -> 0
| C_signature | C_operation | C_contract -> -1) | C_signature | C_operation | C_contract -> -1)
| C_signature -> (function | 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_signature -> 0
| C_operation | C_contract -> -1) | C_operation | C_contract -> -1)
| C_operation -> (function | 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_operation -> 0
| C_contract -> -1) | C_contract -> -1)
| C_contract -> (function | 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 | C_contract -> 0
(* N/A -> -1 *) (* N/A -> -1 *)
) )
@ -826,7 +831,7 @@ and compare_type_value = function
| P_apply _ -> -1) | P_apply _ -> -1)
| P_variable a -> (function | P_variable a -> (function
| P_forall _ -> 1 | P_forall _ -> 1
| P_variable b -> String.compare a b | P_variable b -> compare_type_variable a b
| P_constant _ -> -1 | P_constant _ -> -1
| P_apply _ -> -1) | P_apply _ -> -1)
| P_constant (a1, a2) -> (function | P_constant (a1, a2) -> (function

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

@ -4,8 +4,6 @@ module I = Ast_simplified
module O = Ast_typed module O = Ast_typed
open O.Combinators open O.Combinators
module SMap = O.SMap
module Environment = O.Environment module Environment = O.Environment
module Solver = Solver module Solver = Solver
@ -13,28 +11,28 @@ module Solver = Solver
type environment = Environment.t type environment = Environment.t
module Errors = struct 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 title = (thunk "unbound type variable") in
let message () = "" in let message () = "" in
let data = [ 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. *) (* TODO: types don't have srclocs for now. *)
(* ("location" , fun () -> Format.asprintf "%a" Location.pp (n.location)) ; *) (* ("location" , fun () -> Format.asprintf "%a" Location.pp (n.location)) ; *)
("in" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ("in" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e)
] in ] in
error ~data title message () 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 title = (thunk "unbound variable") in
let message () = "" in let message () = "" in
let data = [ 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) ; ("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc) ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in ] in
error ~data title message () 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 () -> fun matching loc () ->
let title = (thunk "match with no cases") in let title = (thunk "match with no cases") in
let message () = "" in let message () = "" in
@ -44,7 +42,7 @@ module Errors = struct
] in ] in
error ~data title message () 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 () -> fun matching loc () ->
let title = (thunk "missing case in match") in let title = (thunk "missing case in match") in
let message () = "" in let message () = "" in
@ -54,7 +52,7 @@ module Errors = struct
] in ] in
error ~data title message () 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 () -> fun matching loc () ->
let title = (thunk "missing case in match") in let title = (thunk "missing case in match") in
let message () = "" in let message () = "" in
@ -64,25 +62,16 @@ module Errors = struct
] in ] in
error ~data title message () 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 title = (thunk "unbound constructor") in
let message () = "" in let message () = "" in
let data = [ 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) ; ("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc) ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in ] in
error ~data title message () 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 wrong_arity (n:string) (expected:int) (actual:int) (loc : Location.t) () =
let title () = "wrong arity" in let title () = "wrong arity" in
let message () = "" in let message () = "" in
@ -113,11 +102,11 @@ module Errors = struct
] in ] in
error ~data title message () 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 title = (thunk "typing constant declaration") in
let message () = "" in let message () = "" in
let data = [ 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) ; ("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
("expected" , fun () -> ("expected" , fun () ->
match expected with match expected with
@ -127,7 +116,7 @@ module Errors = struct
] in ] in
error ~data title message () 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 () -> fun ?(msg = "") ~expected ~actual loc () ->
let title = (thunk "typing match") in let title = (thunk "typing match") in
let message () = msg in let message () = msg in
@ -199,15 +188,6 @@ module Errors = struct
] in ] in
error ~data title message () 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 end
open Errors 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')))) 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 fun e state t i ae loc -> match i with
| Match_bool {match_true ; match_false} -> | Match_bool {match_true ; match_false} ->
let%bind _ = 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) trace_strong (match_error ~expected:i ~actual:t loc)
@@ get_t_option t in @@ get_t_option t in
let%bind (match_none , state') = type_expression e state match_none in let%bind (match_none , state') = type_expression e state match_none in
let (n, b) = match_some in let (n, b, _) = match_some in
let n' = n, t_opt in
let e' = Environment.add_ez_binder n t_opt e in let e' = Environment.add_ez_binder n t_opt e in
let%bind (b' , state'') = type_expression e' state' b 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} -> | Match_list {match_nil ; match_cons} ->
let%bind t_list = let%bind t_elt =
trace_strong (match_error ~expected:i ~actual:t loc) trace_strong (match_error ~expected:i ~actual:t loc)
@@ get_t_list t in @@ get_t_list t in
let%bind (match_nil , state') = type_expression e state match_nil in let%bind (match_nil , state') = type_expression e state match_nil in
let (hd, tl, b) = match_cons in let (hd, tl, b, _) = match_cons in
let e' = Environment.add_ez_binder hd t_list e in let e' = Environment.add_ez_binder hd t_elt e in
let e' = Environment.add_ez_binder tl t e' in let e' = Environment.add_ez_binder tl t e' in
let%bind (b' , state'') = type_expression e' state' b 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'') ok (O.Match_list {match_nil ; match_cons = (hd, tl, b',t)} , state'')
| Match_tuple (lst, b) -> | Match_tuple ((lst, b),_) ->
let%bind t_tuple = let%bind t_tuple =
trace_strong (match_error ~expected:i ~actual:t loc) trace_strong (match_error ~expected:i ~actual:t loc)
@@ get_t_tuple t in @@ 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 aux prev (name, tv) = Environment.add_ez_binder name tv prev in
let e' = List.fold_left aux e lst' in let e' = List.fold_left aux e lst' in
let%bind (b' , state') = type_expression e' state b in let%bind (b' , state') = type_expression e' state b in
ok (O.Match_tuple (lst, b') , state') ok (O.Match_tuple ((lst, b'), t_tuple) , state')
| Match_variant lst -> | Match_variant (lst,_) ->
let%bind variant_opt = let%bind variant_opt =
let aux acc ((constructor_name , _) , _) = let aux acc ((constructor_name , _) , _) =
let%bind (_ , variant) = let%bind (_ , variant) =
@ -318,7 +297,7 @@ and type_match : environment -> Solver.state -> O.type_value -> 'i I.matching ->
let%bind variant_cases' = let%bind variant_cases' =
trace (match_error ~expected:i ~actual:t loc) trace (match_error ~expected:i ~actual:t loc)
@@ Ast_typed.Combinators.get_t_sum variant in @@ 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 match_cases = List.map (Function.compose fst fst) lst in
let test_case = fun c -> let test_case = fun c ->
Assert.assert_true (List.mem c match_cases) 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 = and evaluate_type (e:environment) (t:I.type_expression) : O.type_value result =
let return tv' = ok (make_t tv' (Some t)) in let return tv' = ok (make_t tv' (Some t)) in
match t with match t.type_expression' with
| T_function (a, b) -> | T_arrow (a, b) ->
let%bind a' = evaluate_type e a in let%bind a' = evaluate_type e a in
let%bind b' = evaluate_type e b in let%bind b' = evaluate_type e b in
return (T_function (a', b')) return (T_arrow (a', b'))
| T_tuple lst -> | T_tuple lst ->
let%bind lst' = bind_list @@ List.map (evaluate_type e) lst in let%bind lst' = bind_list @@ List.map (evaluate_type e) lst in
return (T_tuple lst') 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 aux k v prev =
let%bind prev' = prev in let%bind prev' = prev in
let%bind v' = evaluate_type e v in let%bind v' = evaluate_type e v in
ok @@ SMap.add k v' prev' ok @@ I.CMap.add k v' prev'
in 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) return (T_sum m)
| T_record m -> | T_record m ->
let aux k v prev = let aux k v prev =
let%bind prev' = prev in let%bind prev' = prev in
let%bind v' = evaluate_type e v in let%bind v' = evaluate_type e v in
ok @@ SMap.add k v' prev' ok @@ I.LMap.add k v' prev'
in 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) return (T_record m)
| T_variable name -> | T_variable name ->
let%bind tv = let%bind tv =
trace_option (unbound_type_variable e name) trace_option (unbound_type_variable e name)
@@ Environment.get_type_opt name e in @@ Environment.get_type_opt name e in
ok tv ok tv
| T_constant (cst, lst) -> | T_constant cst ->
let%bind lst' = bind_list @@ List.map (evaluate_type e) lst in return (T_constant cst)
return (T_constant(Type_name cst, lst')) | 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 -> 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. *) 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]) -> ( | E_accessor (base , [Access_record property]) -> (
let%bind (base' , state') = type_expression e state base in let%bind (base' , state') = type_expression e state base in
let wrapped = Wrap.access_string ~base:base'.type_annotation ~property 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 , _ :: _ :: _) -> ( | E_accessor (_base , []) | E_accessor (_base , _ :: _ :: _) -> (
failwith failwith
@ -505,8 +507,9 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
let error = let error =
let title () = "no such constructor" in let title () = "no such constructor" in
let content () = let content () =
Format.asprintf "%s in:\n%a\n" Format.asprintf "%a in:\n%a\n"
c O.Environment.PP.full_environment e Stage_common.PP.constructor c
O.Environment.PP.full_environment e
in in
error title content in error title content in
trace_option error @@ trace_option error @@
@ -520,10 +523,10 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
| E_record m -> | E_record m ->
let aux (acc, state) k expr = let aux (acc, state) k expr =
let%bind (expr' , state') = type_expression e state expr in 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 in
let%bind (m' , state') = bind_fold_smap aux (ok (SMap.empty , state)) m in let%bind (m' , state') = I.bind_fold_lmap aux (ok (I.LMap.empty , state)) m in
let wrapped = Wrap.record (SMap.map get_type_annotation m') in let wrapped = Wrap.record (I.LMap.map get_type_annotation m') in
return_wrapped (E_record m') state' wrapped return_wrapped (E_record m') state' wrapped
(* Data-structure *) (* 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 m = get_t_record prec_tv in
let%bind tv' = let%bind tv' =
trace_option (bad_record_access property ae prec_tv ae.location) @@ 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]) ok (tv' , prec_path @ [O.Access_record property])
) )
in 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%bind (expr' , state') = type_expression e state expr in
let wrapped = Wrap.assign assign_tv expr'.type_annotation in let wrapped = Wrap.assign assign_tv expr'.type_annotation in
return_wrapped (O.E_assign (typed_name , path' , expr')) state' wrapped 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 tv = evaluate_type e te in
let%bind (expr' , state') = type_expression e state expr in let%bind (expr' , state') = type_expression e state expr in
let wrapped = Wrap.annotation expr'.type_annotation tv 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 (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%bind (m' , state'') = type_match e state' ex'.type_annotation m ae ae.location in
let tvs = let tvs =
let aux (cur:O.value O.matching) = let aux (cur:(O.value, O.type_value) O.matching) =
match cur with match cur with
| Match_bool { match_true ; match_false } -> [ match_true ; match_false ] | Match_bool { match_true ; match_false } -> [ match_true ; match_false ]
| Match_list { match_nil ; match_cons = ((_ , _) , match_cons) } -> [ match_nil ; match_cons ] | 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_option { match_none ; match_some = (_ , match_some, _) } -> [ match_none ; match_some ]
| Match_tuple (_ , match_tuple) -> [ match_tuple ] | Match_tuple ((_ , match_tuple), _) -> [ match_tuple ]
| Match_variant (lst , _) -> List.map snd lst in | Match_variant (lst , _) -> List.map snd lst in
List.map get_type_annotation @@ aux m' in List.map get_type_annotation @@ aux m' in
let%bind () = match tvs with 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 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%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 e' = Environment.add_ez_binder (fst binder) fresh e in
let%bind (result , state') = type_expression e' state result 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 *) (* 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 = and type_constant (name:I.constant) (lst:O.type_value list) (tv_opt:O.type_value option) : (O.constant * O.type_value) result =
(* Constant poorman's polymorphism *) let%bind typer = Operators.Typer.constant_typers name in
let ct = Operators.Typer.constant_typers in let%bind tv = typer lst tv_opt in
let%bind typer = ok(name, tv)
trace_option (unrecognized_constant name loc) @@
Map.String.find_opt name ct in
trace (constant_error loc lst tv_opt) @@
typer lst tv_opt
let untype_type_value (t:O.type_value) : (I.type_expression) result = let untype_type_value (t:O.type_value) : (I.type_expression) result =
match t.simplified with 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 let () = ignore (env' , state') in
ok (env', state', declarations) 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 type_program (p : I.program) : (O.program * Solver.state) result =
let%bind (env, state, program) = type_program_returns_state p in let%bind (env, state, program) = type_program_returns_state p in
let subst_all = let subst_all =
let assignments = state.structured_dbs.assignments in 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 let%bind p = p in
Typesystem.Misc.Substitution.Pattern.program ~p ~v ~expr 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 *) (* 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 = let rec untype_type_expression (t:O.type_value) : (I.type_expression) result =
(* TODO: or should we use t.simplified if present? *) (* 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 -> | O.T_tuple x ->
let%bind x' = bind_map_list untype_type_expression x in let%bind x' = bind_map_list untype_type_expression x in
ok @@ I.T_tuple x' ok @@ I.T_tuple x'
| O.T_sum 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' ok @@ I.T_sum x'
| O.T_record 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' ok @@ I.T_record x'
| O.T_constant (Type_name tag, args) -> | O.T_constant (tag) ->
let%bind args' = bind_map_list untype_type_expression args in ok @@ I.T_constant (tag)
ok @@ I.T_constant (tag, args') | O.T_variable (name) -> ok @@ I.T_variable name (* TODO: is this the right conversion? *)
| O.T_variable (Type_name name) -> ok @@ I.T_variable name (* TODO: is this the right conversion? *) | O.T_arrow (a , b) ->
| O.T_function (a , b) ->
let%bind a' = untype_type_expression a in let%bind a' = untype_type_expression a in
let%bind b' = untype_type_expression b 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 *) (* match t.simplified with *)
(* | Some s -> ok s *) (* | Some s -> ok s *)
@ -1030,16 +1054,16 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
| E_literal l -> | E_literal l ->
let%bind l = untype_literal l in let%bind l = untype_literal l in
return (e_literal l) return (e_literal l)
| E_constant (n, lst) -> | E_constant (const, lst) ->
let%bind lst' = bind_map_list untype_expression lst in let%bind lst' = bind_map_list untype_expression lst in
return (e_constant n lst') return (e_constant const lst')
| E_variable n -> | E_variable (n) ->
return (e_variable n) return (e_variable n)
| E_application (f, arg) -> | E_application (f, arg) ->
let%bind f' = untype_expression f in let%bind f' = untype_expression f in
let%bind arg' = untype_expression arg in let%bind arg' = untype_expression arg in
return (e_application f' arg') 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 io = get_t_function e.type_annotation in
let%bind (input_type , output_type) = bind_map_pair untype_type_value io in let%bind (input_type , output_type) = bind_map_pair untype_type_value io in
let%bind result = untype_expression body 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) -> | E_tuple_accessor (tpl, ind) ->
let%bind tpl' = untype_expression tpl in let%bind tpl' = untype_expression tpl in
return (e_accessor tpl' [Access_tuple ind]) return (e_accessor tpl' [Access_tuple ind])
| E_constructor (n, p) -> | E_constructor (Constructor c, p) ->
let%bind p' = untype_expression p in let%bind p' = untype_expression p in
return (e_constructor n p') return (e_constructor c p')
| E_record r -> | 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 let%bind r' = bind_smap
@@ SMap.map untype_expression r in @@ Map.String.map untype_expression r in
return (e_record r') return (e_record r')
| E_record_accessor (r, s) -> | E_record_accessor (r, Label s) ->
let%bind r' = untype_expression r in let%bind r' = untype_expression r in
return (e_accessor r' [Access_record s]) return (e_accessor r' [Access_record s])
| E_map m -> | E_map m ->
@ -1087,7 +1113,7 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
| E_sequence _ | E_sequence _
| E_loop _ | E_loop _
| E_assign _ -> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e.expression | 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 tv = untype_type_value rhs.type_annotation in
let%bind rhs = untype_expression rhs in let%bind rhs = untype_expression rhs in
let%bind result = untype_expression result 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 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 let open I in
match m with match m with
| Match_bool {match_true ; match_false} -> | Match_bool {match_true ; match_false} ->
let%bind match_true = f match_true in let%bind match_true = f match_true in
let%bind match_false = f match_false in let%bind match_false = f match_false in
ok @@ Match_bool {match_true ; match_false} ok @@ Match_bool {match_true ; match_false}
| Match_tuple (lst, b) -> | Match_tuple ((lst, b),_) ->
let%bind b = f b in let%bind b = f b in
ok @@ Match_tuple (lst, b) ok @@ I.Match_tuple ((lst, b),[])
| Match_option {match_none ; match_some = (v, some)} -> | Match_option {match_none ; match_some = (v, some,_)} ->
let%bind match_none = f match_none in let%bind match_none = f match_none in
let%bind some = f some 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} 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 match_nil = f match_nil in
let%bind cons = f cons 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} ok @@ Match_list {match_nil ; match_cons}
| Match_variant (lst , _) -> | Match_variant (lst , _) ->
let aux ((a,b),c) = let aux ((a,b),c) =
let%bind c' = f c in let%bind c' = f c in
ok ((a,b),c') in ok ((a,b),c') in
let%bind lst' = bind_map_list aux lst in let%bind lst' = bind_map_list aux lst in
ok @@ Match_variant lst' 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 e' = Environment.add_ez_declaration (fst binder) rhs e in
let%bind result = type_expression e' result in let%bind result = type_expression e' result in
return (E_let_in {binder = fst binder; rhs; result}) result.type_annotation 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 tv = evaluate_type e te in
let%bind expr' = type_expression ~tv_opt:tv e expr in let%bind expr' = type_expression ~tv_opt:tv e expr in
let%bind type_annotation = 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 I = Ast_simplified
module O = Ast_typed module O = Ast_typed
module SMap = O.SMap
module Environment = O.Environment module Environment = O.Environment
module Solver = Solver 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 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 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_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_type_value : O.type_value -> (I.type_expression) result
val untype_literal : O.literal -> I.literal result val untype_literal : O.literal -> I.literal result

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

@ -4,8 +4,6 @@ module I = Ast_simplified
module O = Ast_typed module O = Ast_typed
open O.Combinators open O.Combinators
module SMap = O.SMap
module Environment = O.Environment module Environment = O.Environment
module Solver = Typer_new.Solver module Solver = Typer_new.Solver
@ -13,28 +11,28 @@ module Solver = Typer_new.Solver
type environment = Environment.t type environment = Environment.t
module Errors = struct 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 title = (thunk "unbound type variable") in
let message () = "" in let message () = "" in
let data = [ 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. *) (* TODO: types don't have srclocs for now. *)
(* ("location" , fun () -> Format.asprintf "%a" Location.pp (n.location)) ; *) (* ("location" , fun () -> Format.asprintf "%a" Location.pp (n.location)) ; *)
("in" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ("in" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e)
] in ] in
error ~data title message () 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 title = (thunk "unbound variable") in
let message () = "" in let message () = "" in
let data = [ 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) ; ("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc) ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in ] in
error ~data title message () 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 () -> fun matching loc () ->
let title = (thunk "match with no cases") in let title = (thunk "match with no cases") in
let message () = "" in let message () = "" in
@ -44,7 +42,7 @@ module Errors = struct
] in ] in
error ~data title message () 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 () -> fun matching loc () ->
let title = (thunk "missing case in match") in let title = (thunk "missing case in match") in
let message () = "" in let message () = "" in
@ -54,7 +52,7 @@ module Errors = struct
] in ] in
error ~data title message () 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 () -> fun matching loc () ->
let title = (thunk "missing case in match") in let title = (thunk "missing case in match") in
let message () = "" in let message () = "" in
@ -64,25 +62,16 @@ module Errors = struct
] in ] in
error ~data title message () 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 title = (thunk "unbound constructor") in
let message () = "" in let message () = "" in
let data = [ 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) ; ("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc) ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in ] in
error ~data title message () 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 wrong_arity (n:string) (expected:int) (actual:int) (loc : Location.t) () =
let title () = "wrong arity" in let title () = "wrong arity" in
let message () = "" in let message () = "" in
@ -113,11 +102,11 @@ module Errors = struct
] in ] in
error ~data title message () 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 title = (thunk "typing constant declaration") in
let message () = "" in let message () = "" in
let data = [ 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) ; ("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
("expected" , fun () -> ("expected" , fun () ->
match expected with match expected with
@ -127,7 +116,7 @@ module Errors = struct
] in ] in
error ~data title message () 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 () -> fun ?(msg = "") ~expected ~actual loc () ->
let title = (thunk "typing match") in let title = (thunk "typing match") in
let message () = msg in let message () = msg in
@ -180,11 +169,11 @@ module Errors = struct
] in ] in
error ~data title message () 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 title = (thunk "invalid record field") in
let message () = "" in let message () = "" in
let data = [ 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) ; ("record_value" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_value t) ; ("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_value t) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc) ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
@ -199,15 +188,6 @@ module Errors = struct
] in ] in
error ~data title message () 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 end
open Errors 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')))) 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 fun f e t i ae loc -> match i with
| Match_bool {match_true ; match_false} -> | Match_bool {match_true ; match_false} ->
let%bind _ = 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) trace_strong (match_error ~expected:i ~actual:t loc)
@@ get_t_option t in @@ get_t_option t in
let%bind match_none = f e match_none in let%bind match_none = f e match_none in
let (n, b) = match_some in let (n, b,_) = match_some in
let n' = n, t_opt in
let e' = Environment.add_ez_binder n t_opt e in let e' = Environment.add_ez_binder n t_opt e in
let%bind b' = f e' b 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} -> | Match_list {match_nil ; match_cons} ->
let%bind t_list = let%bind t_elt =
trace_strong (match_error ~expected:i ~actual:t loc) trace_strong (match_error ~expected:i ~actual:t loc)
@@ get_t_list t in @@ get_t_list t in
let%bind match_nil = f e match_nil in let%bind match_nil = f e match_nil in
let (hd, tl, b) = match_cons in let (hd, tl, b,_) = match_cons in
let e' = Environment.add_ez_binder hd t_list e in let e' = Environment.add_ez_binder hd t_elt e in
let e' = Environment.add_ez_binder tl t e' in let e' = Environment.add_ez_binder tl t e' in
let%bind b' = f e' b in let%bind b' = f e' b in
ok (O.Match_list {match_nil ; match_cons = (((hd , t_list), (tl , t)), b')}) ok (O.Match_list {match_nil ; match_cons = (hd, tl, b', t_elt)})
| Match_tuple (lst, b) -> | Match_tuple ((lst, b),_) ->
let%bind t_tuple = let%bind t_tuple =
trace_strong (match_error ~expected:i ~actual:t loc) trace_strong (match_error ~expected:i ~actual:t loc)
@@ get_t_tuple t in @@ 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 aux prev (name, tv) = Environment.add_ez_binder name tv prev in
let e' = List.fold_left aux e lst' in let e' = List.fold_left aux e lst' in
let%bind b' = f e' b in let%bind b' = f e' b in
ok (O.Match_tuple (lst, b')) ok (O.Match_tuple ((lst, b'),t_tuple))
| Match_variant lst -> | Match_variant (lst,_) ->
let%bind variant_opt = let%bind variant_opt =
let aux acc ((constructor_name , _) , _) = let aux acc ((constructor_name , _) , _) =
let%bind (_ , variant) = let%bind (_ , variant) =
@ -308,7 +287,7 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
let%bind variant_cases' = let%bind variant_cases' =
trace (match_error ~expected:i ~actual:t loc) trace (match_error ~expected:i ~actual:t loc)
@@ Ast_typed.Combinators.get_t_sum variant in @@ 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 match_cases = List.map (Function.compose fst fst) lst in
let test_case = fun c -> let test_case = fun c ->
Assert.assert_true (List.mem c match_cases) 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 = and evaluate_type (e:environment) (t:I.type_expression) : O.type_value result =
let return tv' = ok (make_t tv' (Some t)) in let return tv' = ok (make_t tv' (Some t)) in
match t with match t.type_expression' with
| T_function (a, b) -> | T_arrow (a, b) ->
let%bind a' = evaluate_type e a in let%bind a' = evaluate_type e a in
let%bind b' = evaluate_type e b in let%bind b' = evaluate_type e b in
return (T_function (a', b')) return (T_arrow (a', b'))
| T_tuple lst -> | T_tuple lst ->
let%bind lst' = bind_list @@ List.map (evaluate_type e) lst in let%bind lst' = bind_list @@ List.map (evaluate_type e) lst in
return (T_tuple lst') 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 aux k v prev =
let%bind prev' = prev in let%bind prev' = prev in
let%bind v' = evaluate_type e v in let%bind v' = evaluate_type e v in
ok @@ SMap.add k v' prev' ok @@ I.CMap.add k v' prev'
in 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) return (T_sum m)
| T_record m -> | T_record m ->
let aux k v prev = let aux k v prev =
let%bind prev' = prev in let%bind prev' = prev in
let%bind v' = evaluate_type e v in let%bind v' = evaluate_type e v in
ok @@ SMap.add k v' prev' ok @@ I.LMap.add k v' prev'
in 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) return (T_record m)
| T_variable name -> | T_variable name ->
let%bind tv = let%bind tv =
trace_option (unbound_type_variable e name) trace_option (unbound_type_variable e name)
@@ Environment.get_type_opt name e in @@ Environment.get_type_opt name e in
ok tv ok tv
| T_constant (cst, lst) -> | T_constant cst ->
let%bind lst' = bind_list @@ List.map (evaluate_type e) lst in return (T_constant cst)
return (T_constant(Type_name cst, lst')) | 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 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 -> = 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 ok @@ make_a_e ~location (E_tuple_accessor(prev , index)) tv e
) )
| Access_record property -> ( | Access_record property -> (
let property = I.Label property in
let%bind r_tv = get_t_record prev.type_annotation in let%bind r_tv = get_t_record prev.type_annotation in
let%bind tv = let%bind tv =
generic_try (bad_record_access property ae' prev.type_annotation ae.location) 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 let location = ae.location in
ok @@ make_a_e ~location (E_record_accessor (prev , property)) tv e 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 error =
let title () = "no such constructor" in let title () = "no such constructor" in
let content () = let content () =
Format.asprintf "%s in:\n%a\n" Format.asprintf "%a in:\n%a\n"
c O.Environment.PP.full_environment e Stage_common.PP.constructor c
O.Environment.PP.full_environment e
in in
error title content in error title content in
trace_option error @@ trace_option error @@
@ -482,10 +486,10 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
| E_record m -> | E_record m ->
let aux prev k expr = let aux prev k expr =
let%bind expr' = type_expression' e expr in let%bind expr' = type_expression' e expr in
ok (SMap.add k expr' prev) ok (I.LMap.add k expr' prev)
in in
let%bind m' = bind_fold_smap aux (ok SMap.empty) m in let%bind m' = I.bind_fold_lmap aux (ok I.LMap.empty) m in
return (E_record m') (t_record (SMap.map get_type_annotation m') ()) return (E_record m') (t_record (I.LMap.map get_type_annotation m') ())
(* Data-structure *) (* Data-structure *)
| E_list lst -> | E_list lst ->
let%bind lst' = bind_map_list (type_expression' e) lst in 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 let output_type = body.type_annotation in
return (E_lambda {binder = fst binder ; body}) (t_function input_type output_type ()) 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) ; ( { expression = (I.E_lambda { binder = (lname, None) ;
input_type = 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_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 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 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_operator ( TC_list t | TC_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_map (k,v)| TC_big_map (k,v)) -> ok @@ t_tuple (tv_out::[(t_tuple [k;v] ())]) ()
| _ -> | _ ->
let wtype = Format.asprintf let wtype = Format.asprintf
"Loops over collections expect lists, sets or maps, got type %a" O.PP.type_value tv_col in "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 lst' = [lambda'; v_col; v_initr] in
let tv_lst = List.map get_type_annotation lst' in let tv_lst = List.map get_type_annotation lst' in
let%bind (opname', tv) = 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 return (E_constant (opname' , lst')) tv
| E_constant (name, lst) -> | E_constant (name, lst) ->
let%bind lst' = bind_list @@ List.map (type_expression' e) lst in let%bind lst' = bind_list @@ List.map (type_expression' e) lst in
let tv_lst = List.map get_type_annotation lst' in let tv_lst = List.map get_type_annotation lst' in
let%bind (name', tv) = 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 return (E_constant (name' , lst')) tv
| E_application (f, arg) -> | E_application (f, arg) ->
let%bind f' = type_expression' e f in let%bind f' = type_expression' e f in
let%bind arg = type_expression' e arg in let%bind arg = type_expression' e arg in
let%bind tv = match f'.type_annotation.type_value' with 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 let%bind _ = O.assert_type_value_eq (param, arg.type_annotation) in
ok result 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 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%bind m' = type_match (type_expression' ?tv_opt:None) e ex'.type_annotation m ae ae.location in
let tvs = let tvs =
let aux (cur:O.value O.matching) = let aux (cur:(O.value, O.type_value) O.matching) =
match cur with match cur with
| Match_bool { match_true ; match_false } -> [ match_true ; match_false ] | Match_bool { match_true ; match_false } -> [ match_true ; match_false ]
| Match_list { match_nil ; match_cons = ((_ , _) , match_cons) } -> [ match_nil ; match_cons ] | 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_option { match_none ; match_some = (_ , match_some, _) } -> [ match_none ; match_some ]
| Match_tuple (_ , match_tuple) -> [ match_tuple ] | Match_tuple ((_ , match_tuple), _) -> [ match_tuple ]
| Match_variant (lst , _) -> List.map snd lst in | Match_variant (lst , _) -> List.map snd lst in
List.map get_type_annotation @@ aux m' in List.map get_type_annotation @@ aux m' in
let aux prec cur = let aux prec cur =
@ -758,8 +762,8 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
| Access_record property -> ( | Access_record property -> (
let%bind m = get_t_record prec_tv in let%bind m = get_t_record prec_tv in
let%bind tv' = let%bind tv' =
trace_option (bad_record_access property ae prec_tv ae.location) @@ trace_option (bad_record_access (Label 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]) ok (tv' , prec_path @ [O.Access_record property])
) )
in 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 e' = Environment.add_ez_declaration (fst binder) rhs e in
let%bind result = type_expression' e' result in let%bind result = type_expression' e' result in
return (E_let_in {binder = fst binder; rhs; result}) result.type_annotation 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 tv = evaluate_type e te in
let%bind expr' = type_expression' ~tv_opt:tv e expr in let%bind expr' = type_expression' ~tv_opt:tv e expr in
let%bind type_annotation = 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} 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 = and type_constant (name:I.constant) (lst:O.type_value list) (tv_opt:O.type_value option) : (O.constant * O.type_value) result =
(* Constant poorman's polymorphism *) let%bind typer = Operators.Typer.constant_typers name in
let ct = Operators.Typer.constant_typers in let%bind tv = typer lst tv_opt in
let%bind typer = ok(name, tv)
trace_option (unrecognized_constant name loc) @@
Map.String.find_opt name ct in
trace (constant_error loc lst tv_opt) @@
typer lst tv_opt
let untype_type_value (t:O.type_value) : (I.type_expression) result = let untype_type_value (t:O.type_value) : (I.type_expression) result =
match t.simplified with match t.simplified with
@ -831,9 +831,9 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
| E_literal l -> | E_literal l ->
let%bind l = untype_literal l in let%bind l = untype_literal l in
return (e_literal l) return (e_literal l)
| E_constant (n, lst) -> | E_constant (const, lst) ->
let%bind lst' = bind_map_list untype_expression lst in let%bind lst' = bind_map_list untype_expression lst in
return (e_constant n lst') return (e_constant const lst')
| E_variable n -> | E_variable n ->
return (e_variable n) return (e_variable n)
| E_application (f, arg) -> | E_application (f, arg) ->
@ -853,14 +853,16 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
| E_tuple_accessor (tpl, ind) -> | E_tuple_accessor (tpl, ind) ->
let%bind tpl' = untype_expression tpl in let%bind tpl' = untype_expression tpl in
return (e_accessor tpl' [Access_tuple ind]) return (e_accessor tpl' [Access_tuple ind])
| E_constructor (n, p) -> | E_constructor ( Constructor n, p) ->
let%bind p' = untype_expression p in let%bind p' = untype_expression p in
return (e_constructor n p') return (e_constructor n p')
| E_record r -> | 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 let%bind r' = bind_smap
@@ SMap.map untype_expression r in @@ Map.String.map untype_expression r in
return (e_record r') return (e_record r')
| E_record_accessor (r, s) -> | E_record_accessor (r, Label s) ->
let%bind r' = untype_expression r in let%bind r' = untype_expression r in
return (e_accessor r' [Access_record s]) return (e_accessor r' [Access_record s])
| E_map m -> | 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 let%bind result = untype_expression result in
return (e_let_in (binder , (Some tv)) rhs result) 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 let open I in
match m with match m with
| Match_bool {match_true ; match_false} -> | Match_bool {match_true ; match_false} ->
let%bind match_true = f match_true in let%bind match_true = f match_true in
let%bind match_false = f match_false in let%bind match_false = f match_false in
ok @@ Match_bool {match_true ; match_false} ok @@ Match_bool {match_true ; match_false}
| Match_tuple (lst, b) -> | Match_tuple ((lst, b),_) ->
let%bind b = f b in let%bind b = f b in
ok @@ Match_tuple (lst, b) ok @@ I.Match_tuple ((lst, b),[])
| Match_option {match_none ; match_some = (v, some)} -> | Match_option {match_none ; match_some = (v, some,_)} ->
let%bind match_none = f match_none in let%bind match_none = f match_none in
let%bind some = f some 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} 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 match_nil = f match_nil in
let%bind cons = f cons 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} ok @@ Match_list {match_nil ; match_cons}
| Match_variant (lst , _) -> | Match_variant (lst , _) ->
let aux ((a,b),c) = let aux ((a,b),c) =
let%bind c' = f c in let%bind c' = f c in
ok ((a,b),c') in ok ((a,b),c') in
let%bind lst' = bind_map_list aux lst 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 I = Ast_simplified
module O = Ast_typed module O = Ast_typed
module SMap = O.SMap
module Environment = O.Environment module Environment = O.Environment
module Solver : module type of Typer_new.Solver 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 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 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_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_type_value : O.type_value -> (I.type_expression) result
val untype_literal : O.literal -> I.literal 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 I = Ast_simplified
module O = Ast_typed module O = Ast_typed
module SMap = O.SMap
module Environment = O.Environment module Environment = O.Environment
module Solver = Typer_new.Solver (* Both the old typer and the new typer use the same solver state. *) 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 I = Ast_simplified
module O = Ast_typed module O = Ast_typed
module SMap = O.SMap
module Environment = O.Environment module Environment = O.Environment
module Solver = Typer_new.Solver 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_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 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 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 Trace
open Mini_c 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 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 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 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 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 extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value * AST.type_value) result =
let open Append_tree in let open Append_tree in
let rec aux tv : (string * value * AST.type_value) result= let rec aux tv : (string * value * AST.type_value) result=
match tv with 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 {a}, D_left v -> aux (a, v)
| Node {b}, D_right v -> aux (b, v) | Node {b}, D_right v -> aux (b, v)
| _ -> fail @@ internal_assertion_failure "bad constructor path" | _ -> 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 extract_record (v : value) (tree : _ Append_tree.t') : (_ list) result =
let open Append_tree in 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 match tv with
| Leaf (s, t), v -> ok @@ [s, (v, t)] | Leaf (s, t), v -> ok @@ [s, (v, t)]
| Node {a;b}, D_pair (va, vb) -> | 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 *) 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! Trace
open Helpers open Helpers
@ -29,14 +27,9 @@ them. please report this to the developers." in
] in ] in
error ~data title content 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 no_type_variable name =
let title () = "type variables can't be transpiled" in 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 error title content
let row_loc l = ("location" , fun () -> Format.asprintf "%a" Location.pp l) 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 = let rec transpile_type (t:AST.type_value) : type_value result =
match t.type_value' with match t.type_value' with
| T_variable (Type_name name) -> fail @@ no_type_variable name | T_variable (name) -> fail @@ no_type_variable @@ name
| T_constant (Type_name "bool", []) -> ok (T_base Base_bool) | T_constant (TC_bool) -> ok (T_base Base_bool)
| T_constant (Type_name "int", []) -> ok (T_base Base_int) | T_constant (TC_int) -> ok (T_base Base_int)
| T_constant (Type_name "nat", []) -> ok (T_base Base_nat) | T_constant (TC_nat) -> ok (T_base Base_nat)
| T_constant (Type_name "tez", []) -> ok (T_base Base_tez) | T_constant (TC_mutez) -> ok (T_base Base_mutez)
| T_constant (Type_name "string", []) -> ok (T_base Base_string) | T_constant (TC_string) -> ok (T_base Base_string)
| T_constant (Type_name "bytes", []) -> ok (T_base Base_bytes) | T_constant (TC_bytes) -> ok (T_base Base_bytes)
| T_constant (Type_name "address", []) -> ok (T_base Base_address) | T_constant (TC_address) -> ok (T_base Base_address)
| T_constant (Type_name "timestamp", []) -> ok (T_base Base_timestamp) | T_constant (TC_timestamp) -> ok (T_base Base_timestamp)
| T_constant (Type_name "unit", []) -> ok (T_base Base_unit) | T_constant (TC_unit) -> ok (T_base Base_unit)
| T_constant (Type_name "operation", []) -> ok (T_base Base_operation) | T_constant (TC_operation) -> ok (T_base Base_operation)
| T_constant (Type_name "signature", []) -> ok (T_base Base_signature) | T_constant (TC_signature) -> ok (T_base Base_signature)
| T_constant (Type_name "key_hash", []) -> ok (T_base Base_key_hash) | T_constant (TC_key) -> ok (T_base Base_key)
| T_constant (Type_name "key", []) -> ok (T_base Base_key) | T_constant (TC_key_hash) -> ok (T_base Base_key_hash)
| T_constant (Type_name "chain_id", []) -> ok (T_base Base_chain_id) | T_constant (TC_chain_id) -> ok (T_base Base_chain_id)
| T_constant (Type_name "contract", [x]) -> | T_operator (TC_contract x) ->
let%bind x' = transpile_type x in let%bind x' = transpile_type x in
ok (T_contract x') 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 let%bind kv' = bind_map_pair transpile_type (key, value) in
ok (T_map kv') 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 let%bind kv' = bind_map_pair transpile_type (key, value) in
ok (T_big_map kv') ok (T_big_map kv')
| T_constant (Type_name "list", [t]) -> | T_operator (TC_list t) ->
let%bind t' = transpile_type t in let%bind t' = transpile_type t in
ok (T_list t') ok (T_list t')
| T_constant (Type_name "set", [t]) -> | T_operator (TC_set t) ->
let%bind t' = transpile_type t in let%bind t' = transpile_type t in
ok (T_set t') ok (T_set t')
| T_constant (Type_name "option", [o]) -> | T_operator (TC_option o) ->
let%bind o' = transpile_type o in let%bind o' = transpile_type o in
ok (T_option o') ok (T_option o')
| T_constant (Type_name name , _lst) -> fail @@ unrecognized_type_constant name
(* TODO hmm *) (* TODO hmm *)
| T_sum m -> | 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 aux a b : type_value annotated result =
let%bind a = a in let%bind a = a in
let%bind b = b in let%bind b = b in
ok (None, T_or (a, b)) ok (None, T_or (a, b))
in in
let%bind m' = Append_tree.fold_ne let%bind m' = Append_tree.fold_ne
(fun (ann, a) -> (fun (Constructor ann, a) ->
let%bind a = transpile_type a in let%bind a = transpile_type a in
ok (Some (String.uncapitalize_ascii ann), a)) ok (Some (String.uncapitalize_ascii ann), a))
aux node in aux node in
ok @@ snd m' ok @@ snd m'
| T_record 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 aux a b : type_value annotated result =
let%bind a = a in let%bind a = a in
let%bind b = b in let%bind b = b in
ok (None, T_pair (a, b)) ok (None, T_pair (a, b))
in in
let%bind m' = Append_tree.fold_ne let%bind m' = Append_tree.fold_ne
(fun (ann, a) -> (fun (Label ann, a) ->
let%bind a = transpile_type a in let%bind a = transpile_type a in
ok (Some ann, a)) ok (Some ann, a))
aux node in 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))) ok (T_pair ((None, a), (None, b)))
in in
Append_tree.fold_ne transpile_type aux node 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 param' = transpile_type param in
let%bind result' = transpile_type result in let%bind result' = transpile_type result in
ok (T_function (param', result')) 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 bind_fold_list aux (ty , []) lr_path in
ok lst 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 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_map tym in let tys = kv_list_of_lmap tym in
let node_tv = Append_tree.of_list tys in let node_tv = Append_tree.of_list tys in
let%bind path = 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") @@ trace_option (corner_case ~loc:__LOC__ "record access leaf") @@
Append_tree.exists_path aux node_tv in Append_tree.exists_path aux node_tv in
let lr_path = List.map (fun b -> if b then `Right else `Left) path 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 -> and transpile_environment_element_type : AST.environment_element -> type_value result = fun ele ->
transpile_type ele.type_value 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 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 = and transpile_annotated_expression (ae:AST.annotated_expression) : expression result =
let%bind tv = transpile_type ae.type_annotation in 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} -> | E_let_in {binder; rhs; result} ->
let%bind rhs' = transpile_annotated_expression rhs in let%bind rhs' = transpile_annotated_expression rhs in
let%bind result' = transpile_annotated_expression result 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_literal l -> return @@ E_literal (transpile_literal l)
| E_variable name -> ( | E_variable name -> (
let%bind ele = let%bind ele =
trace_option (corner_case ~loc:__LOC__ "name not in environment") @@ trace_option (corner_case ~loc:__LOC__ "name not in environment") @@
AST.Environment.get_opt name ae.environment in AST.Environment.get_opt name ae.environment in
let%bind tv = transpile_environment_element_type ele 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) -> | E_application (a, b) ->
let%bind a = transpile_annotated_expression a in 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 match (a, b) with
| (None, a), (None, b) -> ok (None, T_or ((None, a), (None, b))) | (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 _, _), (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))) | (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 ("RIGHT", [Combinators.Expression.make_tpl (v, b)])), 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 in
let%bind (ae_opt, tv) = Append_tree.fold_ne leaf node node_tv in let%bind (ae_opt, tv) = Append_tree.fold_ne leaf node node_tv in
let%bind ae = 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 a_ty = Combinators.Expression.get_type a in
let b_ty = Combinators.Expression.get_type b in let b_ty = Combinators.Expression.get_type b in
let tv = T_pair ((None, a_ty) , (None, b_ty)) 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 in
Append_tree.fold_ne (transpile_annotated_expression) aux node 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 tuple_access_to_lr ty' ty'_lst ind in
let aux = fun pred (ty, lr) -> let aux = fun pred (ty, lr) ->
let c = match lr with let c = match lr with
| `Left -> "CAR" | `Left -> C_CAR
| `Right -> "CDR" in | `Right -> C_CDR in
Combinators.Expression.make_tpl (E_constant (c, [pred]) , ty) in Combinators.Expression.make_tpl (E_constant (c, [pred]) , ty) in
let%bind tpl' = transpile_annotated_expression tpl in let%bind tpl' = transpile_annotated_expression tpl in
let expr = List.fold_left aux tpl' path in let expr = List.fold_left aux tpl' path in
ok expr ok expr
) )
| E_record m -> ( | 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 aux a b : expression result =
let%bind a = a in let%bind a = a in
let%bind b = b in let%bind b = b in
let a_ty = Combinators.Expression.get_type a in let a_ty = Combinators.Expression.get_type a in
let b_ty = Combinators.Expression.get_type b in let b_ty = Combinators.Expression.get_type b in
let tv = T_pair ((None, a_ty) , (None, b_ty)) 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 in
trace_strong (corner_case ~loc:__LOC__ "record build") @@ trace_strong (corner_case ~loc:__LOC__ "record build") @@
Append_tree.fold_ne (transpile_annotated_expression) aux node 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' = transpile_type (get_type_annotation record) in
let%bind ty_smap = let%bind ty_lmap =
trace_strong (corner_case ~loc:__LOC__ "not a record") @@ trace_strong (corner_case ~loc:__LOC__ "not a record") @@
get_t_record (get_type_annotation record) in 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 = let%bind path =
trace_strong (corner_case ~loc:__LOC__ "record access") @@ 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 aux = fun pred (ty, lr) ->
let c = match lr with let c = match lr with
| `Left -> "CAR" | `Left -> C_CAR
| `Right -> "CDR" in | `Right -> C_CDR in
Combinators.Expression.make_tpl (E_constant (c, [pred]) , ty) in Combinators.Expression.make_tpl (E_constant (c, [pred]) , ty) in
let%bind record' = transpile_annotated_expression record in let%bind record' = transpile_annotated_expression record in
let expr = List.fold_left aux record' path 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 body' = transpile_annotated_expression l.body in
let%bind (input , _) = AST.get_t_function f.type_annotation in let%bind (input , _) = AST.get_t_function f.type_annotation in
let%bind input' = transpile_type input in let%bind input' = transpile_type input in
ok ((Var.of_name l.binder , input') , body') ok ((l.binder , input') , body')
in in
let expression_to_iterator_body (f : AST.annotated_expression) = let expression_to_iterator_body (f : AST.annotated_expression) =
match f.expression with match f.expression with
@ -399,29 +391,29 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
| _ -> fail @@ unsupported_iterator f.location | _ -> fail @@ unsupported_iterator f.location
in in
fun (lst : AST.annotated_expression list) -> match (lst , iterator_name) with 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 f' = expression_to_iterator_body f in
let%bind i' = transpile_annotated_expression i in let%bind i' = transpile_annotated_expression i in
return @@ E_iterator (iterator_name , f' , i') 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 f' = expression_to_iterator_body f in
let%bind initial' = transpile_annotated_expression initial in let%bind initial' = transpile_annotated_expression initial in
let%bind collection' = transpile_annotated_expression collection in let%bind collection' = transpile_annotated_expression collection in
return @@ E_fold (f' , collection' , initial') 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 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 match (name , lst) with
| ("SET_ITER" , lst) -> iter lst | (C_SET_ITER , lst) -> iter lst
| ("LIST_ITER" , lst) -> iter lst | (C_LIST_ITER , lst) -> iter lst
| ("MAP_ITER" , lst) -> iter lst | (C_MAP_ITER , lst) -> iter lst
| ("LIST_MAP" , lst) -> map lst | (C_LIST_MAP , lst) -> map lst
| ("MAP_MAP" , lst) -> map lst | (C_MAP_MAP , lst) -> map lst
| ("LIST_FOLD" , lst) -> fold lst | (C_LIST_FOLD , lst) -> fold lst
| ("SET_FOLD" , lst) -> fold lst | (C_SET_FOLD , lst) -> fold lst
| ("MAP_FOLD" , lst) -> fold lst | (C_MAP_FOLD , lst) -> fold lst
| _ -> ( | _ -> (
let%bind lst' = bind_map_list (transpile_annotated_expression) lst in let%bind lst' = bind_map_list (transpile_annotated_expression) lst in
return @@ E_constant (name , lst') return @@ E_constant (name , lst')
@ -436,7 +428,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
get_t_list tv in get_t_list tv in
let%bind lst' = bind_map_list (transpile_annotated_expression) lst in let%bind lst' = bind_map_list (transpile_annotated_expression) lst in
let aux : expression -> expression -> expression result = fun prev cur -> 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 let%bind (init : expression) = return @@ E_make_empty_list t in
bind_fold_right_list aux init lst' 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 get_t_set tv in
let%bind lst' = bind_map_list (transpile_annotated_expression) lst in let%bind lst' = bind_map_list (transpile_annotated_expression) lst in
let aux : expression -> expression -> expression result = fun prev cur -> 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 let%bind (init : expression) = return @@ E_make_empty_set t in
bind_fold_list aux init lst' 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%bind (k', v') =
let v' = e_a_some v ae.environment in let v' = e_a_some v ae.environment in
bind_map_pair (transpile_annotated_expression) (k , v') 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 in
let init = return @@ E_make_empty_map (src, dst) in let init = return @@ E_make_empty_map (src, dst) in
List.fold_left aux init m 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%bind (k', v') =
let v' = e_a_some v ae.environment in let v' = e_a_some v ae.environment in
bind_map_pair (transpile_annotated_expression) (k , v') 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 in
let init = return @@ E_make_empty_big_map (src, dst) in let init = return @@ E_make_empty_big_map (src, dst) in
List.fold_left aux init m List.fold_left aux init m
) )
| E_look_up dsi -> ( | E_look_up dsi -> (
let%bind (ds', i') = bind_map_pair f dsi in 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) -> ( | E_sequence (a , b) -> (
let%bind a' = transpile_annotated_expression a in 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 = let%bind ty_map =
trace_strong (corner_case ~loc:__LOC__ "not a record") @@ trace_strong (corner_case ~loc:__LOC__ "not a record") @@
AST.Combinators.get_t_record prev in 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%bind path = record_access_to_lr ty' ty'_map prop in
let path' = List.map snd path in let path' = List.map snd path in
let%bind prop_in_ty_map = trace_option let%bind prop_in_ty_map = trace_option
(Errors.not_found "acessing prop in ty_map [TODO: better error message]") (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') ok (prop_in_ty_map, acc @ path')
) )
in in
let%bind (_, path) = bind_fold_list aux (ty, []) path in let%bind (_, path) = bind_fold_list aux (ty, []) path in
let%bind expr' = transpile_annotated_expression expr 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) -> ( | E_matching (expr, m) -> (
let%bind expr' = transpile_annotated_expression expr in 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} -> | Match_bool {match_true ; match_false} ->
let%bind (t , f) = bind_map_pair (transpile_annotated_expression) (match_true, match_false) in let%bind (t , f) = bind_map_pair (transpile_annotated_expression) (match_true, match_false) in
return @@ E_if_bool (expr', t, f) 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 n = transpile_annotated_expression match_none in
let%bind (tv' , s') = let%bind (tv' , s') =
let%bind tv' = transpile_type tv in let%bind tv' = transpile_type tv in
let%bind s' = transpile_annotated_expression s in let%bind s' = transpile_annotated_expression s in
ok (tv' , s') ok (tv' , s')
in 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_list {
match_nil ; 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 nil = transpile_annotated_expression match_nil in
let%bind cons = let%bind cons =
let%bind hd_ty' = transpile_type hd_ty in let%bind ty' = transpile_type ty in
let%bind tl_ty' = transpile_type tl_ty in
let%bind match_cons' = transpile_annotated_expression match_cons 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 in
return @@ E_if_cons (expr' , nil , cons) 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") @@ trace_option (corner_case ~loc:__LOC__ "missing match clause") @@
List.find_opt (fun ((constructor_name' , _) , _) -> constructor_name' = constructor_name) lst in List.find_opt (fun ((constructor_name' , _) , _) -> constructor_name' = constructor_name) lst in
let%bind body' = transpile_annotated_expression body 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) -> | ((`Node (a , b)) , tv) ->
let%bind a' = let%bind a' =
let%bind a_ty = get_t_left tv in let%bind a_ty = get_t_left tv in
let a_var = Var.of_name "left" , a_ty in let left_var = Var.fresh ~name:"left" () in
let%bind e = aux (((Expression.make (E_variable (Var.of_name "left")) a_ty))) a in let%bind e = aux (((Expression.make (E_variable left_var) a_ty))) a in
ok (a_var , e) ok ((left_var , a_ty) , e)
in in
let%bind b' = let%bind b' =
let%bind b_ty = get_t_right tv in let%bind b_ty = get_t_right tv in
let b_var = Var.of_name "right" , b_ty in let right_var = Var.fresh ~name:"right" () in
let%bind e = aux (((Expression.make (E_variable (Var.of_name "right")) b_ty))) b in let%bind e = aux (((Expression.make (E_variable right_var) b_ty))) b in
ok (b_var , e) ok ((right_var , b_ty) , e)
in in
return @@ E_if_left (top , a' , b') return @@ E_if_left (top , a' , b')
in in
@ -608,7 +599,7 @@ and transpile_lambda l (input_type , output_type) =
let%bind input = transpile_type input_type in let%bind input = transpile_type input_type in
let%bind output = transpile_type output_type in let%bind output = transpile_type output_type in
let tv = Combinators.t_function input output 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) ok @@ Combinators.Expression.make_tpl (closure , tv)
let transpile_declaration env (d:AST.declaration) : toplevel_statement result = 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} , _) -> | Declaration_constant ({name;annotated_expression} , _) ->
let%bind expression = transpile_annotated_expression annotated_expression in let%bind expression = transpile_annotated_expression annotated_expression in
let tv = Combinators.Expression.get_type expression in let tv = Combinators.Expression.get_type expression in
let env' = Environment.add (Var.of_name name, tv) env in let env' = Environment.add (name, tv) env in
ok @@ ((Var.of_name name, expression), environment_wrap env env') ok @@ ((name, expression), environment_wrap env env')
let transpile_program (lst : AST.program) : program result = let transpile_program (lst : AST.program) : program result =
let aux (prev:(toplevel_statement list * Environment.t) result) cur = let aux (prev:(toplevel_statement list * Environment.t) result) cur =

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

@ -53,61 +53,92 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
let open! AST in let open! AST in
let return e = ok (make_a_e_empty e t) in let return e = ok (make_a_e_empty e t) in
match t.type_value' with match t.type_value' with
| T_constant (Type_name "unit", []) -> ( | T_constant type_constant -> (
match type_constant with
| TC_unit -> (
let%bind () = let%bind () =
trace_strong (wrong_mini_c_value "unit" v) @@ trace_strong (wrong_mini_c_value "unit" v) @@
get_unit v in get_unit v in
return (E_literal Literal_unit) return (E_literal Literal_unit)
) )
| T_constant (Type_name "bool", []) -> ( | TC_bool -> (
let%bind b = let%bind b =
trace_strong (wrong_mini_c_value "bool" v) @@ trace_strong (wrong_mini_c_value "bool" v) @@
get_bool v in get_bool v in
return (E_literal (Literal_bool b)) return (E_literal (Literal_bool b))
) )
| T_constant (Type_name "int", []) -> ( | TC_int -> (
let%bind n = let%bind n =
trace_strong (wrong_mini_c_value "int" v) @@ trace_strong (wrong_mini_c_value "int" v) @@
get_int v in get_int v in
return (E_literal (Literal_int n)) return (E_literal (Literal_int n))
) )
| T_constant (Type_name "nat", []) -> ( | TC_nat -> (
let%bind n = let%bind n =
trace_strong (wrong_mini_c_value "nat" v) @@ trace_strong (wrong_mini_c_value "nat" v) @@
get_nat v in get_nat v in
return (E_literal (Literal_nat n)) return (E_literal (Literal_nat n))
) )
| T_constant (Type_name "timestamp", []) -> ( | TC_timestamp -> (
let%bind n = let%bind n =
trace_strong (wrong_mini_c_value "timestamp" v) @@ trace_strong (wrong_mini_c_value "timestamp" v) @@
get_timestamp v in get_timestamp v in
return (E_literal (Literal_timestamp n)) return (E_literal (Literal_timestamp n))
) )
| T_constant (Type_name "tez", []) -> ( | TC_mutez -> (
let%bind n = let%bind n =
trace_strong (wrong_mini_c_value "tez" v) @@ trace_strong (wrong_mini_c_value "tez" v) @@
get_mutez v in get_mutez v in
return (E_literal (Literal_mutez n)) return (E_literal (Literal_mutez n))
) )
| T_constant (Type_name "string", []) -> ( | TC_string -> (
let%bind n = let%bind n =
trace_strong (wrong_mini_c_value "string" v) @@ trace_strong (wrong_mini_c_value "string" v) @@
get_string v in get_string v in
return (E_literal (Literal_string n)) return (E_literal (Literal_string n))
) )
| T_constant (Type_name "bytes", []) -> ( | TC_bytes -> (
let%bind n = let%bind n =
trace_strong (wrong_mini_c_value "bytes" v) @@ trace_strong (wrong_mini_c_value "bytes" v) @@
get_bytes v in get_bytes v in
return (E_literal (Literal_bytes n)) return (E_literal (Literal_bytes n))
) )
| T_constant (Type_name "address", []) -> ( | TC_address -> (
let%bind n = let%bind n =
trace_strong (wrong_mini_c_value "address" v) @@ trace_strong (wrong_mini_c_value "address" v) @@
get_string v in get_string v in
return (E_literal (Literal_address n)) return (E_literal (Literal_address n))
) )
| T_constant (Type_name "option", [o]) -> ( | 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_operator type_operator -> (
match type_operator with
| TC_option o -> (
let%bind opt = let%bind opt =
trace_strong (wrong_mini_c_value "option" v) @@ trace_strong (wrong_mini_c_value "option" v) @@
get_option v in get_option v in
@ -117,7 +148,7 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
let%bind s' = untranspile s o in let%bind s' = untranspile s o in
ok (e_a_empty_some s') ok (e_a_empty_some s')
) )
| T_constant (Type_name "map", [k_ty;v_ty]) -> ( | TC_map (k_ty,v_ty)-> (
let%bind lst = let%bind lst =
trace_strong (wrong_mini_c_value "map" v) @@ trace_strong (wrong_mini_c_value "map" v) @@
get_map v in get_map v in
@ -129,7 +160,7 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
bind_map_list aux lst in bind_map_list aux lst in
return (E_map lst') return (E_map lst')
) )
| T_constant (Type_name "big_map", [k_ty;v_ty]) -> ( | TC_big_map (k_ty, v_ty) -> (
let%bind lst = let%bind lst =
trace_strong (wrong_mini_c_value "big_map" v) @@ trace_strong (wrong_mini_c_value "big_map" v) @@
get_big_map v in get_big_map v in
@ -141,7 +172,7 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
bind_map_list aux lst in bind_map_list aux lst in
return (E_big_map lst') return (E_big_map lst')
) )
| T_constant (Type_name "list", [ty]) -> ( | TC_list ty -> (
let%bind lst = let%bind lst =
trace_strong (wrong_mini_c_value "list" v) @@ trace_strong (wrong_mini_c_value "list" v) @@
get_list v in get_list v in
@ -150,25 +181,7 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
bind_map_list aux lst in bind_map_list aux lst in
return (E_list lst') return (E_list lst')
) )
| T_constant (Type_name "key", []) -> ( | TC_set ty -> (
let%bind n =
trace_strong (wrong_mini_c_value "key" v) @@
get_string v in
return (E_literal (Literal_key n))
)
| 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_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 = let%bind lst =
trace_strong (wrong_mini_c_value "set" v) @@ trace_strong (wrong_mini_c_value "set" v) @@
get_set v in get_set v in
@ -177,18 +190,11 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
bind_map_list aux lst in bind_map_list aux lst in
return (E_set lst') return (E_set lst')
) )
| T_constant (Type_name "contract" , [_ty]) -> | TC_contract _ ->
fail @@ bad_untranspile "contract" v 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 -> | 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 let%bind node = match Append_tree.of_list lst with
| Empty -> fail @@ corner_case ~loc:__LOC__ "empty sum type" | Empty -> fail @@ corner_case ~loc:__LOC__ "empty sum type"
| Full t -> ok t | 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") @@ trace_strong (corner_case ~loc:__LOC__ "sum extract constructor") @@
extract_constructor v node in extract_constructor v node in
let%bind sub = untranspile v tv in let%bind sub = untranspile v tv in
return (E_constructor (name, sub)) return (E_constructor (Constructor name, sub))
| T_tuple lst -> | T_tuple lst ->
let%bind node = match Append_tree.of_list lst with let%bind node = match Append_tree.of_list lst with
| Empty -> fail @@ corner_case ~loc:__LOC__ "empty tuple" | 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 @@ List.map (fun (x, y) -> untranspile x y) tpl in
return (E_tuple tpl') return (E_tuple tpl')
| T_record m -> | 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 let%bind node = match Append_tree.of_list lst with
| Empty -> fail @@ corner_case ~loc:__LOC__ "empty record" | Empty -> fail @@ corner_case ~loc:__LOC__ "empty record"
| Full t -> ok t in | 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 extract_record v node in
let%bind lst = bind_list let%bind lst = bind_list
@@ List.map (fun (x, (y, z)) -> let%bind yz = untranspile y z in ok (x, yz)) lst in @@ 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') return (E_record m')
| T_function _ -> | T_arrow _ ->
let%bind n = let%bind n =
trace_strong (wrong_mini_c_value "lambda as string" v) @@ trace_strong (wrong_mini_c_value "lambda as string" v) @@
get_string v in get_string v in
return (E_literal (Literal_string n)) 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 (* true if the name names a pure constant -- i.e. if uses will be pure
assuming arguments are pure *) assuming arguments are pure *)
let is_pure_constant : string -> bool = let is_pure_constant : constant -> bool =
function function
| "UNIT" | C_UNIT
| "CAR" | "CDR" | "PAIR" | C_CAR | C_CDR | C_PAIR
| "NIL" | "CONS" | C_NIL | C_CONS
| "NEG" | "OR" | "AND" | "XOR" | "NOT" | C_NEG | C_OR | C_AND | C_XOR | C_NOT
| "EQ" | "NEQ" | "LT" | "LE" | "GT" | "GE" | C_EQ | C_NEQ | C_LT | C_LE | C_GT | C_GE
| "SOME" | C_SOME
| "UPDATE" | "MAP_GET" | "MAP_FIND_OPT" | "MAP_ADD" | "MAP_UPDATE" | C_UPDATE | C_MAP_GET | C_MAP_FIND_OPT | C_MAP_ADD | C_MAP_UPDATE
| "INT" | "ABS" | "ISNAT" | C_INT | C_ABS | C_IS_NAT
| "BALANCE" | "AMOUNT" | "ADDRESS" | "NOW" | "SOURCE" | "SENDER" | "CHAIN_ID" | C_BALANCE | C_AMOUNT | C_ADDRESS | C_NOW | C_SOURCE | C_SENDER | C_CHAIN_ID
| "SET_MEM" | "SET_ADD" | "SET_REMOVE" | "SLICE" | C_SET_MEM | C_SET_ADD | C_SET_REMOVE | C_SLICE
| "SHA256" | "SHA512" | "BLAKE2B" | "CHECK_SIGNATURE" | C_SHA256 | C_SHA512 | C_BLAKE2b | C_CHECK_SIGNATURE
| "HASH_KEY" | "PACK" | "CONCAT" | C_HASH_KEY | C_BYTES_PACK | C_CONCAT
-> true -> true
(* unfortunately impure: *) (* unfortunately impure: *)
| "ADD"|"SUB"|"TIMES"|"DIV"|"MOD" | C_ADD | C_SUB |C_MUL|C_DIV|C_MOD
(* impure: *) (* impure: *)
| "ASSERT" | "ASSERT_INFERRED" | C_ASSERTION | C_ASSERT_INFERRED
| "MAP_GET_FORCE" | "MAP_FIND" | C_MAP_GET_FORCE | C_MAP_FIND
| "FOLD_WHILE" | C_FOLD_WHILE
| "CALL" | C_CALL
(* TODO... *) (* TODO... *)
| _ | _
-> false -> false
@ -80,12 +80,12 @@ let rec is_pure : expression -> bool = fun e ->
(* definitely not pure *) (* definitely not pure *)
| E_assignment _ -> false | E_assignment _ -> false
let occurs_in : Var.t -> expression -> bool = let occurs_in : expression_variable -> expression -> bool =
fun x e -> fun x e ->
let fvs = Free_variables.expression [] e in let fvs = Free_variables.expression [] e in
Free_variables.mem x fvs Free_variables.mem x fvs
let occurs_count : Var.t -> expression -> int = let occurs_count : expression_variable -> expression -> int =
fun x e -> fun x e ->
let fvs = Free_variables.expression [] e in let fvs = Free_variables.expression [] e in
Free_variables.mem_count x fvs 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 (* If `ignore_lambdas` is true, ignore assignments which occur inside
lambdas, which have no effect on the value of the variable outside lambdas, which have no effect on the value of the variable outside
of the lambda. *) 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 -> fun ~ignore_lambdas x e ->
let self = is_assigned ~ignore_lambdas x in let self = is_assigned ~ignore_lambdas x in
let selfs = List.exists self 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 -> fun x e1 e2 ->
is_pure e1 && is_pure e1 &&
(* if x does not occur in e2, there can be no other problems: (* 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)) (fun y -> not (is_assigned ~ignore_lambdas:true y e2))
(Free_variables.expression [] e2))) (Free_variables.expression [] e2)))
let should_inline : Var.t -> expression -> bool = let should_inline : expression_variable -> expression -> bool =
fun x e -> fun x e ->
occurs_count x e <= 1 occurs_count x e <= 1
@ -232,12 +232,12 @@ let beta : bool ref -> expression -> expression =
else e else e
(* also do CAR (PAIR x y) ↦ x, or CDR (PAIR x y) ↦ y, only if x and y are pure *) (* 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 if is_pure e1 && is_pure e2
then (changed := true ; then (changed := true ;
match const with match const with
| "CAR" -> e1 | C_CAR -> e1
| "CDR" -> e2 | C_CDR -> e2
| _ -> assert false) | _ -> assert false)
else e else e
| _ -> e | _ -> e

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

@ -317,7 +317,7 @@ let%expect_test _ =
(* iter shadowed *) (* iter shadowed *)
Var.reset_counter () ; Var.reset_counter () ;
show_subst 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 ~x:x
~expr:unit ; ~expr:unit ;
[%expect{| [%expect{|
@ -328,7 +328,7 @@ let%expect_test _ =
(* iter not shadowed *) (* iter not shadowed *)
Var.reset_counter () ; Var.reset_counter () ;
show_subst 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 ~x:x
~expr:unit ; ~expr:unit ;
[%expect{| [%expect{|
@ -339,7 +339,7 @@ let%expect_test _ =
(* iter capture-avoiding *) (* iter capture-avoiding *)
Var.reset_counter () ; Var.reset_counter () ;
show_subst 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 ~x:x
~expr:(var y) ; ~expr:(var y) ;
[%expect{| [%expect{|

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

@ -5,12 +5,13 @@ open Michelson
let empty : environment = [] 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%bind (_ , position) =
let error = let error =
let title () = "Environment.get" in let title () = "Environment.get" in
let content () = Format.asprintf "%a in %a" 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 error title content in
generic_try error @@ generic_try error @@
(fun () -> Environment.get_i s e) in (fun () -> Environment.get_i s e) in
@ -34,10 +35,10 @@ let get : environment -> Var.t -> michelson result = fun e s ->
ok code 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) = let%bind (_ , position) =
generic_try (simple_error "Environment.set") @@ 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 -> let rec aux_bubble = fun n ->
match n with match n with
| 0 -> dip i_drop | 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 module Stack = Meta_michelson.Stack
*) *)
val empty: environment val empty: environment
val get : environment -> Var.t -> michelson result val get : environment -> expression_variable -> michelson result
val set : environment -> Var.t -> michelson result val set : environment -> expression_variable -> michelson result
val pack_closure : environment -> selector -> michelson result val pack_closure : environment -> selector -> michelson result
val unpack_closure : environment -> 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 end
open Errors open Errors
let get_operator : string -> type_value -> expression list -> predicate result = fun s ty lst -> (* This does not makes sense to me *)
match Map.String.find_opt s Operators.Compiler.operators with let get_operator : constant -> type_value -> expression list -> predicate result = fun s ty lst ->
| Some x -> ok x match Operators.Compiler.get_operators s with
| None -> ( | Trace.Ok (x,_) -> ok x
| Trace.Error _ -> (
match s with match s with
| "NONE" -> ( | C_NONE -> (
let%bind ty' = Mini_c.get_t_option ty in let%bind ty' = Mini_c.get_t_option ty in
let%bind m_ty = Compiler_type.type_ ty' in let%bind m_ty = Compiler_type.type_ ty' in
ok @@ simple_constant @@ prim ~children:[m_ty] I_NONE ok @@ simple_constant @@ prim ~children:[m_ty] I_NONE
) )
| "NIL" -> ( | C_NIL -> (
let%bind ty' = Mini_c.get_t_list ty in let%bind ty' = Mini_c.get_t_list ty in
let%bind m_ty = Compiler_type.type_ ty' in let%bind m_ty = Compiler_type.type_ ty' in
ok @@ simple_unary @@ prim ~children:[m_ty] I_NIL 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 ty' = Mini_c.get_t_set ty in
let%bind m_ty = Compiler_type.type_ ty' in let%bind m_ty = Compiler_type.type_ ty' in
ok @@ simple_constant @@ prim ~children:[m_ty] I_EMPTY_SET 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 ty' = Mini_c.get_t_option ty in
let%bind m_ty = Compiler_type.type_ ty' in let%bind m_ty = Compiler_type.type_ ty' in
ok @@ simple_unary @@ prim ~children:[m_ty] I_UNPACK ok @@ simple_unary @@ prim ~children:[m_ty] I_UNPACK
) )
| "MAP_REMOVE" -> | C_MAP_REMOVE ->
let%bind v = match lst with let%bind v = match lst with
| [ _ ; expr ] -> | [ _ ; expr ] ->
let%bind (_, v) = Mini_c.Combinators.(bind_map_or (get_t_map , get_t_big_map) (Expression.get_type expr)) in 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 | _ -> simple_fail "mini_c . MAP_REMOVE" in
let%bind v_ty = Compiler_type.type_ v in let%bind v_ty = Compiler_type.type_ v in
ok @@ simple_binary @@ seq [dip (i_none v_ty) ; prim I_UPDATE ] ok @@ simple_binary @@ seq [dip (i_none v_ty) ; prim I_UPDATE ]
| "LEFT" -> | C_LEFT ->
let%bind r = match lst with let%bind r = match lst with
| [ _ ] -> get_t_right ty | [ _ ] -> get_t_right ty
| _ -> simple_fail "mini_c . LEFT" in | _ -> simple_fail "mini_c . LEFT" in
let%bind r_ty = Compiler_type.type_ r in let%bind r_ty = Compiler_type.type_ r in
ok @@ simple_unary @@ prim ~children:[r_ty] I_LEFT ok @@ simple_unary @@ prim ~children:[r_ty] I_LEFT
| "RIGHT" -> | C_RIGHT ->
let%bind l = match lst with let%bind l = match lst with
| [ _ ] -> get_t_left ty | [ _ ] -> get_t_left ty
| _ -> simple_fail "mini_c . RIGHT" in | _ -> simple_fail "mini_c . RIGHT" in
let%bind l_ty = Compiler_type.type_ l in let%bind l_ty = Compiler_type.type_ l in
ok @@ simple_unary @@ prim ~children:[l_ty] I_RIGHT ok @@ simple_unary @@ prim ~children:[l_ty] I_RIGHT
| "CONTRACT" -> | C_CONTRACT ->
let%bind r = get_t_contract ty in let%bind r = get_t_contract ty in
let%bind r_ty = Compiler_type.type_ r in let%bind r_ty = Compiler_type.type_ r in
ok @@ simple_unary @@ seq [ ok @@ simple_unary @@ seq [
prim ~children:[r_ty] I_CONTRACT ; prim ~children:[r_ty] I_CONTRACT ;
i_assert_some_msg (i_push_string "bad address for get_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 = get_t_contract ty in
let%bind r_ty = Compiler_type.type_ r in let%bind r_ty = Compiler_type.type_ r in
let%bind entry = match lst with 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 ; prim ~annot:[entry] ~children:[r_ty] I_CONTRACT ;
i_assert_some_msg (i_push_string @@ Format.sprintf "bad address for get_entrypoint (%s)" entry) ; 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 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 = and translate_expression (expr:expression) (env:environment) : michelson result =
let (expr' , ty) = Combinators.Expression.(get_content expr , get_type expr) in let (expr' , ty) = Combinators.Expression.(get_content expr , get_type expr) in
let error_message () = 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 in
let return code = ok code in let return code = ok code in
@ -227,7 +229,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result
pre_code ; pre_code ;
f ; f ;
] ]
| _ -> simple_fail ("bad arity for " ^ str) | _ -> simple_fail (Format.asprintf "bad arity for %a" Stage_common.PP.constant str)
in in
let error = let error =
let title () = "error compiling constant" in 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 expr' = translate_expression expr env in
let%bind body' = translate_expression body (Environment.add v env) in let%bind body' = translate_expression body (Environment.add v env) in
match name with match name with
| "ITER" -> ( | C_ITER -> (
let%bind code = ok (seq [ let%bind code = ok (seq [
expr' ; expr' ;
i_iter (seq [body' ; i_drop ; i_drop]) ; i_iter (seq [body' ; i_drop ; i_drop]) ;
@ -337,7 +339,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result
]) in ]) in
return code return code
) )
| "MAP" -> ( | C_MAP -> (
let%bind code = ok (seq [ let%bind code = ok (seq [
expr' ; expr' ;
i_map (seq [body' ; dip i_drop]) ; i_map (seq [body' ; dip i_drop]) ;
@ -345,7 +347,8 @@ and translate_expression (expr:expression) (env:environment) : michelson result
return code return code
) )
| s -> ( | 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 fail error
) )
) )
@ -454,7 +457,7 @@ type compiled_program = {
} }
let get_main : program -> string -> (anon_function * _) result = fun p entry -> 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 match Combinators.Expression.(get_content expr , get_type expr)with
| (E_closure content , T_function ty) | (E_closure content , T_function ty)
when Var.equal name (Var.of_name entry) -> 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 ; 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_expression : expression -> environment -> michelson result
val translate_function_body : anon_function -> environment_element list -> type_value -> 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_value : value -> type_value -> michelson result
val translate_program : program -> string -> compiled_program result val translate_program : program -> string -> compiled_program result
val translate_contract : anon_function -> (type_value * type_value ) -> michelson result val translate_contract : anon_function -> (type_value * type_value ) -> michelson result
val translate_entry : anon_function -> type_value * type_value -> compiled_program 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_void -> fail (not_comparable "void")
| Base_bool -> fail (not_comparable "bool") | Base_bool -> fail (not_comparable "bool")
| Base_nat -> return nat_k | Base_nat -> return nat_k
| Base_tez -> return tez_k | Base_mutez -> return tez_k
| Base_int -> return int_k | Base_int -> return int_k
| Base_string -> return string_k | Base_string -> return string_k
| Base_address -> return address_k | Base_address -> return address_k
@ -96,7 +96,7 @@ module Ty = struct
| Base_bool -> return bool | Base_bool -> return bool
| Base_int -> return int | Base_int -> return int
| Base_nat -> return nat | Base_nat -> return nat
| Base_tez -> return tez | Base_mutez -> return tez
| Base_string -> return string | Base_string -> return string
| Base_address -> return address | Base_address -> return address
| Base_timestamp -> return timestamp | Base_timestamp -> return timestamp
@ -181,7 +181,7 @@ let base_type : type_base -> O.michelson result =
| Base_bool -> ok @@ O.prim T_bool | Base_bool -> ok @@ O.prim T_bool
| Base_int -> ok @@ O.prim T_int | Base_int -> ok @@ O.prim T_int
| Base_nat -> ok @@ O.prim T_nat | 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_string -> ok @@ O.prim T_string
| Base_address -> ok @@ O.prim T_address | Base_address -> ok @@ O.prim T_address
| Base_timestamp -> ok @@ O.prim T_timestamp | Base_timestamp -> ok @@ O.prim T_timestamp

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

@ -21,90 +21,80 @@ module Typer = struct
end end
open Errors open Errors
type type_result = string * type_value type type_result = type_value
type typer' = type_value list -> type_value option -> type_result result type typer = type_value list -> type_value option -> type_result result
type typer = string * typer'
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 match lst with
| [] -> ( | [] -> (
let%bind tv' = f tv_opt in let%bind tv' = f tv_opt in
ok (s , tv') ok (tv')
) )
| _ -> fail @@ wrong_param_number s 0 lst | _ -> 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 match lst with
| [ a ] -> ( | [ a ] -> (
let%bind tv' = f a in let%bind tv' = f a in
ok (s , tv') ok (tv')
) )
| _ -> fail @@ wrong_param_number s 1 lst | _ -> 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 match lst with
| [ a ] -> ( | [ a ] -> (
let%bind tv' = f a tv_opt in let%bind tv' = f a tv_opt in
ok (s , tv') ok (tv')
) )
| _ -> fail @@ wrong_param_number s 1 lst | _ -> 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 match lst with
| [ a ; b ] -> ( | [ a ; b ] -> (
let%bind tv' = f a b in let%bind tv' = f a b in
ok (s , tv') ok (tv')
) )
| _ -> fail @@ wrong_param_number s 2 lst | _ -> 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 match lst with
| [ a ; b ] -> ( | [ a ; b ] -> (
let%bind tv' = f a b tv_opt in let%bind tv' = f a b tv_opt in
ok (s , tv') ok (tv')
) )
| _ -> fail @@ wrong_param_number s 2 lst | _ -> 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 match lst with
| [ a ; b ; c ] -> ( | [ a ; b ; c ] -> (
let%bind tv' = f a b c in let%bind tv' = f a b c in
ok (s , tv') ok (tv')
) )
| _ -> fail @@ wrong_param_number s 3 lst | _ -> 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 match lst with
| [ a ; b ; c ; d ] -> ( | [ a ; b ; c ; d ] -> (
let%bind tv' = f a b c d in let%bind tv' = f a b c d in
ok (s , tv') ok (tv')
) )
| _ -> fail @@ wrong_param_number s 4 lst | _ -> 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 match lst with
| [ a ; b ; c ; d ; e ] -> ( | [ a ; b ; c ; d ; e ] -> (
let%bind tv' = f a b c d e in let%bind tv' = f a b c d e in
ok (s , tv') ok (tv')
) )
| _ -> fail @@ wrong_param_number s 5 lst | _ -> 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 match lst with
| [ a ; b ; c ; d ; e ; f_ ] -> ( | [ a ; b ; c ; d ; e ; f_ ] -> (
let%bind tv' = f a b c d e f_ in let%bind tv' = f a b c d e f_ in
ok (s , tv') ok (tv')
) )
| _ -> fail @@ wrong_param_number s 6 lst | _ -> 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) 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 open Ast_typed
module Errors : sig 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 val error_uncomparable_types : type_value -> type_value -> unit -> error
end end
type type_result = string * type_value type type_result = type_value
type typer' = type_value list -> type_value option -> type_result result type typer = type_value list -> type_value option -> type_result result
type typer = string * typer'
(* (*
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 : 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 : 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 : 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 : name -> (type_value -> type_value -> type_value result) -> typer val typer_2 : string -> (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_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 : 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 : 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 : 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 : 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_1 : type_value -> type_value -> bool
val eq_2 : ( type_value * 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 assert_eq_1 : ?msg:string -> type_value -> type_value -> unit result
val comparator : name -> typer val comparator : string -> typer
val boolean_operator_2 : name -> typer val boolean_operator_2 : string -> typer
end end

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

@ -11,6 +11,7 @@ open Trace
module Simplify = struct module Simplify = struct
open Ast_simplified
(* (*
Each front-end has its owns constants. 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 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. - 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 module Pascaligo = struct
let constants = [ let constants = function
("get_force" , "MAP_GET_FORCE") ; | "get_force" -> ok C_MAP_GET_FORCE
("get_chain_id", "CHAIN_ID"); | "get_chain_id" -> ok C_CHAIN_ID
("transaction" , "CALL") ; | "transaction" -> ok C_CALL
("get_contract" , "CONTRACT") ; | "get_contract" -> ok C_CONTRACT
("get_entrypoint" , "CONTRACT_ENTRYPOINT") ; | "get_entrypoint" -> ok C_CONTRACT_ENTRYPOINT
("size" , "SIZE") ; | "size" -> ok C_SIZE
("int" , "INT") ; | "int" -> ok C_INT
("abs" , "ABS") ; | "abs" -> ok C_ABS
("is_nat", "ISNAT") ; | "is_nat" -> ok C_IS_NAT
("amount" , "AMOUNT") ; | "amount" -> ok C_AMOUNT
("balance", "BALANCE") ; | "balance" -> ok C_BALANCE
("now" , "NOW") ; | "now" -> ok C_NOW
("unit" , "UNIT") ; | "unit" -> ok C_UNIT
("source" , "SOURCE") ; | "source" -> ok C_SOURCE
("sender" , "SENDER") ; | "sender" -> ok C_SENDER
("address", "ADDRESS") ; | "failwith" -> ok C_FAILWITH
("self_address", "SELF_ADDRESS") ; | "bitwise_or" -> ok C_OR
("implicit_account", "IMPLICIT_ACCOUNT") ; | "bitwise_and" -> ok C_AND
("failwith" , "FAILWITH") ; | "bitwise_xor" -> ok C_XOR
("bitwise_or" , "OR") ; | "string_concat" -> ok C_CONCAT
("bitwise_and" , "AND") ; | "string_slice" -> ok C_SLICE
("bitwise_xor" , "XOR") ; | "crypto_check" -> ok C_CHECK_SIGNATURE
("string_concat" , "CONCAT") ; | "crypto_hash_key" -> ok C_HASH_KEY
("string_slice" , "SLICE") ; | "bytes_concat" -> ok C_CONCAT
("crypto_check", "CHECK_SIGNATURE") ; | "bytes_slice" -> ok C_SLICE
("crypto_hash_key", "HASH_KEY") ; | "bytes_pack" -> ok C_BYTES_PACK
("bytes_concat" , "CONCAT") ; | "set_empty" -> ok C_SET_EMPTY
("bytes_slice" , "SLICE") ; | "set_mem" -> ok C_SET_MEM
("bytes_pack" , "PACK") ; | "set_add" -> ok C_SET_ADD
("set_empty" , "SET_EMPTY") ; | "set_remove" -> ok C_SET_REMOVE
("set_mem" , "SET_MEM") ; | "set_iter" -> ok C_SET_ITER
("set_add" , "SET_ADD") ; | "set_fold" -> ok C_SET_FOLD
("set_remove" , "SET_REMOVE") ; | "list_iter" -> ok C_LIST_ITER
("set_iter" , "SET_ITER") ; | "list_fold" -> ok C_LIST_FOLD
("set_fold" , "SET_FOLD") ; | "list_map" -> ok C_LIST_MAP
("list_iter" , "LIST_ITER") ; | "map_iter" -> ok C_MAP_ITER
("list_fold" , "LIST_FOLD") ; | "map_map" -> ok C_MAP_MAP
("list_map" , "LIST_MAP") ; | "map_fold" -> ok C_MAP_FOLD
("map_iter" , "MAP_ITER") ; | "map_remove" -> ok C_MAP_REMOVE
("map_map" , "MAP_MAP") ; | "map_update" -> ok C_MAP_UPDATE
("map_fold" , "MAP_FOLD") ; | "map_get" -> ok C_MAP_GET
("map_remove" , "MAP_REMOVE") ; | "sha_256" -> ok C_SHA256
("map_update" , "MAP_UPDATE") ; | "sha_512" -> ok C_SHA512
("map_get" , "MAP_GET") ; | "blake2b" -> ok C_BLAKE2b
("sha_256" , "SHA256") ; | "cons" -> ok C_CONS
("sha_512" , "SHA512") ; | "EQ" -> ok C_EQ
("blake2b" , "BLAKE2b") ; | "NEQ" -> ok C_NEQ
("cons" , "CONS") ; | "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_constants = type_constants
let type_operators = type_operators
end end
module Camligo = struct module Camligo = struct
let constants = [ let constants = function
("Bytes.pack" , "PACK") ; | "Bytes.pack" -> ok C_BYTES_PACK
("Crypto.hash" , "HASH") ; | "Crypto.hash" -> ok C_HASH (* TODO : Check if right *)
("Operation.transaction" , "CALL") ; | "Operation.transaction" -> ok C_CALL
("Operation.get_contract" , "CONTRACT") ; | "Operation.get_contract" -> ok C_CONTRACT
("sender" , "SENDER") ; | "sender" -> ok C_SENDER
("unit" , "UNIT") ; | "unit" -> ok C_UNIT
("source" , "SOURCE") ; | "source" -> ok C_SOURCE
] | _ -> simple_fail "Not a CamLIGO constant"
let type_constants = type_constants let type_constants = type_constants
let type_operators = type_operators
end end
module Ligodity = struct module Ligodity = struct
let constants = [ let constants = function
("assert" , "ASSERT") ; | "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") ; | "Crypto.hash" -> ok C_HASH
("balance", "BALANCE") ; | "Crypto.black2b" -> ok C_BLAKE2b
("Current.time", "NOW") ; | "Crypto.sha256" -> ok C_SHA256
("time", "NOW") ; | "Crypto.sha512" -> ok C_SHA512
("Current.amount" , "AMOUNT") ; | "Crypto.hash_key" -> ok C_HASH_KEY
("amount", "AMOUNT") ; | "Crypto.check" -> ok C_CHECK_SIGNATURE
("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" , "HASH") ; | "Bytes.pack" -> ok C_BYTES_PACK
("Crypto.black2b", "BLAKE2B") ; | "Bytes.unpack" -> ok C_BYTES_UNPACK
("Crypto.sha256", "SHA256") ; | "Bytes.length" -> ok C_SIZE
("Crypto.sha512", "SHA512") ; | "Bytes.size" -> ok C_SIZE
("Crypto.hash_key", "HASH_KEY") ; | "Bytes.concat" -> ok C_CONCAT
("Crypto.check", "CHECK_SIGNATURE") ; | "Bytes.slice" -> ok C_SLICE
| "Bytes.sub" -> ok C_SLICE
("Bytes.pack" , "PACK") ; | "Set.mem" -> ok C_SET_MEM
("Bytes.unpack", "UNPACK") ; | "Set.empty" -> ok C_SET_EMPTY
("Bytes.length", "SIZE") ; | "Set.literal" -> ok C_SET_LITERAL
("Bytes.size" , "SIZE") ; | "Set.add" -> ok C_SET_ADD
("Bytes.concat", "CONCAT") ; | "Set.remove" -> ok C_SET_REMOVE
("Bytes.slice", "SLICE") ; | "Set.fold" -> ok C_SET_FOLD
("Bytes.sub", "SLICE") ; | "Set.size" -> ok C_SIZE
("Set.mem" , "SET_MEM") ; | "Map.find_opt" -> ok C_MAP_FIND_OPT
("Set.empty" , "SET_EMPTY") ; | "Map.find" -> ok C_MAP_FIND
("Set.literal" , "SET_LITERAL") ; | "Map.update" -> ok C_MAP_UPDATE
("Set.add" , "SET_ADD") ; | "Map.add" -> ok C_MAP_ADD
("Set.remove" , "SET_REMOVE") ; | "Map.remove" -> ok C_MAP_REMOVE
("Set.fold" , "SET_FOLD") ; | "Map.iter" -> ok C_MAP_ITER
("Set.size", "SIZE") ; | "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") ; | "Big_map.find_opt" -> ok C_MAP_FIND_OPT
("Map.find" , "MAP_FIND") ; | "Big_map.find" -> ok C_MAP_FIND
("Map.update" , "MAP_UPDATE") ; | "Big_map.update" -> ok C_MAP_UPDATE
("Map.add" , "MAP_ADD") ; | "Big_map.add" -> ok C_MAP_ADD
("Map.remove" , "MAP_REMOVE") ; | "Big_map.remove" -> ok C_MAP_REMOVE
("Map.iter" , "MAP_ITER") ; | "Big_map.literal" -> ok C_BIG_MAP_LITERAL
("Map.map" , "MAP_MAP") ; | "Big_map.empty" -> ok C_BIG_MAP_EMPTY
("Map.fold" , "MAP_FOLD") ;
("Map.empty" , "MAP_EMPTY") ;
("Map.literal" , "MAP_LITERAL" ) ;
("Map.size" , "SIZE" ) ;
("Big_map.find_opt" , "MAP_FIND_OPT") ; | "Bitwise.lor" -> ok C_OR
("Big_map.find" , "MAP_FIND") ; | "Bitwise.land" -> ok C_AND
("Big_map.update" , "MAP_UPDATE") ; | "Bitwise.lxor" -> ok C_XOR
("Big_map.add" , "MAP_ADD") ;
("Big_map.remove" , "MAP_REMOVE") ;
("Big_map.literal" , "BIG_MAP_LITERAL" ) ;
("Big_map.empty" , "BIG_MAP_EMPTY" ) ;
("Bitwise.lor" , "OR") ; | "String.length" -> ok C_SIZE
("Bitwise.land" , "AND") ; | "String.size" -> ok C_SIZE
("Bitwise.lxor" , "XOR") ; | "String.slice" -> ok C_SLICE
| "String.sub" -> ok C_SLICE
| "String.concat" -> ok C_CONCAT
("String.length", "SIZE") ; | "List.length" -> ok C_SIZE
("String.size", "SIZE") ; | "List.size" -> ok C_SIZE
("String.slice", "SLICE") ; | "List.iter" -> ok C_LIST_ITER
("String.sub", "SLICE") ; | "List.map" -> ok C_LIST_MAP
("String.concat", "CONCAT") ; | "List.fold" -> ok C_LIST_FOLD
("List.length", "SIZE") ; | "Loop.fold_while" -> ok C_FOLD_WHILE
("List.size", "SIZE") ; | "continue" -> ok C_CONTINUE
("List.iter", "LIST_ITER") ; | "stop" -> ok C_STOP
("List.map" , "LIST_MAP") ;
("List.fold" , "LIST_FOLD") ;
("Loop.fold_while" , "FOLD_WHILE") ; | "Operation.transaction" -> ok C_CALL
("continue" , "CONTINUE") ; | "Operation.get_contract" -> ok C_CONTRACT
("stop" , "STOP") ; | "Operation.get_entrypoint" -> ok C_CONTRACT_ENTRYPOINT
| "int" -> ok C_INT
| "abs" -> ok C_ABS
| "unit" -> ok C_UNIT
("Operation.transaction" , "CALL") ; | "NEG" -> ok C_NEG
("Operation.get_contract" , "CONTRACT") ; | "ADD" -> ok C_ADD
("Operation.get_entrypoint" , "CONTRACT_ENTRYPOINT") ; | "SUB" -> ok C_SUB
("int" , "INT") ; | "TIMES" -> ok C_MUL
("abs" , "ABS") ; | "DIV" -> ok C_DIV
("unit" , "UNIT") ; | "MOD" -> ok C_MOD
("source" , "SOURCE") ; | "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_constants = type_constants
let type_operators = type_operators
end end
end end
@ -295,10 +335,10 @@ module Typer = struct
let t_sender = address let t_sender = address
let t_source = address let t_source = address
let t_unit = unit let t_unit = unit
let t_amount = tez let t_amount = mutez
let t_address = address let t_address = address
let t_now = timestamp 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_get_contract = forall "a" @@ fun a -> contract a
let t_abs = int --> nat let t_abs = int --> nat
let t_cons = forall "a" @@ fun a -> a --> list a --> list a 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 let%bind () = assert_eq_1 hd elt in
ok tl ok tl
let constant_typers = Map.String.of_list [ let constant_typers c : typer result = match c with
add ; | C_INT -> ok @@ int ;
times ; | C_UNIT -> ok @@ unit ;
div ; | C_NOW -> ok @@ now ;
mod_ ; | C_IS_NAT -> ok @@ is_nat ;
sub ; | C_SOME -> ok @@ some ;
none ; | C_NONE -> ok @@ none ;
some ; | C_ASSERTION -> ok @@ assertion ;
concat ; | C_FAILWITH -> ok @@ failwith_ ;
slice ; (* LOOPS *)
comparator "EQ" ; | C_FOLD_WHILE -> ok @@ fold_while ;
comparator "NEQ" ; | C_CONTINUE -> ok @@ continue ;
comparator "LT" ; | C_STOP -> ok @@ stop ;
comparator "GT" ; (* MATH *)
comparator "LE" ; | C_NEG -> ok @@ neg ;
comparator "GE" ; | C_ABS -> ok @@ abs ;
or_ ; | C_ADD -> ok @@ add ;
and_ ; | C_SUB -> ok @@ sub ;
xor ; | C_MUL -> ok @@ times;
not_ ; | C_DIV -> ok @@ div ;
map_remove ; | C_MOD -> ok @@ mod_ ;
map_add ; (* LOGIC *)
map_update ; | C_NOT -> ok @@ not_ ;
map_mem ; | C_AND -> ok @@ and_ ;
map_find ; | C_OR -> ok @@ or_ ;
map_find_opt ; | C_XOR -> ok @@ xor ;
map_map ; (* COMPARATOR *)
map_fold ; | C_EQ -> ok @@ comparator "EQ" ;
fold_while ; | C_NEQ -> ok @@ comparator "NEQ" ;
continue ; | C_LT -> ok @@ comparator "LT" ;
stop ; | C_GT -> ok @@ comparator "GT" ;
map_iter ; | C_LE -> ok @@ comparator "LE" ;
map_get_force ; | C_GE -> ok @@ comparator "GE" ;
map_get ; (* BYTES / STRING *)
set_empty ; | C_SIZE -> ok @@ size ;
set_mem ; | C_CONCAT -> ok @@ concat ;
set_add ; | C_SLICE -> ok @@ slice ;
set_remove ; | C_BYTES_PACK -> ok @@ bytes_pack ;
set_iter ; | C_BYTES_UNPACK -> ok @@ bytes_unpack ;
set_fold ; | C_CONS -> ok @@ cons ;
list_iter ; (* SET *)
list_map ; | C_SET_EMPTY -> ok @@ set_empty ;
list_fold ; | C_SET_ADD -> ok @@ set_add ;
int ; | C_SET_REMOVE -> ok @@ set_remove ;
size ; | C_SET_ITER -> ok @@ set_iter ;
failwith_ ; | C_SET_FOLD -> ok @@ set_fold ;
bytes_pack ; | C_SET_MEM -> ok @@ set_mem ;
bytes_unpack ;
hash256 ; (* LIST *)
hash512 ; | C_LIST_ITER -> ok @@ list_iter ;
blake2b ; | C_LIST_MAP -> ok @@ list_map ;
hash_key ; | C_LIST_FOLD -> ok @@ list_fold ;
check_signature ; | C_LIST_CONS -> ok @@ list_cons ;
sender ; (* MAP *)
source ; | C_MAP_GET -> ok @@ map_get ;
chain_id ; | C_MAP_GET_FORCE -> ok @@ map_get_force ;
unit ; | C_MAP_ADD -> ok @@ map_add ;
balance ; | C_MAP_REMOVE -> ok @@ map_remove ;
amount ; | C_MAP_UPDATE -> ok @@ map_update ;
transaction ; | C_MAP_ITER -> ok @@ map_iter ;
get_contract ; | C_MAP_MAP -> ok @@ map_map ;
get_entrypoint ; | C_MAP_FOLD -> ok @@ map_fold ;
neg ; | C_MAP_MEM -> ok @@ map_mem ;
abs ; | C_MAP_FIND -> ok @@ map_find ;
is_nat ; | C_MAP_FIND_OPT -> ok @@ map_find_opt ;
cons ; (* BIG MAP *)
now ; (* CRYPTO *)
slice ; | C_SHA256 -> ok @@ hash256 ;
address ; | C_SHA512 -> ok @@ hash512 ;
self_address ; | C_BLAKE2b -> ok @@ blake2b ;
implicit_account ; | C_HASH_KEY -> ok @@ hash_key ;
assertion ; | C_CHECK_SIGNATURE -> ok @@ check_signature ;
list_cons ; | 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 end
@ -832,74 +885,71 @@ module Compiler = struct
include Helpers.Compiler include Helpers.Compiler
open Tezos_utils.Michelson 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. 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 module Simplify : sig
open Ast_simplified
open Trace
module Pascaligo : sig module Pascaligo : sig
val constants : ( string * string ) list val constants : string -> constant result
val type_constants : ( string * string ) list val type_constants : string -> type_constant result
val type_operators : string -> type_expression type_operator result
end end
module Camligo : sig module Camligo : sig
val constants : ( string * string ) list val constants : string -> constant result
val type_constants : ( string * string ) list val type_constants : string -> type_constant result
val type_operators : string -> type_expression type_operator result
end end
module Ligodity : sig module Ligodity : sig
val constants : ( string * string ) list val constants : string -> constant result
val type_constants : ( string * string ) list val type_constants : string -> type_constant result
val type_operators : string -> type_expression type_operator result
end end
end end
@ -21,6 +26,7 @@ end
module Typer : sig module Typer : sig
open Helpers.Typer open Helpers.Typer
open Ast_typed open Ast_typed
open Trace
module Operators_types : sig module Operators_types : sig
(* TODO: we need a map from type names to type values. Then, all (* TODO: we need a map from type names to type values. Then, all
@ -169,7 +175,7 @@ module Typer : sig
val concat : typer val concat : typer
*) *)
val cons : typer val cons : typer
val constant_typers : typer' type_name_map val constant_typers : constant -> typer result
end end
@ -178,6 +184,8 @@ module Compiler : sig
include Helpers.Compiler include Helpers.Compiler
*) *)
open Tezos_utils.Michelson open Tezos_utils.Michelson
open Mini_c
open Trace
type predicate = type predicate =
| Constant of michelson | Constant of michelson
@ -187,7 +195,7 @@ module Compiler : sig
| Tetrary of michelson | Tetrary of michelson
| Pentary of michelson | Pentary of michelson
| Hexary of michelson | Hexary of michelson
val operators : predicate Map.String.t val get_operators : constant -> predicate result
val simple_constant : t -> predicate val simple_constant : t -> predicate
val simple_unary : t -> predicate val simple_unary : t -> predicate
val simple_binary : t -> predicate val simple_binary : t -> predicate

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

@ -1,49 +1,27 @@
open Types open Types
open PP_helpers open PP_helpers
open Format open Format
include Stage_common.PP
let list_sep_d x ppf lst = match lst with let list_sep_d x ppf lst = match lst with
| [] -> () | [] -> ()
| _ -> fprintf ppf "@; @[<v>%a@]@;" (list_sep x (tag "@;")) lst | _ -> fprintf ppf "@; @[<v>%a@]@;" (list_sep x (tag "@;")) lst
let smap_sep_d x ppf m = let rec te' ppf (te : type_expression type_expression') : unit =
if Map.String.is_empty m type_expression' type_expression ppf te
then ()
else fprintf ppf "@; @[<v>%a@]@;" (smap_sep x (tag "@;")) m
let rec type_expression ppf (te:type_expression) = match te with and type_expression ppf (te: type_expression) : unit =
| T_tuple lst -> fprintf ppf "tuple[%a]" (list_sep_d type_expression) lst te' ppf te.type_expression'
| 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)"
let rec expression ppf (e:expression) = match e.expression with let rec expression ppf (e:expression) = match e.expression with
| E_literal l -> literal ppf l | 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_application (f, arg) -> fprintf ppf "(%a)@(%a)" expression f expression arg
| E_constructor (name, ae) -> fprintf ppf "%s(%a)" name expression ae | E_constructor (c, ae) -> fprintf ppf "%a(%a)" constructor c expression ae
| E_constant (name, lst) -> fprintf ppf "%s(%a)" name (list_sep_d expression) lst | 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_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_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_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_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 | 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" fprintf ppf "%a ; %a"
expression expr expression expr
expression body expression body
| E_assign (name , path , expr) -> | E_assign (n , path , expr) ->
fprintf ppf "%s.%a := %a" fprintf ppf "%a.%a := %a"
name name n
PP_helpers.(list_sep access (const ".")) path PP_helpers.(list_sep access (const ".")) path
expression expr expression expr
| E_let_in { binder ; rhs ; result } -> | E_let_in { binder ; rhs ; result } ->
fprintf ppf "let %a = %a in %a" option_type_name binder expression rhs expression result fprintf ppf "let %a = %a in %a" option_type_name binder expression rhs expression result
| E_skip -> fprintf ppf "skip" | 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 match ty_opt with
| None -> fprintf ppf "%s" name | None -> fprintf ppf "%a" name n
| Some ty -> fprintf ppf "%s : %a" name type_expression ty | Some ty -> fprintf ppf "%a : %a" name n type_expression ty
and assoc_expression ppf : (expr * expr) -> unit = fun (a, b) -> and assoc_expression ppf : (expr * expr) -> unit = fun (a, b) ->
fprintf ppf "%a -> %a" expression a expression b fprintf ppf "%a -> %a" expression a expression b
and access ppf (a:access) = and access ppf (a:access) =
match a with match a with
| Access_tuple n -> fprintf ppf "%d" n | Access_tuple i -> fprintf ppf "%d" i
| Access_record s -> fprintf ppf "%s" s | Access_record l -> fprintf ppf "%s" l
and access_path ppf (p:access_path) = and access_path ppf (p:access_path) =
fprintf ppf "%a" (list_sep access (const ".")) p 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) = and single_tuple_patch ppf ((p, expr) : int * expr) =
fprintf ppf "%d <- %a" p expression 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) -> 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 fun f ppf m -> match m with
| Match_tuple (lst, b) -> | Match_tuple ((lst, b), _) ->
fprintf ppf "let (%a) = %a" (list_sep_d string) lst f b fprintf ppf "let (%a) = %a" (list_sep_d name) lst f b
| Match_variant lst -> | Match_variant (lst, _) ->
fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst
| Match_bool {match_true ; match_false} -> | Match_bool {match_true ; match_false} ->
fprintf ppf "| True -> %a @.| False -> %a" f match_true f match_false fprintf ppf "| True -> %a @.| False -> %a" f match_true f match_false
| Match_list {match_nil ; match_cons = (hd, tl, match_cons)} -> | 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 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)} -> | Match_option {match_none ; match_some = (some, match_some, _)} ->
fprintf ppf "| None -> %a @.| Some %s -> %a" f match_none some f 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 *) (* Shows the type expected for the matched value *)
and matching_type ppf m = match m with and matching_type ppf m = match m with
| Match_tuple _ -> | Match_tuple _ ->
fprintf ppf "tuple" fprintf ppf "tuple"
| Match_variant lst -> | Match_variant (lst, _) ->
fprintf ppf "variant %a" (list_sep matching_variant_case_type (tag "@.")) lst fprintf ppf "variant %a" (list_sep matching_variant_case_type (tag "@.")) lst
| Match_bool _ -> | Match_bool _ ->
fprintf ppf "boolean" fprintf ppf "boolean"
@ -131,11 +109,11 @@ and matching_type ppf m = match m with
fprintf ppf "option" fprintf ppf "option"
and matching_variant_case_type ppf ((c,n),_a) = 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 let declaration ppf (d:declaration) = match d with
| Declaration_type (type_name , te) -> | 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) -> | Declaration_constant (name , ty_opt , expr) ->
fprintf ppf "const %a = %a" option_type_name (name , ty_opt) expression 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 *) (** 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 val matching_variant_case_type : formatter -> ( ( constructor_name * name) * 'a) -> unit

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

@ -15,47 +15,62 @@ module Errors = struct
end end
open Errors open Errors
let t_bool : type_expression = T_constant ("bool", []) let make_t type_expression' = {type_expression'}
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 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 t_record_ez lst =
let m = SMap.of_list lst in let lst = List.map (fun (k, v) -> (Label k, v)) lst in
t_record m 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 ez_t_sum (lst:(string * type_expression) list) : type_expression =
let aux prev (k, v) = SMap.add k v prev in let aux prev (k, v) = CMap.add (Constructor k) v prev in
let map = List.fold_left aux SMap.empty lst in let map = List.fold_left aux CMap.empty lst in
T_sum map 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_function param result : type_expression = make_t @@ T_arrow (param, result)
let t_map key value = (T_constant ("map", [key ; value])) let t_map key value : type_expression = make_t @@ T_operator (TC_map (key, value))
let t_big_map key value = (T_constant ("big_map", [key ; value])) let t_big_map key value : type_expression = make_t @@ T_operator (TC_big_map (key , value))
let t_set key = (T_constant ("set", [key])) 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_wrap ?(loc = Location.generated) expression =
let location = loc in let location = loc in
{ location ; expression } { 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_literal ?loc l : expression = location_wrap ?loc @@ E_literal l
let e_unit ?loc () : expression = location_wrap ?loc @@ E_literal (Literal_unit) 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) 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_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_record ?loc map : expression = location_wrap ?loc @@ E_record map
let e_tuple ?loc lst : expression = location_wrap ?loc @@ E_tuple lst 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_some ?loc s : expression = location_wrap ?loc @@ E_constant (C_SOME, [s])
let e_none ?loc () : expression = location_wrap ?loc @@ E_constant ("NONE", []) 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 ("CONCAT" , [sl ; sr ]) 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 ("MAP_ADD" , [k ; v ; old]) 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_map ?loc lst : expression = location_wrap ?loc @@ E_map lst
let e_set ?loc lst : expression = location_wrap ?loc @@ E_set 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_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_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 ?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_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) 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_skip ?loc () = location_wrap ?loc @@ E_skip
let e_loop ?loc cond body = location_wrap ?loc @@ E_loop (cond , body) 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_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_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_annotation (expr , ty) 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_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_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_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 = let make_option_typed ?loc e t_opt =
match t_opt with match t_opt with
@ -111,9 +131,10 @@ let make_option_typed ?loc e t_opt =
| Some t -> e_annotation ?loc e t | Some t -> e_annotation ?loc e t
let ez_e_record ?loc lst = let ez_e_record ?loc (lst : (string * expr) list) =
let aux prev (k, v) = SMap.add k v prev in let aux prev (k, v) = LMap.add k v prev in
let map = List.fold_left aux SMap.empty lst 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 e_record ?loc map
let e_typed_none ?loc t_opt = 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_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) (input_type : type_expression option)
(output_type : type_expression option) (output_type : type_expression option)
(result : expression) (result : expression)
: expression = : expression =
location_wrap ?loc @@ E_lambda { location_wrap ?loc @@ E_lambda {
binder = (make_name binder , input_type) ; binder = (binder , input_type) ;
input_type = input_type ; input_type = input_type ;
output_type = output_type ; output_type = output_type ;
result ; result ;
} }
let e_record ?loc map = location_wrap ?loc @@ E_record map
let e_ez_record ?loc (lst : (string * expr) list) : expression = let e_ez_record ?loc (lst : (string * expr) list) : expression =
let map = SMap.of_list lst in let map = List.fold_left (fun m (x, y) -> LMap.add (Label x) y m) LMap.empty lst in
e_record ?loc map 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 -> let get_e_accessor = fun t ->
match t with match t with
@ -185,9 +207,9 @@ let extract_list : expression -> (expression list) result = fun e ->
| E_list lst -> ok lst | E_list lst -> ok lst
| _ -> fail @@ bad_kind "list" e.location | _ -> 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 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 | _ -> fail @@ bad_kind "record" e.location
let extract_map : expression -> (expression * expression) list result = fun e -> 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 val bad_kind : name -> Location.t -> unit -> error
end end
*) *)
val make_t : type_expression type_expression' -> type_expression
val t_bool : type_expression val t_bool : type_expression
val t_string : type_expression val t_string : type_expression
val t_bytes : 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_option : type_expression -> type_expression
*) *)
val t_list : 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_tuple : type_expression list -> type_expression
val t_record : te_map -> type_expression val t_record : te_map -> type_expression
*) *)
val t_pair : ( type_expression * type_expression ) -> 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_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 ez_t_sum : ( string * type_expression ) list -> type_expression
val t_function : type_expression -> type_expression -> type_expression val t_function : type_expression -> type_expression -> type_expression
val t_map : 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 t_set : type_expression -> type_expression
(*
val make_name : string -> name
*)
val e_var : ?loc:Location.t -> string -> expression val e_var : ?loc:Location.t -> string -> expression
val e_literal : ?loc:Location.t -> literal -> expression val e_literal : ?loc:Location.t -> literal -> expression
val e_unit : ?loc:Location.t -> unit -> 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_set : ?loc:Location.t -> expression list -> expression
val e_list : ?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_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 : ?loc:Location.t -> expression -> matching_expr -> expression
val e_matching_bool : ?loc:Location.t -> expression -> expression -> expression -> 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 : ?loc:Location.t -> expression -> access_path -> expression
val e_accessor_props : ?loc:Location.t -> expression -> name list -> expression val e_accessor_props : ?loc:Location.t -> expression -> string list -> expression
val e_variable : ?loc:Location.t -> name -> expression val e_variable : ?loc:Location.t -> expression_variable -> expression
val e_skip : ?loc:Location.t -> unit -> expression val e_skip : ?loc:Location.t -> unit -> expression
val e_loop : ?loc:Location.t -> expression -> expression -> expression val e_loop : ?loc:Location.t -> expression -> expression -> expression
val e_sequence : ?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_annotation : ?loc:Location.t -> expression -> type_expression -> expression
val e_application : ?loc:Location.t -> expression -> expression -> expression val e_application : ?loc:Location.t -> expression -> expression -> expression
val e_binop : ?loc:Location.t -> name -> expression -> expression -> expression val e_binop : ?loc:Location.t -> constant -> expression -> expression -> expression
val e_constant : ?loc:Location.t -> name -> expression list -> expression val e_constant : ?loc:Location.t -> constant -> expression list -> expression
val e_look_up : ?loc:Location.t -> expression -> expression -> 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 make_option_typed : ?loc:Location.t -> expression -> type_expression option -> expression
val ez_e_record : ?loc:Location.t -> ( string * expression ) list -> 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_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_lambda : ?loc:Location.t -> expression_variable -> type_expression option -> type_expression option -> expression -> expression
val e_record : ?loc:Location.t -> expr_map -> expression val e_record : ?loc:Location.t -> expr Map.String.t -> expression
val e_ez_record : ?loc:Location.t -> ( string * expr ) list -> 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_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 val extract_map : expression -> (expression * expression) list result

1
src/stages/ast_simplified/dune
View File

@ -4,6 +4,7 @@
(libraries (libraries
simple-utils simple-utils
tezos-utils tezos-utils
stage_common
) )
(preprocess (preprocess
(pps ppx_let) (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 a, Some b -> Some (assert_value_eq (a, b))
| _ -> Some (simple_fail "different record keys") | _ -> Some (simple_fail "different record keys")
in 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 () ok ()
) )
| E_record _, _ -> | E_record _, _ ->
@ -170,8 +170,8 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
| E_set _, _ -> | E_set _, _ ->
simple_fail "comparing set with other stuff" simple_fail "comparing set with other stuff"
| (E_annotation (a , _) , _b') -> assert_value_eq (a , b) | (E_ascription (a , _) , _b') -> assert_value_eq (a , b)
| (_a' , E_annotation (b , _)) -> assert_value_eq (a , b) | (_a' , E_ascription (b , _)) -> assert_value_eq (a , b)
| (E_variable _, _) | (E_lambda _, _) | (E_variable _, _) | (E_lambda _, _)
| (E_application _, _) | (E_let_in _, _) | (E_application _, _) | (E_let_in _, _)
| (E_accessor _, _) | (E_accessor _, _)

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

@ -1,43 +1,28 @@
[@@@warning "-30"] [@@@warning "-30"]
module Map = Simple_utils.Map
module Location = Simple_utils.Location module Location = Simple_utils.Location
include Stage_common.Types
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
type program = declaration Location.wrap list type program = declaration Location.wrap list
and type_expression = {
type_expression' : type_expression type_expression'
}
and declaration = and declaration =
| Declaration_type of (type_name * type_expression) | Declaration_type of (type_variable * type_expression)
| Declaration_constant of (name * type_expression option * expression) | Declaration_constant of (expression_variable * type_expression option * expression)
(* | Macro_declaration of macro_declaration *) (* | Macro_declaration of macro_declaration *)
and expr = expression 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 = { and lambda = {
binder : (name * type_expression option) ; binder : (expression_variable * type_expression option) ;
input_type : type_expression option ; input_type : type_expression option ;
output_type : type_expression option ; output_type : type_expression option ;
result : expr ; result : expr ;
} }
and let_in = { and let_in = {
binder : (name * type_expression option) ; binder : (expression_variable * type_expression option) ;
rhs : expr ; rhs : expr ;
result : expr ; result : expr ;
} }
@ -45,17 +30,17 @@ and let_in = {
and expression' = and expression' =
(* Base *) (* Base *)
| E_literal of literal | E_literal of literal
| E_constant of (name * expr list) (* For language constants, like (Cons hd tl) or (plus i j) *) | E_constant of (constant * expr list) (* For language constants, like (Cons hd tl) or (plus i j) *)
| E_variable of name | E_variable of expression_variable
| E_lambda of lambda | E_lambda of lambda
| E_application of (expr * expr) | E_application of (expr * expr)
| E_let_in of let_in | E_let_in of let_in
(* E_Tuple *) (* E_Tuple *)
| E_tuple of expr list | E_tuple of expr list
(* Sum *) (* Sum *)
| E_constructor of (name * expr) (* For user defined constructors *) | E_constructor of (constructor * expr) (* For user defined constructors *)
(* E_record *) (* E_record *)
| E_record of expr_map | E_record of expr label_map
(* TODO: Change it to (expr * access) *) (* TODO: Change it to (expr * access) *)
| E_accessor of (expr * access_path) | E_accessor of (expr * access_path)
(* Data Structures *) (* Data Structures *)
@ -69,52 +54,15 @@ and expression' =
(* Replace Statements *) (* Replace Statements *)
| E_sequence of (expr * expr) | E_sequence of (expr * expr)
| E_loop 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 | E_skip
(* Annotate *) (* Annotate *)
| E_annotation of expr * type_expression | E_ascription of expr * type_expression
and expression = { and expression = {
expression : expression' ; expression : expression' ;
location : Location.t ; location : Location.t ;
} }
and access =
| Access_tuple of int
| Access_record of string
and access_path = access list and matching_expr = (expr,unit) matching
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

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

@ -1,20 +1,13 @@
open Types open Types
open Format open Format
open PP_helpers open PP_helpers
include Stage_common.PP
let list_sep_d x = list_sep x (const " , ") 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 = let rec type_value' ppf (tv':type_value type_expression') : unit =
match tv' with type_expression' type_value ppf tv'
| 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
and type_value ppf (tv:type_value) : unit = and type_value ppf (tv:type_value) : unit =
type_value' ppf tv.type_value' type_value' ppf tv.type_value'
@ -26,21 +19,22 @@ let rec annotated_expression ppf (ae:annotated_expression) : unit =
and lambda ppf l = and lambda ppf l =
let ({ binder ; body } : lambda) = l in let ({ binder ; body } : lambda) = l in
fprintf ppf "lambda (%s) -> %a" fprintf ppf "lambda (%a) -> %a"
binder annotated_expression body name binder
annotated_expression body
and expression ppf (e:expression) : unit = and expression ppf (e:expression) : unit =
match e with match e with
| E_literal l -> literal ppf l | E_literal l -> Stage_common.PP.literal ppf l
| E_constant (c, lst) -> fprintf ppf "%s(%a)" c (list_sep_d annotated_expression) lst | E_constant (b, lst) -> fprintf ppf "%a(%a)" constant b (list_sep_d annotated_expression) lst
| E_constructor (c, lst) -> fprintf ppf "%s(%a)" c annotated_expression lst | E_constructor (c, lst) -> fprintf ppf "%a(%a)" constructor c annotated_expression lst
| E_variable a -> fprintf ppf "%s" a | E_variable a -> fprintf ppf "%a" name a
| E_application (f, arg) -> fprintf ppf "(%a) (%a)" annotated_expression f annotated_expression arg | E_application (f, arg) -> fprintf ppf "(%a) (%a)" annotated_expression f annotated_expression arg
| E_lambda l -> fprintf ppf "%a" lambda l | E_lambda l -> fprintf ppf "%a" lambda l
| E_tuple_accessor (ae, i) -> fprintf ppf "%a.%d" annotated_expression ae i | 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_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_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_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 | 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_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_loop (expr , body) -> fprintf ppf "while %a { %a }" annotated_expression expr annotated_expression body
| E_assign (name , path , expr) -> | E_assign (name , path , expr) ->
fprintf ppf "%s.%a := %a" fprintf ppf "%a.%a := %a"
name.type_name Stage_common.PP.name name.type_name
PP_helpers.(list_sep pre_access (const ".")) path PP_helpers.(list_sep pre_access (const ".")) path
annotated_expression expr annotated_expression expr
| E_let_in { binder; rhs; result } -> | E_let_in { binder; rhs; result } -> fprintf ppf "let %a = %a in %a" name binder annotated_expression rhs annotated_expression result
fprintf ppf "let %s = %a in %a" binder annotated_expression rhs annotated_expression result
and value ppf v = annotated_expression ppf v and value ppf v = annotated_expression ppf v
and assoc_annotated_expression ppf : (ae * ae) -> unit = fun (a, b) -> and assoc_annotated_expression ppf : (ae * ae) -> unit = fun (a, b) ->
fprintf ppf "%a -> %a" annotated_expression a annotated_expression 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) = and single_record_patch ppf ((s, ae) : string * ae) =
fprintf ppf "%s <- %a" s annotated_expression 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) -> 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 and matching : type a . (formatter -> a -> unit) -> _ -> (a, 'var) matching -> unit = fun f ppf m -> match m with
| Match_tuple (lst, b) -> | Match_tuple ((lst, b),_) ->
fprintf ppf "let (%a) = %a" (list_sep_d (fun ppf -> fprintf ppf "%s")) lst f b fprintf ppf "let (%a) = %a" (list_sep_d Stage_common.PP.name) lst f b
| Match_variant (lst , _) -> | Match_variant (lst, _) ->
fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst
| Match_bool {match_true ; match_false} -> | Match_bool {match_true ; match_false} ->
fprintf ppf "| True -> %a @.| False -> %a" f match_true f 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)} -> | 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 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)} -> | Match_option {match_none ; match_some = (some, match_some, _)} ->
fprintf ppf "| None -> %a @.| Some %s -> %a" f match_none (fst some) f 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 and pre_access ppf (a:access) = match a with
| Access_record n -> fprintf ppf ".%s" n | 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) = let declaration ppf (d:declaration) =
match d with match d with
| Declaration_constant ({name ; annotated_expression = ae} , _) -> | 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) = let program ppf (p:program) =
fprintf ppf "@[<v>%a@]" (list_sep declaration (tag "@;")) (List.map Location.unwrap p) 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 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 val matching : ( formatter -> 'a -> unit ) -> formatter -> 'a matching -> unit

123
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_e name a_e = { name ; annotated_expression = a_e }
let make_n_t type_name type_value = { type_name ; type_value } 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_signature ?s () : type_value = make_t (T_constant TC_signature) s
let t_string ?s () : type_value = make_t (T_constant (Type_name "string", [])) s let t_chain_id ?s () : type_value = make_t (T_constant TC_chain_id) s
let t_bytes ?s () : type_value = make_t (T_constant (Type_name "bytes", [])) s let t_bool ?s () : type_value = make_t (T_constant TC_bool) s
let t_key ?s () : type_value = make_t (T_constant (Type_name "key", [])) s let t_string ?s () : type_value = make_t (T_constant TC_string) s
let t_key_hash ?s () : type_value = make_t (T_constant (Type_name "key_hash", [])) s let t_bytes ?s () : type_value = make_t (T_constant TC_bytes) s
let t_signature ?s () : type_value = make_t (T_constant (Type_name "signature", [])) s let t_key ?s () : type_value = make_t (T_constant TC_key) s
let t_int ?s () : type_value = make_t (T_constant (Type_name "int", [])) s let t_key_hash ?s () : type_value = make_t (T_constant TC_key_hash) s
let t_address ?s () : type_value = make_t (T_constant (Type_name "address", [])) s let t_int ?s () : type_value = make_t (T_constant TC_int) s
let t_chain_id ?s () : type_value = make_t (T_constant (Type_name "chain_id", [])) s let t_address ?s () : type_value = make_t (T_constant TC_address) s
let t_operation ?s () : type_value = make_t (T_constant (Type_name "operation", [])) s let t_operation ?s () : type_value = make_t (T_constant TC_operation) s
let t_nat ?s () : type_value = make_t (T_constant (Type_name "nat", [])) s let t_nat ?s () : type_value = make_t (T_constant TC_nat) s
let t_mutez ?s () : type_value = make_t (T_constant (Type_name "tez", [])) s let t_mutez ?s () : type_value = make_t (T_constant TC_mutez) s
let t_timestamp ?s () : type_value = make_t (T_constant (Type_name "timestamp", [])) s let t_timestamp ?s () : type_value = make_t (T_constant TC_timestamp) s
let t_unit ?s () : type_value = make_t (T_constant (Type_name "unit", [])) s let t_unit ?s () : type_value = make_t (T_constant TC_unit) s
let t_option o ?s () : type_value = make_t (T_constant (Type_name "option", [o])) 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_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_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_list t ?s () : type_value = make_t (T_operator (TC_list t)) s
let t_set t ?s () : type_value = make_t (T_constant (Type_name "set", [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_constant (Type_name "contract", [t])) s let t_contract t ?s () : type_value = make_t (T_operator (TC_contract t)) s
let t_pair a b ?s () = t_tuple [a ; b] ?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 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 make_t_ez_record (lst:(label * type_value) list) : type_value =
let aux prev (k, v) = SMap.add k v prev in let aux prev (k, v) = LMap.add k v prev in
let map = List.fold_left aux SMap.empty lst in let map = List.fold_left aux LMap.empty lst in
make_t (T_record map) None make_t (T_record map) None
let ez_t_record lst ?s () : type_value = 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 () t_record m ?s ()
let t_map key value ?s () = make_t (T_constant (Type_name "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_constant (Type_name "big_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 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 make_t_ez_sum (lst:(constructor * type_value) list) : type_value =
let aux prev (k, v) = SMap.add k v prev in let aux prev (k, v) = CMap.add k v prev in
let map = List.fold_left aux SMap.empty lst in let map = List.fold_left aux CMap.empty lst in
make_t (T_sum map) None make_t (T_sum map) None
let t_function 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_function (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_annotation (x:annotated_expression) = x.type_annotation
let get_type' (x:type_value) = x.type_value' 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 = let get_lambda_with_type e =
match (e.expression , e.type_annotation.type_value') with 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" | _ -> simple_fail "not a lambda with functional type"
let get_t_bool (t:type_value) : unit result = match t.type_value' with 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" | _ -> simple_fail "not a bool"
let get_t_int (t:type_value) : unit result = match t.type_value' with 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" | _ -> simple_fail "not a int"
let get_t_nat (t:type_value) : unit result = match t.type_value' with 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" | _ -> simple_fail "not a nat"
let get_t_unit (t:type_value) : unit result = match t.type_value' with 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" | _ -> simple_fail "not a unit"
let get_t_mutez (t:type_value) : unit result = match t.type_value' with 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" | _ -> simple_fail "not a tez"
let get_t_bytes (t:type_value) : unit result = match t.type_value' with 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" | _ -> simple_fail "not a bytes"
let get_t_string (t:type_value) : unit result = match t.type_value' with 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" | _ -> simple_fail "not a string"
let get_t_contract (t:type_value) : type_value result = match t.type_value' with 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" | _ -> simple_fail "not a contract"
let get_t_option (t:type_value) : type_value result = match t.type_value' with 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" | _ -> simple_fail "not a option"
let get_t_list (t:type_value) : type_value result = match t.type_value' with 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" | _ -> simple_fail "not a list"
let get_t_set (t:type_value) : type_value result = match t.type_value' with 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" | _ -> simple_fail "not a set"
let get_t_key (t:type_value) : unit result = match t.type_value' with 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" | _ -> simple_fail "not a key"
let get_t_signature (t:type_value) : unit result = match t.type_value' with 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" | _ -> simple_fail "not a signature"
let get_t_key_hash (t:type_value) : unit result = match t.type_value' with 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" | _ -> simple_fail "not a key_hash"
let get_t_tuple (t:type_value) : type_value list result = match t.type_value' with 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" | _ -> simple_fail "not a tuple"
let get_t_function (t:type_value) : (type_value * type_value) result = match t.type_value' with 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" | _ -> 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 | T_sum m -> ok m
| _ -> simple_fail "not a sum" | _ -> 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 | T_record m -> ok m
| _ -> simple_fail "not a record type" | _ -> simple_fail "not a record type"
let get_t_map (t:type_value) : (type_value * type_value) result = let get_t_map (t:type_value) : (type_value * type_value) result =
match t.type_value' with 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" | _ -> simple_fail "get: not a map"
let get_t_big_map (t:type_value) : (type_value * type_value) result = let get_t_big_map (t:type_value) : (type_value * type_value) result =
match t.type_value' with 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" | _ -> simple_fail "get: not a big_map"
let get_t_map_key : type_value -> type_value result = fun t -> 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_key_hash = get_t_key_hash
let assert_t_contract (t:type_value) : unit result = match t.type_value' with 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" | _ -> simple_fail "not a contract"
let assert_t_list t = let assert_t_list t =
@ -207,7 +207,7 @@ let assert_t_bytes = fun t ->
let assert_t_operation (t:type_value) : unit result = let assert_t_operation (t:type_value) : unit result =
match t.type_value' with match t.type_value' with
| T_constant (Type_name "operation" , []) -> ok () | T_constant (TC_operation) -> ok ()
| _ -> simple_fail "assert: not an operation" | _ -> simple_fail "assert: not an operation"
let assert_t_list_operation (t : type_value) : unit result = 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' assert_t_operation t'
let assert_t_int : type_value -> unit result = fun t -> match t.type_value' with 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" | _ -> simple_fail "not an int"
let assert_t_nat : type_value -> unit result = fun t -> match t.type_value' with 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" | _ -> simple_fail "not an nat"
let assert_t_bool : type_value -> unit result = fun v -> get_t_bool v 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 assert_t_unit : type_value -> unit result = fun v -> get_t_unit v
let e_record map : expression = E_record map let e_record map : expression = E_record map
let ez_e_record (lst : (string * ae) list) : expression = let ez_e_record (lst : (label * ae) list) : expression =
let aux prev (k, v) = SMap.add k v prev in let aux prev (k, v) = LMap.add k v prev in
let map = List.fold_left aux SMap.empty lst in let map = List.fold_left aux LMap.empty lst in
e_record map e_record map
let e_some s : expression = E_constant ("SOME", [s]) let e_some s : expression = E_constant (C_SOME, [s])
let e_none : expression = E_constant ("NONE", []) let e_none : expression = E_constant (C_NONE, [])
let e_map lst : expression = E_map lst 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_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_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_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_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 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) ()) 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 get_declaration_by_name : program -> string -> declaration result = fun p name ->
let aux : declaration -> bool = fun declaration -> let aux : declaration -> bool = fun declaration ->
match declaration with match declaration with
| Declaration_constant (d , _) -> d.name = name | Declaration_constant (d , _) -> d.name = Var.of_name name
in in
trace_option (simple_error "no declaration with given name") @@ trace_option (simple_error "no declaration with given name") @@
List.find_opt aux @@ List.map Location.unwrap p 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 Trace
open Types open Types
open Stage_common.Types
val make_n_e : name -> annotated_expression -> named_expression val make_n_e : expression_variable -> annotated_expression -> named_expression
val make_n_t : name -> type_value -> named_type_value val make_n_t : expression_variable -> type_value -> named_type_value
val make_t : type_value' -> S.type_expression option -> 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 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_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_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_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_variable : type_variable -> ?s:S.type_expression -> unit -> type_value
val t_record : tv_map -> ?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 : (string * type_value) list -> 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 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_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_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 t_sum : type_value constructor_map -> ?s:S.type_expression -> unit -> type_value
val make_t_ez_sum : ( string * type_value ) list -> 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_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 t_shallow_closure : type_value -> type_value -> ?s:S.type_expression -> unit -> type_value
val get_type_annotation : annotated_expression -> 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_environment : annotated_expression -> full_environment
val get_expression : annotated_expression -> expression val get_expression : annotated_expression -> expression
val get_lambda : expression -> lambda result 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_bool : type_value -> unit result
(* (*
val get_t_int : 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_tuple : type_value -> type_value list result
val get_t_pair : type_value -> ( type_value * type_value ) 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_function : type_value -> ( type_value * type_value ) result
val get_t_sum : 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 SMap.t 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_map : type_value -> ( type_value * type_value ) result
val get_t_big_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 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_lambda : lambda -> expression
val e_pair : value -> value -> expression val e_pair : value -> value -> expression
val e_application : 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_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_tuple : value list -> expression
val e_a_unit : full_environment -> annotated_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_address : string -> full_environment -> annotated_expression
val e_a_pair : annotated_expression -> annotated_expression -> 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_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_none : type_value -> full_environment -> annotated_expression
val e_a_tuple : annotated_expression list -> 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_application : annotated_expression -> annotated_expression -> full_environment -> annotated_expression
val e_a_variable : name -> type_value -> full_environment -> annotated_expression val e_a_variable : expression_variable -> type_value -> full_environment -> annotated_expression
val ez_e_a_record : ( name * annotated_expression ) list -> 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_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_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_int : annotated_expression -> int result
val get_a_unit : annotated_expression -> unit result val get_a_unit : annotated_expression -> unit result
val get_a_bool : annotated_expression -> bool 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 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 open Environment
let env_sum_type ?(env = full_empty) let env_sum_type ?(env = full_empty)
?(name = "a_sum_type") ?(type_name = Var.of_name "a_sum_type")
(lst : (string * type_value) list) = (lst : (constructor * type_value) list) =
add_type name (make_t_ez_sum lst) env 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_some : annotated_expression -> annotated_expression
val e_a_empty_none : type_value -> 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_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_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 e_a_empty_list : annotated_expression list -> type_value -> annotated_expression
val ez_e_a_empty_record : ( name * annotated_expression ) list -> annotated_expression val ez_e_a_empty_record : ( label * annotated_expression ) list -> annotated_expression
val e_a_empty_lambda : lambda -> tv -> tv -> 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 simple-utils
tezos-utils tezos-utils
ast_simplified ; Is that a good idea? ast_simplified ; Is that a good idea?
stage_common
) )
(preprocess (preprocess
(pps ppx_let) (pps ppx_let)

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

@ -1,4 +1,5 @@
open Types open Types
open Stage_common.Types
open Combinators open Combinators
type element = environment_element 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_environment : _ -> t -> t = fun f (a , b) -> (f a , b)
let map_type_environment : _ -> t -> t = fun f (a , b) -> (a , f 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 : expression_variable -> 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 add_type : type_variable -> 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_opt : expression_variable -> 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 get_type_opt : type_variable -> t -> type_value option = fun k x -> List.assoc_opt k (get_type_environment x)
end end
type t = full_environment type t = full_environment
let empty : environment = Small.(get_environment empty) let empty : environment = Small.(get_environment empty)
let full_empty : t = List.Ne.singleton Small.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 : expression_variable -> 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_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 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 List.Ne.hd_map (Small.add k (make_element_declaration e ae)) e
let add_ez_ae = add_ez_declaration 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 add_type : type_variable -> 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_opt : expression_variable -> 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 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 x ->
let aux = fun (_type_name , x) -> let aux = fun (_type_name , x) ->
match x.type_value' with match x.type_value' with
| T_sum m -> | T_sum m ->
(match Map.String.find_opt k m with (match CMap.find_opt k m with
Some km -> Some (km , x) Some km -> Some (km , x)
| None -> None) | None -> None)
| _ -> None | _ -> None
@ -60,10 +61,10 @@ module PP = struct
let list_sep_scope x = list_sep x (const " | ") let list_sep_scope x = list_sep x (const " | ")
let environment_element = fun ppf (k , (ele : environment_element)) -> 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) -> 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 -> let environment : _ -> environment -> unit = fun ppf lst ->
fprintf ppf "E[%a]" (list_sep environment_element (const " , ")) lst fprintf ppf "E[%a]" (list_sep environment_element (const " , ")) lst
@ -83,9 +84,9 @@ end
open Trace 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 error =
let title () = "missing var not in env" in 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 error title content in
trace_option error @@ get_opt s env 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 t = full_environment
type element = environment_element type element = environment_element
val get_trace : string -> t -> element result val get_trace : expression_variable -> t -> element result
val empty : environment val empty : environment
val full_empty : t val full_empty : t
val add : string -> element -> t -> t val add : expression_variable -> element -> t -> t
val add_ez_binder : string -> type_value -> t -> t val add_ez_binder : expression_variable -> type_value -> t -> t
val add_ez_declaration : string -> annotated_expression -> t -> t val add_ez_declaration : expression_variable -> annotated_expression -> t -> t
val add_ez_ae : string -> annotated_expression -> t -> t val add_ez_ae : expression_variable -> annotated_expression -> t -> t
val add_type : string -> type_value -> t -> t val add_type : type_variable -> type_value -> t -> t
val get_opt : string -> t -> element option val get_opt : expression_variable -> t -> element option
val get_type_opt : string -> t -> type_value option val get_type_opt : type_variable -> t -> type_value option
val get_constructor : string -> t -> (type_value * type_value) option val get_constructor : constructor -> t -> (type_value * type_value) option
module Small : sig module Small : sig
type t = small_environment type t = small_environment

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

@ -12,11 +12,19 @@ module Errors = struct
error ~data title message () error ~data title message ()
let different_constants a b () = let different_constants a b () =
let title = (thunk "different constants") in let title = (thunk "different type constants") in
let message () = "" in let message () = "" in
let data = [ let data = [
("a" , fun () -> Format.asprintf "%s" a) ; ("a" , fun () -> Format.asprintf "%a" Stage_common.PP.type_constant a) ;
("b" , fun () -> Format.asprintf "%s" b ) ("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 ] in
error ~data title message () error ~data title message ()
@ -38,7 +46,7 @@ module Errors = struct
] in ] in
error ~data title message () 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" let different_size_tuples = different_size_type "tuples"
@ -146,13 +154,13 @@ end
module Free_variables = struct module Free_variables = struct
type bindings = string list type bindings = expression_variable list
let mem : string -> bindings -> bool = List.mem let mem : expression_variable -> bindings -> bool = List.mem
let singleton : string -> bindings = fun s -> [ s ] let singleton : expression_variable -> bindings = fun s -> [ s ]
let union : bindings -> bindings -> bindings = (@) let union : bindings -> bindings -> bindings = (@)
let unions : bindings list -> bindings = List.concat let unions : bindings list -> bindings = List.concat
let empty : bindings = [] 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 rec expression : bindings -> expression -> bindings = fun b e ->
let self = annotated_expression b in 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_application (a, b) -> unions @@ List.map self [ a ; b ]
| E_tuple lst -> unions @@ List.map self lst | E_tuple lst -> unions @@ List.map self lst
| E_constructor (_ , a) -> self a | 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_record_accessor (a, _) -> self a
| E_tuple_accessor (a, _) -> self a | E_tuple_accessor (a, _) -> self a
| E_list lst -> unions @@ List.map self lst | 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 -> and annotated_expression : bindings -> annotated_expression -> bindings = fun b ae ->
expression b ae.expression 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 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 m with
| Match_bool { match_true = t ; match_false = fa } -> union (f b t) (f b fa) | 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_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_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_tuple ((lst , a), _) ->
| Match_variant (lst , _) -> unions @@ List.map (matching_variant_case f b) lst 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 and matching_expression = fun x -> matching annotated_expression x
@ -288,6 +297,7 @@ end
open Errors open Errors
let rec assert_type_value_eq (a, b: (type_value * type_value)) : unit result = match (a.type_value', b.type_value') with 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 -> ( | T_tuple ta, T_tuple tb -> (
let%bind _ = 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) bind_list_iter assert_type_value_eq (List.combine ta tb)
) )
| T_tuple _, _ -> fail @@ different_kinds a b | T_tuple _, _ -> fail @@ different_kinds a b
| T_constant (Type_name ca, lsta), T_constant (Type_name cb, lstb) -> ( | T_constant ca, T_constant cb -> (
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) trace_strong (different_constants ca cb)
@@ Assert.assert_true (ca = cb) in @@ Assert.assert_true (ca = cb)
trace (different_types "constant sub-expression" a b)
@@ bind_list_iter assert_type_value_eq (List.combine lsta lstb)
) )
| T_constant _, _ -> fail @@ different_kinds a b | 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 -> ( | T_sum sa, T_sum sb -> (
let sa' = SMap.to_kv_list sa in let sa' = CMap.to_kv_list sa in
let sb' = SMap.to_kv_list sb in let sb' = CMap.to_kv_list sb in
let aux ((ka, va), (kb, vb)) = let aux ((ka, va), (kb, vb)) =
let%bind _ = let%bind _ =
Assert.assert_true ~msg:"different keys in sum types" 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_sum _, _ -> fail @@ different_kinds a b
| T_record ra, T_record rb -> ( | T_record ra, T_record rb -> (
let ra' = SMap.to_kv_list ra in let ra' = LMap.to_kv_list ra in
let rb' = SMap.to_kv_list rb in let rb' = LMap.to_kv_list rb in
let aux ((ka, va), (kb, vb)) = let aux ((ka, va), (kb, vb)) =
let%bind _ = let%bind _ =
trace (different_types "records" a b) @@ trace (different_types "records" a b) @@
let Label ka = ka in
let Label kb = kb in
trace_strong (different_props_in_record ka kb) @@ trace_strong (different_props_in_record ka kb) @@
Assert.assert_true (ka = kb) in Assert.assert_true (ka = kb) in
assert_type_value_eq (va, vb) 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_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 (param, param') in
let%bind _ = assert_type_value_eq (result, result') in let%bind _ = assert_type_value_eq (result, result') in
ok () 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 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 | 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 fail @@ different_values_because_different_types "tuple vs. non-tuple" a b
| E_record sma, E_record smb -> ( | E_record sma, E_record smb -> (
let aux k a b = let aux (Label k) a b =
match a, b with match a, b with
| Some a, Some b -> Some (assert_value_eq (a, b)) | Some a, Some b -> Some (assert_value_eq (a, b))
| _ -> Some (fail @@ missing_key_in_record_value k) | _ -> Some (fail @@ missing_key_in_record_value k)
in in
let%bind _all = bind_smap @@ SMap.merge aux sma smb in let%bind _all = bind_lmap @@ LMap.merge aux sma smb in
ok () ok ()
) )
| E_record _, _ -> | E_record _, _ ->
@ -508,7 +528,7 @@ let get_entry (lst : program) (name : string) : annotated_expression result =
trace_option (Errors.missing_entry_point name) @@ trace_option (Errors.missing_entry_point name) @@
let aux x = let aux x =
let (Declaration_constant (an , _)) = Location.unwrap x in let (Declaration_constant (an , _)) = Location.unwrap x in
if (an.name = name) if (an.name = Var.of_name name)
then Some an.annotated_expression then Some an.annotated_expression
else None else None
in 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 val type_value_eq : ( type_value * type_value ) -> bool
module Free_variables : sig module Free_variables : sig
type bindings = string list type bindings = expression_variable list
val matching_expression : bindings -> matching_expr -> bindings val matching_expression : bindings -> matching_expr -> bindings
val lambda : bindings -> lambda -> bindings val lambda : bindings -> lambda -> bindings
@ -19,7 +19,7 @@ module Free_variables : sig
val annotated_expression : bindings -> annotated_expression -> bindings val annotated_expression : bindings -> annotated_expression -> bindings
val empty : bindings val empty : bindings
val singleton : string -> bindings val singleton : expression_variable -> bindings
(* (*
val mem : string -> bindings -> bool val mem : string -> bindings -> bool

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

@ -2,12 +2,13 @@ open Trace
open Types open Types
open Combinators open Combinators
open Misc open Misc
open Stage_common.Types
let program_to_main : program -> string -> lambda result = fun p s -> let program_to_main : program -> string -> lambda result = fun p s ->
let%bind (main , input_type , _) = let%bind (main , input_type , _) =
let pred = fun d -> let pred = fun d ->
match d with 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 | Declaration_constant _ -> None
in in
let%bind main = 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 List.find_map (Function.compose pred Location.unwrap) p in
let%bind (input_ty , output_ty) = let%bind (input_ty , output_ty) =
match (get_type' @@ get_type_annotation main) with 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 | _ -> simple_fail "program main isn't a function" in
ok (main , input_ty , output_ty) ok (main , input_ty , output_ty)
in in
@ -24,10 +25,10 @@ let program_to_main : program -> string -> lambda result = fun p s ->
match d with match d with
| Declaration_constant (_ , (_ , post_env)) -> post_env in | Declaration_constant (_ , (_ , post_env)) -> post_env in
List.fold_left aux Environment.full_empty (List.map Location.unwrap p) 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 body =
let input_expr = e_a_variable binder input_type env in 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 e_a_application main_expr input_expr env in
ok { ok {
binder ; binder ;
@ -36,13 +37,13 @@ let program_to_main : program -> string -> lambda result = fun p s ->
module Captured_variables = struct module Captured_variables = struct
type bindings = string list type bindings = expression_variable list
let mem : string -> bindings -> bool = List.mem let mem : expression_variable -> bindings -> bool = List.mem
let singleton : string -> bindings = fun s -> [ s ] let singleton : expression_variable -> bindings = fun s -> [ s ]
let union : bindings -> bindings -> bindings = (@) let union : bindings -> bindings -> bindings = (@)
let unions : bindings list -> bindings = List.concat let unions : bindings list -> bindings = List.concat
let empty : bindings = [] 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 rec annotated_expression : bindings -> annotated_expression -> bindings result = fun b ae ->
let self = annotated_expression b in let self = annotated_expression b in
@ -68,7 +69,7 @@ module Captured_variables = struct
ok @@ unions lst' ok @@ unions lst'
| E_constructor (_ , a) -> self a | E_constructor (_ , a) -> self a
| E_record m -> | 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' ok @@ unions lst'
| E_record_accessor (a, _) -> self a | E_record_accessor (a, _) -> self a
| E_tuple_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 let b' = union (singleton li.binder) b in
annotated_expression b' li.result 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 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 m with
| Match_bool { match_true = t ; match_false = fa } -> | Match_bool { match_true = t ; match_false = fa } ->
let%bind t' = f b t in let%bind t' = f b t in
let%bind fa' = f b fa in let%bind fa' = f b fa in
ok @@ union t' fa' 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 n' = f b n in
let%bind c' = f (union (of_list [hd ; tl]) b) c in let%bind c' = f (union (of_list [hd ; tl]) b) c in
ok @@ union n' c' 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 n' = f b n in
let%bind s' = f (union (singleton opt) b) s in let%bind s' = f (union (singleton opt) b) s in
ok @@ union n' s' ok @@ union n' s'
| Match_tuple (lst , a) -> | Match_tuple ((lst , a),_) ->
f (union (of_list lst) b) a f (union (of_list lst) b) a
| Match_variant (lst , _) -> | Match_variant (lst , _) ->
let%bind lst' = bind_map_list (matching_variant_case f b) lst in 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 Trace
open Types open Types
open Stage_common.Types
val program_to_main : program -> string -> lambda result val program_to_main : program -> string -> lambda result
module Captured_variables : sig module Captured_variables : sig
type bindings = string list type bindings = expression_variable list
val matching : (bindings -> 'a -> bindings result) -> bindings -> 'a matching -> bindings result val matching : (bindings -> 'a -> bindings result) -> bindings -> ('a, type_value) matching -> bindings result
val matching_expression : bindings -> matching_expr -> 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 union : bindings -> bindings -> bindings
val unions : bindings list -> bindings val unions : bindings list -> bindings
val empty : 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 annotated_expression : bindings -> annotated_expression -> bindings result
val matching_variant_case : (bindings -> 'a -> bindings result) -> bindings -> ((constructor_name * name) * 'a) -> 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"] [@@@warning "-30"]
module S = Ast_simplified module S = Ast_simplified
include Stage_common.Types
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
type program = declaration Location.wrap list type program = declaration Location.wrap list
@ -21,45 +13,34 @@ and environment_element_definition =
| ED_binder | ED_binder
| ED_declaration of (annotated_expression * free_variables) | ED_declaration of (annotated_expression * free_variables)
and free_variables = name list and free_variables = expression_variable list
and environment_element = { and environment_element = {
type_value : type_value ; (* SUBST ??? *) type_value : type_value ;
source_environment : full_environment ; source_environment : full_environment ;
definition : environment_element_definition ; definition : environment_element_definition ;
} }
and environment = (string * environment_element) list and environment = (expression_variable * environment_element) list
and type_environment = (string * type_value) list (* SUBST ??? *) and type_environment = (type_variable * type_value) list (* SUBST ??? *)
and small_environment = (environment * type_environment) and small_environment = (environment * type_environment)
and full_environment = small_environment List.Ne.t and full_environment = small_environment List.Ne.t
and annotated_expression = { and annotated_expression = {
expression : expression ; expression : expression ;
type_annotation : tv ; (* SUBST *) type_annotation : type_value ; (* SUBST *)
environment : full_environment ; environment : full_environment ;
location : Location.t ; location : Location.t ;
} }
and named_expression = { and named_expression = {
name: name ; name: expression_variable ;
annotated_expression: ae ; annotated_expression: ae ;
} }
and tv = type_value
and ae = annotated_expression and ae = annotated_expression
and tv_map = type_value type_name_map and type_value' = type_value type_expression'
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 = { 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. *) 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 In mini_c, we need the type associated with `x` in the assignment
expression `x.y.z := 42`, so it is stored here. *) expression `x.y.z := 42`, so it is stored here. *)
and named_type_value = { and named_type_value = {
type_name: name ; type_name: expression_variable ;
type_value : type_value ; type_value : type_value ;
} }
(* E_lamba and other expressions are always wrapped as an annotated_expression. *) (* E_lamba and other expressions are always wrapped as an annotated_expression. *)
and lambda = { and lambda = {
binder : name ; binder : expression_variable ;
(* input_type: tv ; (* input_type: tv ;
* output_type: tv ; *) * output_type: tv ; *)
body : ae ; body : ae ;
} }
and let_in = { and let_in = {
binder: name; binder: expression_variable;
rhs: ae; rhs: ae;
result: ae; result: ae;
} }
and expression = and 'a expression' =
(* Base *) (* Base *)
| E_literal of literal | E_literal of literal
| E_constant of (name * ae list) (* For language constants, like (Cons hd tl) or (plus i j) *) | E_constant of (constant * ('a) list) (* For language constants, like (Cons hd tl) or (plus i j) *)
| E_variable of name | E_variable of expression_variable
| E_application of (ae * ae) | E_application of (('a) * ('a))
| E_lambda of lambda | E_lambda of lambda
| E_let_in of let_in | E_let_in of let_in
(* Tuple *) (* Tuple *)
| E_tuple of ae list | E_tuple of ('a) list
| E_tuple_accessor of (ae * int) (* Access n'th tuple's element *) | E_tuple_accessor of (('a) * int) (* Access n'th tuple's element *)
(* Sum *) (* Sum *)
| E_constructor of (name * ae) (* For user defined constructors *) | E_constructor of (constructor * ('a)) (* For user defined constructors *)
(* Record *) (* Record *)
| E_record of ae_map | E_record of ('a) label_map
| E_record_accessor of (ae * string) | E_record_accessor of (('a) * label)
(* Data Structures *) (* Data Structures *)
| E_map of (ae * ae) list | E_map of (('a) * ('a)) list
| E_big_map of (ae * ae) list | E_big_map of (('a) * ('a)) list
| E_list of ae list | E_list of ('a) list
| E_set of ae list | E_set of ('a) list
| E_look_up of (ae * ae) | E_look_up of (('a) * ('a))
(* Advanced *) (* Advanced *)
| E_matching of (ae * matching_expr) | E_matching of (('a) * matching_expr)
(* Replace Statements *) (* Replace Statements *)
| E_sequence of (ae * ae) | E_sequence of (('a) * ('a))
| E_loop of (ae * ae) | E_loop of (('a) * ('a))
| E_assign of (named_type_value * access_path * ae) | E_assign of (named_type_value * access_path * ('a))
and expression = ae expression'
and value = annotated_expression (* todo (for refactoring) *) and value = annotated_expression (* todo (for refactoring) *)
and literal = and matching_expr = (ae,type_value) matching
| 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

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 Simple_utils.PP_helpers
open Types open Types
open Format open Format
include Stage_common.PP
let list_sep_d x = list_sep x (const " , ") 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_bool -> fprintf ppf "bool"
| Base_int -> fprintf ppf "int" | Base_int -> fprintf ppf "int"
| Base_nat -> fprintf ppf "nat" | Base_nat -> fprintf ppf "nat"
| Base_tez -> fprintf ppf "tez" | Base_mutez -> fprintf ppf "tez"
| Base_string -> fprintf ppf "string" | Base_string -> fprintf ppf "string"
| Base_address -> fprintf ppf "address" | Base_address -> fprintf ppf "address"
| Base_timestamp -> fprintf ppf "timestamp" | Base_timestamp -> fprintf ppf "timestamp"
@ -25,24 +26,24 @@ let type_base ppf : type_base -> _ = function
| Base_key_hash -> fprintf ppf "key_hash" | Base_key_hash -> fprintf ppf "key_hash"
| Base_chain_id -> fprintf ppf "chain_id" | 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_or(a, b) -> fprintf ppf "(%a) | (%a)" annotated a annotated b
| T_pair(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_base b -> type_base ppf b
| T_function(a, b) -> fprintf ppf "(%a) -> (%a)" type_ a type_ b | T_function(a, b) -> fprintf ppf "(%a) -> (%a)" type_variable a type_variable b
| T_map(k, v) -> fprintf ppf "map(%a -> %a)" type_ k type_ v | 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_ k type_ 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_ t | T_list(t) -> fprintf ppf "list(%a)" type_variable t
| T_set(t) -> fprintf ppf "set(%a)" type_ t | T_set(t) -> fprintf ppf "set(%a)" type_variable t
| T_option(o) -> fprintf ppf "option(%a)" type_ o | T_option(o) -> fprintf ppf "option(%a)" type_variable o
| T_contract(t) -> fprintf ppf "contract(%a)" type_ t | T_contract(t) -> fprintf ppf "contract(%a)" type_variable t
and annotated ppf : type_value annotated -> _ = function and annotated ppf : type_value annotated -> _ = function
| (Some ann, a) -> fprintf ppf "(%a %%%s)" type_ a ann | (Some ann, a) -> fprintf ppf "(%a %%%s)" type_variable a ann
| (None, a) -> type_ ppf a | (None, a) -> type_variable ppf a
and environment_element ppf ((s, tv) : environment_element) = and environment_element ppf ((n, tv) : environment_element) =
Format.fprintf ppf "%a : %a" Var.pp s type_ tv Format.fprintf ppf "%a : %a" Stage_common.PP.name n type_variable tv
and environment ppf (x:environment) = and environment ppf (x:environment) =
fprintf ppf "Env[%a]" (list_sep_d environment_element) x 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 and expression' ppf (e:expression') = match e with
| E_skip -> fprintf ppf "skip" | E_skip -> fprintf ppf "skip"
| E_closure x -> fprintf ppf "C(%a)" function_ x | 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_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_literal v -> fprintf ppf "L(%a)" value v
| E_make_empty_map _ -> fprintf ppf "map[]" | E_make_empty_map _ -> fprintf ppf "map[]"
| E_make_empty_big_map _ -> fprintf ppf "big_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_empty_set _ -> fprintf ppf "set[]"
| E_make_none _ -> fprintf ppf "none" | 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_bool (c, a, b) -> fprintf ppf "%a ? %a : %a" expression c expression a expression b
| E_if_none (c, n, ((name, _) , s)) -> | E_if_none (c, n, ((name, _) , s)) -> fprintf ppf "%a ?? %a : %a -> %a" expression c expression n Stage_common.PP.name name expression s
fprintf ppf "%a ?? %a : %a -> %a" | 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
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_left (c, ((name_l, _) , l), ((name_r, _) , r)) -> | E_if_left (c, ((name_l, _) , l), ((name_r, _) , r)) ->
fprintf ppf "%a ?? %a -> %a : %a -> %a" 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
expression c Var.pp name_l expression l Var.pp name_r expression r
| E_sequence (a , b) -> fprintf ppf "%a ;; %a" expression a expression b | E_sequence (a , b) -> fprintf ppf "%a ;; %a" expression a expression b
| E_let_in ((name , _) , expr , body) -> | E_let_in ((name , _) , expr , body) ->
fprintf ppf "let %a = %a in ( %a )" 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 (s , ((name , _) , body) , expr) -> | E_iterator (b , ((name , _) , body) , expr) ->
fprintf ppf "for_%s %a of %a do ( %a )" s Var.pp name expression expr expression body 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) -> | E_fold (((name , _) , body) , collection , initial) ->
fprintf ppf "fold %a on %a with %a do ( %a )" fprintf ppf "fold %a on %a with %a do ( %a )" expression collection expression initial Stage_common.PP.name name expression body
expression collection expression initial Var.pp name expression body
| E_assignment (r , path , e) -> | 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) -> | E_while (e , b) ->
fprintf ppf "while (%a) %a" expression e expression 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 -> and expression_with_type : _ -> expression -> _ = fun ppf e ->
fprintf ppf "%a : %a" fprintf ppf "%a : %a"
expression' e.content expression' e.content
type_ e.type_value type_variable e.type_value
and function_ ppf ({binder ; body}:anon_function) = and function_ ppf ({binder ; body}:anon_function) =
fprintf ppf "fun %a -> (%a)" fprintf ppf "fun %a -> (%a)"
Var.pp binder Stage_common.PP.name binder
expression body 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 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_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_element : formatter -> environment_element -> unit
val environment : formatter -> environment -> unit val environment : formatter -> environment -> unit
val value : formatter -> value -> 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 ; 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 end
@ -136,7 +136,7 @@ let get_or (v:value) = match v with
let wrong_type name t = let wrong_type name t =
let title () = "not a " ^ name in 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 error title content
let get_t_left t = match t with 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_unit : Expression.t
val e_skip : Expression.t val e_skip : Expression.t
val e_var_int : Var.t -> Expression.t val e_var_int : expression_variable -> Expression.t
val e_let_in : Var.t -> type_value -> Expression.t -> Expression.t -> 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 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 (libraries
simple-utils simple-utils
tezos-utils tezos-utils
stage_common
) )
(inline_tests) (inline_tests)
(preprocess (pps ppx_expect ppx_let)) (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 empty : t = []
let add : element -> t -> t = List.cons let add : element -> t -> t = List.cons
let concat : t list -> t = List.concat let concat : t list -> t = List.concat
let get_opt : Var.t -> t -> type_value option = List.assoc_opt ~compare:Var.compare let get_opt : expression_variable -> t -> type_value option = List.assoc_opt ~compare:Var.compare
let has : Var.t -> t -> bool = fun s t -> let has : expression_variable -> t -> bool = fun s t ->
match get_opt s t with match get_opt s t with
| None -> false | None -> false
| Some _ -> true | 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 of_list : element list -> t = fun x -> x
let to_list : t -> element list = 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 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 =
let e_lst = to_list env in let e_lst = to_list env in
let aux selector (s , _) = 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 get_opt : Var.t -> t -> type_value option
val has : Var.t -> t -> bool 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 of_list : element list -> t
val to_list : t -> element list 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 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 fold : ('a -> element -> 'a ) -> 'a -> t -> 'a
val filter : ( element -> bool ) -> t -> t 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 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) 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 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 fold : ('a -> element -> 'a ) -> 'a -> t -> 'a
val filter : ( element -> bool ) -> t -> t val filter : ( element -> bool ) -> t -> t

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

@ -24,16 +24,16 @@ end
module Free_variables = struct module Free_variables = struct
type bindings = Var.t list type bindings = expression_variable list
let mem : Var.t -> bindings -> bool = List.memq ~eq:Var.equal let mem : expression_variable -> bindings -> bool = List.mem
let mem_count : Var.t -> bindings -> int = let singleton : expression_variable -> bindings = fun s -> [ s ]
let mem_count : expression_variable -> bindings -> int =
fun x fvs -> fun x fvs ->
List.length (List.filter (Var.equal x) fvs) List.length (List.filter (Var.equal x) fvs)
let singleton : Var.t -> bindings = fun s -> [ s ]
let union : bindings -> bindings -> bindings = (@) let union : bindings -> bindings -> bindings = (@)
let unions : bindings list -> bindings = List.concat let unions : bindings list -> bindings = List.concat
let empty : bindings = [] 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 rec expression : bindings -> expression -> bindings = fun b e ->
let self = expression b in 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 type 'a annotated = string option * 'a
@ -23,7 +15,7 @@ type type_value =
| T_contract of type_value | T_contract of type_value
| T_option 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 and environment = environment_element list
@ -32,8 +24,8 @@ type environment_wrap = {
post_environment : environment ; post_environment : environment ;
} }
type var_name = Var.t type var_name = expression_variable
type fun_name = Var.t type fun_name = expression_variable
type value = type value =
| D_unit | D_unit
@ -62,7 +54,7 @@ and expression' =
| E_literal of value | E_literal of value
| E_closure of anon_function | E_closure of anon_function
| E_skip | E_skip
| E_constant of string * expression list | E_constant of constant * expression list
| E_application of (expression * expression) | E_application of (expression * expression)
| E_variable of var_name | E_variable of var_name
| E_make_empty_map of (type_value * type_value) | 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_list of type_value
| E_make_empty_set of type_value | E_make_empty_set of type_value
| E_make_none 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_fold of (((var_name * type_value) * expression) * expression * expression)
| E_if_bool of (expression * expression * expression) | E_if_bool of (expression * expression * expression)
| E_if_none of expression * expression * ((var_name * type_value) * 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_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_let_in of ((var_name * type_value) * expression * expression)
| E_sequence of (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) | E_while of (expression * expression)
and expression = { and expression = {
@ -91,7 +83,7 @@ and assignment = var_name * expression
and toplevel_statement = assignment * environment_wrap and toplevel_statement = assignment * environment_wrap
and anon_function = { and anon_function = {
binder : var_name ; binder : expression_variable ;
body : expression ; 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 *) (* generate a new type variable and gave it an id *)
let fresh_type_variable : ?name:string -> unit -> type_variable = let fresh_type_variable : ?name:string -> unit -> type_variable =
let id = ref 0 in Var.fresh
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)
(* add information on the type or the kind for operator*) (* add information on the type or the kind for operator*)
@ -26,7 +21,7 @@ type constant_tag =
| C_bool (* * *) | C_bool (* * *)
| C_string (* * *) | C_string (* * *)
| C_nat (* * *) | C_nat (* * *)
| C_tez (* * *) | C_mutez (* * *)
| C_timestamp (* * *) | C_timestamp (* * *)
| C_int (* * *) | C_int (* * *)
| C_address (* * *) | C_address (* * *)
@ -37,7 +32,7 @@ type constant_tag =
| C_operation (* * *) | C_operation (* * *)
| C_contract (* * -> * *) | C_contract (* * -> * *)
type label = type accessor =
| L_int of int | L_int of int
| L_string of string | 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_const = (type_variable * type_value)
and c_equation = (type_value * type_value) and c_equation = (type_value * type_value)
and c_typeclass = (type_value list * typeclass) 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 *) (*What i was saying just before *)
and type_constraint = and type_constraint =

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

@ -8,7 +8,7 @@ module Substitution = struct
open Trace open Trace
module T = Ast_typed module T = Ast_typed
module TSMap = Trace.TMap(String) (* module TSMap = Trace.TMap(String) *)
type 'a w = 'a -> 'a result type 'a w = 'a -> 'a result
@ -17,17 +17,15 @@ module Substitution = struct
| T.ED_binder -> ok @@ T.ED_binder | T.ED_binder -> ok @@ T.ED_binder
| T.ED_declaration (val_, free_variables) -> | T.ED_declaration (val_, free_variables) ->
let%bind val_ = s_annotated_expression ~v ~expr val_ in 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) ok @@ T.ED_declaration (val_, free_variables)
and s_environment ~v ~expr = fun lst -> and s_environment ~v ~expr : T.environment w = fun env ->
bind_map_list (fun (type_variable, T.{ type_value; source_environment; definition }) -> bind_map_list (fun (variable, T.{ type_value; source_environment; definition }) ->
let _ = type_value in let%bind variable = s_variable ~v ~expr variable in
let%bind type_variable = s_type_variable ~v ~expr type_variable in
let%bind type_value = s_type_value ~v ~expr type_value 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 source_environment = s_full_environment ~v ~expr source_environment in
let%bind definition = s_environment_element_definition ~v ~expr definition in let%bind definition = s_environment_element_definition ~v ~expr definition in
ok @@ (type_variable, T.{ type_value; source_environment; definition }) ok @@ (variable, T.{ type_value; source_environment; definition })) env
) lst
and s_type_environment ~v ~expr : T.type_environment w = fun tenv -> and s_type_environment ~v ~expr : T.type_environment w = fun tenv ->
bind_map_list (fun (type_variable , type_value) -> bind_map_list (fun (type_variable , type_value) ->
let%bind type_variable = s_type_variable ~v ~expr type_variable in 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 let%bind b = bind_map_list (s_small_environment ~v ~expr) b in
ok (a , b) 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 let () = ignore (v, expr) in
ok var 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 let _TODO = ignore (v, expr) in
Printf.printf "TODO: subst: unimplemented case s_type_variable"; Printf.printf "TODO: subst: unimplemented case s_type_variable";
ok @@ tvar ok @@ tvar
@ -54,8 +52,19 @@ module Substitution = struct
* expr * expr
* else * else
* ok tvar *) * 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? *) (* TODO: we don't need to subst anything, right? *)
let () = ignore (v , expr) in let () = ignore (v , expr) in
ok @@ type_name ok @@ type_name
@ -66,22 +75,24 @@ module Substitution = struct
ok @@ T.T_tuple type_value_list ok @@ T.T_tuple type_value_list
| T.T_sum _ -> failwith "TODO: T_sum" | T.T_sum _ -> failwith "TODO: T_sum"
| T.T_record _ -> failwith "TODO: T_record" | 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_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)
ok @@ T.T_constant (type_name, type_value_list)
| T.T_variable _ -> failwith "TODO: T_variable" | 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 let _TODO = (v, expr) in
failwith "TODO: T_function" failwith "TODO: T_function"
and s_type_expression ~v ~expr : Ast_simplified.type_expression w = function 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_tuple _ -> failwith "TODO: subst: unimplemented case s_type_expression"
| Ast_simplified.T_sum _ -> 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_record _ -> failwith "TODO: subst: unimplemented case s_type_expression"
| Ast_simplified.T_function (_, _) -> 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_variable _ -> failwith "TODO: subst: unimplemented case s_type_expression"
| Ast_simplified.T_constant (_, _) -> | Ast_simplified.T_operator _ -> failwith "TODO: subst: unimplemented case s_type_expression"
| Ast_simplified.T_constant _ ->
let _TODO = (v, expr) in let _TODO = (v, expr) in
failwith "TODO: subst: unimplemented case s_type_expression" failwith "TODO: subst: unimplemented case s_type_expression"
@ -122,7 +133,7 @@ module Substitution = struct
let%bind x = s_literal ~v ~expr x in let%bind x = s_literal ~v ~expr x in
ok @@ T.E_literal x ok @@ T.E_literal x
| T.E_constant (var, vals) -> | 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 let%bind vals = bind_map_list (s_annotated_expression ~v ~expr) vals in
ok @@ T.E_constant (var, vals) ok @@ T.E_constant (var, vals)
| T.E_variable tv -> | T.E_variable tv ->
@ -149,7 +160,7 @@ module Substitution = struct
let i = i in let i = i in
ok @@ T.E_tuple_accessor (val_, i) ok @@ T.E_tuple_accessor (val_, i)
| T.E_constructor (tvar, val_) -> | 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 let%bind val_ = s_annotated_expression ~v ~expr val_ in
ok @@ T.E_constructor (tvar, val_) ok @@ T.E_constructor (tvar, val_)
| T.E_record aemap -> | T.E_record aemap ->
@ -160,10 +171,10 @@ module Substitution = struct
* let val_ = s_annotated_expression ~v ~expr val_ in * let val_ = s_annotated_expression ~v ~expr val_ in
* ok @@ (key , val_)) aemap in * ok @@ (key , val_)) aemap in
* ok @@ T.E_record aemap *) * 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 val_ = s_annotated_expression ~v ~expr val_ in
let%bind tvar = s_type_variable ~v ~expr tvar in let%bind l = s_label ~v ~expr l in
ok @@ T.E_record_accessor (val_, tvar) ok @@ T.E_record_accessor (val_, l)
| T.E_map val_val_list -> | T.E_map val_val_list ->
let%bind val_val_list = bind_map_list (fun (val1 , val2) -> let%bind val_val_list = bind_map_list (fun (val1 , val2) ->
let%bind val1 = s_annotated_expression ~v ~expr val1 in let%bind val1 = s_annotated_expression ~v ~expr val1 in
@ -214,7 +225,7 @@ module Substitution = struct
ok T.{ expression; type_annotation; environment; location } ok T.{ expression; type_annotation; environment; location }
and s_named_expression ~v ~expr : T.named_expression w = fun { name; annotated_expression } -> 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 let%bind annotated_expression = s_annotated_expression ~v ~expr annotated_expression in
ok T.{ name; annotated_expression } ok T.{ name; annotated_expression }
@ -231,7 +242,7 @@ module Substitution = struct
(* Replace the type variable ~v with ~expr everywhere within the (* Replace the type variable ~v with ~expr everywhere within the
program ~p. TODO: issues with scoping/shadowing. *) 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 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 bool = P_constant (C_bool , [])
let string = P_constant (C_string , []) let string = P_constant (C_string , [])
let nat = P_constant (C_nat , []) 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 timestamp = P_constant (C_timestamp , [])
let int = P_constant (C_int , []) let int = P_constant (C_int , [])
let address = P_constant (C_address , []) 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 = let empty_op_list =
(e_typed_list [] t_operation) (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)) (Some t_unit) (Some (t_list t_operation))
empty_op_list empty_op_list
let chain_id_zero = e_chain_id @@ Tezos_crypto.Base58.simple_encode 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 = let empty_op_list =
(e_typed_list [] t_operation) (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)) (Some t_bytes) (Some (t_list t_operation))
empty_op_list 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)) (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 send_param msg = e_constructor "Send" msg
let withdraw_param = e_constructor "Withdraw" empty_message 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) let test_expression ?(env = Typer.Environment.full_empty)
?(state = Typer.Solver.initial_state) ?(state = Typer.Solver.initial_state)
(expr : expression) (expr : expression)
(test_expected_ty : Typed.tv) = (test_expected_ty : Typed.type_value) =
let pre = expr in let pre = expr in
let open Typer in let open Typer in
let open! Typed in let open! Typed in
@ -46,7 +46,7 @@ module TestExpressions = struct
let lambda () : unit result = let lambda () : unit result =
test_expression 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 ()) ()) O.(t_function (t_int ()) (t_int ()) ())
let tuple () : unit result = let tuple () : unit result =
@ -56,7 +56,7 @@ module TestExpressions = struct
let constructor () : unit result = let constructor () : unit result =
let variant_foo_bar = let variant_foo_bar =
O.[("foo", t_int ()); ("bar", t_string ())] O.[(Constructor "foo", t_int ()); (Constructor "bar", t_string ())]
in test_expression in test_expression
~env:(E.env_sum_type variant_foo_bar) ~env:(E.env_sum_type variant_foo_bar)
I.(e_constructor "foo" (e_int 32)) I.(e_constructor "foo" (e_int 32))
@ -65,7 +65,8 @@ module TestExpressions = struct
let record () : unit result = let record () : unit result =
test_expression test_expression
I.(ez_e_record [("foo", e_int 32); ("bar", e_string "foo")]) 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 end
(* TODO: deep types (e.g. record of record) (* 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 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_pair result in
let%bind storage' = extract_record storage 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 votes' = extract_map votes in
let%bind (_ , yess) = let%bind (_ , yess) =
trace_option (simple_error "") @@ 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 ; name : string ;
counter : int option ; counter : int option ;
} }
@ -30,6 +30,16 @@ let of_name name =
counter = None 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 fresh ?name () =
let name = Option.unopt ~default:"" name in let name = Option.unopt ~default:"" name in
let counter = incr global_counter ; Some !global_counter 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 does not accept names like "foo#121" as possible variable names, so
this confusion should not arise for us. *) this confusion should not arise for us. *)
type t type 'a t
val equal : t -> t -> bool val equal : 'a t -> 'a t -> bool
val compare : t -> t -> int val compare : 'a t -> 'a t -> int
(* Prints vars as %s or %s#%d *) (* 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 (* Construct a user variable directly from a string. This should only
be used for embedding user variable names. For programmatically be used for embedding user variable names. For programmatically
generated variables, use `fresh`. Take care not to cause generated variables, use `fresh`. Take care not to cause
shadowing/capture except as the user intended. *) 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_ (* Generate a variable, using a counter value from a _global_
counter. If the name is not provided, it will be empty. *) 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 (* Generate a variable as with `fresh`, reusing the name part of the
given variable. *) 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 (* Reset the global counter. Danger, do not use... Provided for tests
only. *) only. *)