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

errorm messages for the transpiler

Browse Source
This commit is contained in:
Galfour 2019-06-04 08:21:13 +00:00
parent c2643f5b4c
commit 388c5e6a09
4 changed files with 227 additions and 98 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/main/run_source.ml
View File

@ -51,7 +51,7 @@ let transpile_value
let%bind f = let%bind f =
let open Transpiler in let open Transpiler in
let (f , _) = functionalize e in let (f , _) = functionalize e in
let%bind main = translate_main f in let%bind main = translate_main f e.location in
ok main ok main
in in

2
src/main/run_typed.ml
View File

@ -5,7 +5,7 @@ let transpile_value
let%bind f = let%bind f =
let open Transpiler in let open Transpiler in
let (f , _) = functionalize e in let (f , _) = functionalize e in
let%bind main = translate_main f in let%bind main = translate_main f e.location in
ok main ok main
in in

9
src/simplify/ligodity.ml
View File

@ -79,7 +79,7 @@ let rec simpl_type_expression : Raw.type_expr -> type_expression result = fun te
in in
ok @@ T_function (a , b) ok @@ T_function (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 = let%bind cst =
@ -88,10 +88,11 @@ let rec simpl_type_expression : Raw.type_expr -> type_expression result = fun te
in 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') ok @@ T_constant (cst , lst')
| TProd p -> )
let%bind tpl = simpl_list_type_expression | TProd p -> (
@@ npseq_to_list p.value in let%bind tpl = simpl_list_type_expression @@ npseq_to_list p.value in
ok tpl ok tpl
)
| TRecord r -> | TRecord r ->
let aux = fun (x, y) -> let%bind y = simpl_type_expression y in ok (x, y) in let aux = fun (x, y) -> let%bind y = simpl_type_expression y in ok (x, y) in
let%bind lst = let%bind lst =

298
src/transpiler/transpiler.ml
View File

@ -15,7 +15,78 @@ let map_of_kv_list lst =
let open AST.SMap in let open AST.SMap 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
module Errors = struct
let corner_case ~loc message =
let title () = "corner case" in
let content () = "we don't have a good error message for this case. we are
striving find ways to better report them and find the use-cases that generate
them. please report this to the developers." in
let data = [
("location" , fun () -> loc) ;
("message" , fun () -> message) ;
] in
error ~data title content
let unrecognized_type_constant name =
let title () = "unrecognized type constant" in
let content () = name in
error title content
let unsupported_pattern_matching kind location =
let title () = "unsupported pattern-matching" in
let content () = Format.asprintf "%s patterns aren't supported yet" kind in
let data = [
("location" , fun () -> Format.asprintf "%a" Location.pp location) ;
] in
error ~data title content
let not_functional_main location =
let title () = "not functional main" in
let content () = "main should be a function" in
let data = [
("location" , fun () -> Format.asprintf "%a" Location.pp location) ;
] in
error ~data title content
let missing_entry_point name =
let title () = "missing entry point" in
let content () = "no entry point with the given name" in
let data = [
("name" , fun () -> name) ;
] in
error ~data title content
let wrong_mini_c_value expected_type actual =
let title () = "illed typed intermediary value" in
let content () = "type of intermediary value doesn't match what was expected" in
let data = [
("expected_type" , fun () -> expected_type) ;
("actual" , fun () -> Format.asprintf "%a" Mini_c.PP.value actual ) ;
] in
error ~data title content
let bad_untranspile bad_type value =
let title () = "untranspiling bad value" in
let content () = Format.asprintf "can not untranspile %s" bad_type in
let data = [
("bad_type" , fun () -> bad_type) ;
("value" , fun () -> Format.asprintf "%a" Mini_c.PP.value value) ;
] in
error ~data title content
let unknown_untranspile unknown_type value =
let title () = "untranspiling unknown value" in
let content () = Format.asprintf "can not untranspile %s" unknown_type in
let data = [
("unknown_type" , fun () -> unknown_type) ;
("value" , fun () -> Format.asprintf "%a" Mini_c.PP.value value) ;
] in
error ~data title content
end
open Errors
let rec translate_type (t:AST.type_value) : type_value result = let rec translate_type (t:AST.type_value) : type_value result =
trace (simple_info "") @@
match t.type_value' with match t.type_value' with
| T_constant ("bool", []) -> ok (T_base Base_bool) | T_constant ("bool", []) -> ok (T_base Base_bool)
| T_constant ("int", []) -> ok (T_base Base_int) | T_constant ("int", []) -> ok (T_base Base_int)
@ -37,12 +108,7 @@ let rec translate_type (t:AST.type_value) : type_value result =
| T_constant ("option", [o]) -> | T_constant ("option", [o]) ->
let%bind o' = translate_type o in let%bind o' = translate_type o in
ok (T_option o') ok (T_option o')
| T_constant (name , lst) -> | T_constant (name , _lst) -> fail @@ unrecognized_type_constant name
let error =
let title () = "unrecognized type constant" in
let content () = Format.asprintf "%s (%d)" name (List.length lst) in
error title content in
fail error
| T_sum m -> | T_sum m ->
let node = Append_tree.of_list @@ list_of_map m in let node = Append_tree.of_list @@ list_of_map m in
let aux a b : type_value result = let aux a b : type_value result =
@ -163,8 +229,12 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
let%bind tv = translate_type ae.type_annotation in let%bind tv = translate_type ae.type_annotation in
let return ?(tv = tv) expr = ok @@ Combinators.Expression.make_tpl (expr, tv) in let return ?(tv = tv) expr = ok @@ Combinators.Expression.make_tpl (expr, tv) in
let f = translate_annotated_expression in let f = translate_annotated_expression in
let info =
let title () = "translating expression" in
let content () = Format.asprintf "%a" Location.pp ae.location in
info title content in
trace info @@
match ae.expression with match ae.expression with
(* Optimise immediate application as a let-in *)
| E_let_in {binder; rhs; result} -> | E_let_in {binder; rhs; result} ->
let%bind rhs' = translate_annotated_expression rhs in let%bind rhs' = translate_annotated_expression rhs in
let%bind result' = translate_annotated_expression result in let%bind result' = translate_annotated_expression result in
@ -185,14 +255,16 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
let%bind a = translate_annotated_expression a in let%bind a = translate_annotated_expression a in
let%bind b = translate_annotated_expression b in let%bind b = translate_annotated_expression b in
return @@ E_application (a, b) return @@ E_application (a, b)
| E_constructor (m, param) -> | E_constructor (m, param) -> (
let%bind param' = translate_annotated_expression param in let%bind param' = translate_annotated_expression param in
let (param'_expr , param'_tv) = Combinators.Expression.(get_content param' , get_type param') in let (param'_expr , param'_tv) = Combinators.Expression.(get_content param' , get_type param') in
let%bind node_tv = tree_of_sum ae.type_annotation in let%bind node_tv =
trace_strong (corner_case ~loc:__LOC__ "getting lr tree") @@
tree_of_sum ae.type_annotation in
let leaf (k, tv) : (expression' option * type_value) result = let leaf (k, tv) : (expression' option * type_value) result =
if k = m then ( if k = m then (
let%bind _ = let%bind _ =
trace (simple_error "constructor parameter doesn't have expected type (shouldn't happen here)") trace_strong (corner_case ~loc:__LOC__ "wrong type for constructor parameter")
@@ AST.assert_type_value_eq (tv, param.type_annotation) in @@ AST.assert_type_value_eq (tv, param.type_annotation) in
ok (Some (param'_expr), param'_tv) ok (Some (param'_expr), param'_tv)
) else ( ) else (
@ -204,16 +276,17 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
let%bind b = b in let%bind b = b in
match (a, b) with match (a, b) with
| (None, a), (None, b) -> ok (None, T_or (a, b)) | (None, a), (None, b) -> ok (None, T_or (a, b))
| (Some _, _), (Some _, _) -> simple_fail "several identical constructors in the same variant (shouldn't happen here)" | (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 (a, b)) | (Some v, a), (None, b) -> ok (Some (E_constant ("LEFT", [Combinators.Expression.make_tpl (v, a)])), T_or (a, b))
| (None, a), (Some v, b) -> ok (Some (E_constant ("RIGHT", [Combinators.Expression.make_tpl (v, b)])), T_or (a, b)) | (None, a), (Some v, b) -> ok (Some (E_constant ("RIGHT", [Combinators.Expression.make_tpl (v, b)])), T_or (a, 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 =
trace_option (simple_error "constructor doesn't exist in claimed type (shouldn't happen here)") trace_option (corner_case ~loc:__LOC__ "inexistant constructor")
ae_opt in ae_opt in
return ~tv ae return ~tv ae
| E_tuple lst -> )
| E_tuple lst -> (
let node = Append_tree.of_list lst in let node = Append_tree.of_list lst in
let aux (a:expression result) (b:expression result) : expression result = let aux (a:expression result) (b:expression result) : expression result =
let%bind a = a in let%bind a = a in
@ -224,11 +297,16 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
return ~tv @@ E_constant ("PAIR", [a; b]) return ~tv @@ E_constant ("PAIR", [a; b])
in in
Append_tree.fold_ne (translate_annotated_expression) aux node Append_tree.fold_ne (translate_annotated_expression) aux node
| E_tuple_accessor (tpl, ind) -> )
| E_tuple_accessor (tpl, ind) -> (
let%bind ty' = translate_type tpl.type_annotation in let%bind ty' = translate_type tpl.type_annotation in
let%bind ty_lst = get_t_tuple tpl.type_annotation in let%bind ty_lst =
trace_strong (corner_case ~loc:__LOC__ "not a tuple") @@
get_t_tuple tpl.type_annotation in
let%bind ty'_lst = bind_map_list translate_type ty_lst in let%bind ty'_lst = bind_map_list translate_type ty_lst in
let%bind path = tuple_access_to_lr ty' ty'_lst ind in let%bind path =
trace_strong (corner_case ~loc:__LOC__ "tuple access") @@
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 -> "CAR"
@ -237,7 +315,8 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
let%bind tpl' = translate_annotated_expression tpl in let%bind tpl' = translate_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_map m in
let aux a b : expression result = let aux a b : expression result =
let%bind a = a in let%bind a = a in
@ -247,12 +326,18 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
let tv = T_pair (a_ty , b_ty) in let tv = T_pair (a_ty , b_ty) in
return ~tv @@ E_constant ("PAIR", [a; b]) return ~tv @@ E_constant ("PAIR", [a; b])
in in
trace_strong (corner_case ~loc:__LOC__ "record build") @@
Append_tree.fold_ne (translate_annotated_expression) aux node Append_tree.fold_ne (translate_annotated_expression) aux node
)
| E_record_accessor (record, property) -> | E_record_accessor (record, property) ->
let%bind ty' = translate_type (get_type_annotation record) in let%bind ty' = translate_type (get_type_annotation record) in
let%bind ty_smap = get_t_record (get_type_annotation record) in let%bind ty_smap =
trace_strong (corner_case ~loc:__LOC__ "not a record") @@
get_t_record (get_type_annotation record) in
let%bind ty'_smap = bind_map_smap translate_type ty_smap in let%bind ty'_smap = bind_map_smap translate_type ty_smap in
let%bind path = record_access_to_lr ty' ty'_smap property in let%bind path =
trace_strong (corner_case ~loc:__LOC__ "record access") @@
record_access_to_lr ty' ty'_smap 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 -> "CAR"
@ -261,38 +346,49 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
let%bind record' = translate_annotated_expression record in let%bind record' = translate_annotated_expression record in
let expr = List.fold_left aux record' path in let expr = List.fold_left aux record' path in
ok expr ok expr
| E_constant (name, lst) -> | E_constant (name, lst) -> (
let%bind lst' = bind_list @@ List.map (translate_annotated_expression) lst in ( let%bind lst' = bind_map_list (translate_annotated_expression) lst in
match name, lst with match name, lst with
| "NONE", [] -> | "NONE", [] ->
let%bind o = Mini_c.Combinators.get_t_option tv in let%bind o =
trace_strong (corner_case ~loc:__LOC__ "not an option") @@
Mini_c.Combinators.get_t_option tv in
return @@ E_make_none o return @@ E_make_none o
| _ -> return @@ E_constant (name, lst') | _ -> return @@ E_constant (name, lst')
) )
| E_lambda l -> | E_lambda l ->
let%bind env = transpile_environment ae.environment in let%bind env =
trace_strong (corner_case ~loc:__LOC__ "environment") @@
transpile_environment ae.environment in
translate_lambda env l translate_lambda env l
| E_list lst -> | E_list lst -> (
let%bind t = Mini_c.Combinators.get_t_list tv in let%bind t =
trace_strong (corner_case ~loc:__LOC__ "not a list") @@
Mini_c.Combinators.get_t_list tv in
let%bind lst' = bind_map_list (translate_annotated_expression) lst in let%bind lst' = bind_map_list (translate_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 ("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_list aux init lst' bind_fold_list aux init lst'
| E_map m -> )
let%bind (src, dst) = Mini_c.Combinators.get_t_map tv in | E_map m -> (
let%bind (src, dst) =
trace_strong (corner_case ~loc:__LOC__ "not a map") @@
Mini_c.Combinators.get_t_map tv in
let aux : expression result -> (AST.ae * AST.ae) -> expression result = fun prev (k, v) -> let aux : expression result -> (AST.ae * AST.ae) -> expression result = fun prev (k, v) ->
let%bind prev' = prev in let%bind prev' = prev in
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 (translate_annotated_expression) (k, v') in bind_map_pair (translate_annotated_expression) (k , v') in
return @@ E_constant ("UPDATE", [k' ; v' ; prev']) return @@ E_constant ("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
| 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 ("MAP_GET", [i' ; ds'])
)
| E_sequence (a , b) -> ( | E_sequence (a , b) -> (
let%bind a' = translate_annotated_expression a in let%bind a' = translate_annotated_expression a in
let%bind b' = translate_annotated_expression b in let%bind b' = translate_annotated_expression b in
@ -309,27 +405,25 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
fun (prev, acc) cur -> fun (prev, acc) cur ->
let%bind ty' = translate_type prev in let%bind ty' = translate_type prev in
match cur with match cur with
| Access_tuple ind -> | Access_tuple ind -> (
let%bind ty_lst = AST.Combinators.get_t_tuple prev in let%bind ty_lst =
trace_strong (corner_case ~loc:__LOC__ "not a tuple") @@
AST.Combinators.get_t_tuple prev in
let%bind ty'_lst = bind_map_list translate_type ty_lst in let%bind ty'_lst = bind_map_list translate_type ty_lst in
let%bind path = tuple_access_to_lr ty' ty'_lst ind in let%bind path = tuple_access_to_lr ty' ty'_lst ind in
let path' = List.map snd path in let path' = List.map snd path in
ok (List.nth ty_lst ind, acc @ path') ok (List.nth ty_lst ind, acc @ path')
| Access_record prop -> )
| Access_record prop -> (
let%bind ty_map = let%bind ty_map =
let error = trace_strong (corner_case ~loc:__LOC__ "not a record") @@
let title () = "accessing property on not a record" in
let content () = Format.asprintf "%s on %a in %a"
prop Ast_typed.PP.type_value prev Ast_typed.PP.annotated_expression expr in
error title content
in
trace error @@
AST.Combinators.get_t_record prev in AST.Combinators.get_t_record prev in
let%bind ty'_map = bind_map_smap translate_type ty_map in let%bind ty'_map = bind_map_smap translate_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
ok (Map.String.find prop ty_map, acc @ path') ok (Map.String.find prop ty_map, acc @ path')
| Access_map _k -> simple_fail "no patch for map yet" )
| Access_map _k -> fail (corner_case ~loc:__LOC__ "no patch for map yet")
in in
let%bind (_, path) = bind_fold_right_list aux (ty, []) path in let%bind (_, path) = bind_fold_right_list aux (ty, []) path in
let%bind expr' = translate_annotated_expression expr in let%bind expr' = translate_annotated_expression expr in
@ -349,9 +443,11 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
ok (tv' , s') in ok (tv' , s') in
return @@ E_if_none (expr' , n , ((name , tv') , s')) return @@ E_if_none (expr' , n , ((name , tv') , s'))
| Match_variant (lst , variant) -> ( | Match_variant (lst , variant) -> (
let%bind tree = tree_of_sum variant in let%bind tree =
trace_strong (corner_case ~loc:__LOC__ "getting lr tree") @@
tree_of_sum variant in
let%bind tree' = match tree with let%bind tree' = match tree with
| Empty -> simple_fail "match empty variant" | Empty -> fail (corner_case ~loc:__LOC__ "match empty variant")
| Full x -> ok x in | Full x -> ok x in
let%bind tree'' = let%bind tree'' =
let rec aux t = let rec aux t =
@ -371,7 +467,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
match t with match t with
| ((`Leaf constructor_name) , tv) -> ( | ((`Leaf constructor_name) , tv) -> (
let%bind ((_ , name) , body) = let%bind ((_ , name) , body) =
trace_option (simple_error "not supposed to happen here: 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' = translate_annotated_expression body in let%bind body' = translate_annotated_expression body in
return @@ E_let_in ((name , tv) , top , body') return @@ E_let_in ((name , tv) , top , body')
@ -391,10 +487,11 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
in in
return @@ E_if_left (top , a' , b') return @@ E_if_left (top , a' , b')
in in
trace_strong (corner_case ~loc:__LOC__ "building constructor") @@
aux expr' tree'' aux expr' tree''
) )
| AST.Match_list _ | AST.Match_tuple (_, _) -> | AST.Match_list _ -> fail @@ unsupported_pattern_matching "list" ae.location
simple_fail "only match bool, option and variants are translated yet" | AST.Match_tuple _ -> fail @@ unsupported_pattern_matching "tuple" ae.location
) )
and translate_lambda_deep : Mini_c.Environment.t -> AST.lambda -> Mini_c.expression result = fun env l -> and translate_lambda_deep : Mini_c.Environment.t -> AST.lambda -> Mini_c.expression result = fun env l ->
@ -433,7 +530,6 @@ and translate_lambda env l =
| [] -> ( | [] -> (
let%bind result' = translate_annotated_expression result in let%bind result' = translate_annotated_expression result in
let result' = ez_e_return result' in let result' = ez_e_return result' in
trace (simple_error "translate quote") @@
let%bind input = translate_type input_type in let%bind input = translate_type input_type in
let%bind output = translate_type output_type in let%bind output = translate_type output_type in
let tv = Combinators.t_function input output in let tv = Combinators.t_function input output in
@ -441,7 +537,6 @@ and translate_lambda env l =
ok @@ Combinators.Expression.make_tpl (E_literal content, tv) ok @@ Combinators.Expression.make_tpl (E_literal content, tv)
) )
| _ -> ( | _ -> (
trace (simple_error "translate lambda deep") @@
translate_lambda_deep env l translate_lambda_deep env l
) in ) in
ok result ok result
@ -463,11 +558,11 @@ let translate_program (lst:AST.program) : program result =
let%bind (statements, _) = List.fold_left aux (ok ([], Environment.empty)) (temp_unwrap_loc_list lst) in let%bind (statements, _) = List.fold_left aux (ok ([], Environment.empty)) (temp_unwrap_loc_list lst) in
ok statements ok statements
let translate_main (l:AST.lambda) : anon_function result = let translate_main (l:AST.lambda) loc : anon_function result =
let%bind expr = translate_lambda Environment.empty l in let%bind expr = translate_lambda Environment.empty l in
match Combinators.Expression.get_content expr with match Combinators.Expression.get_content expr with
| E_literal (D_function f) -> ok f | E_literal (D_function f) -> ok f
| _ -> simple_fail "main is not a function" | _ -> fail @@ not_functional_main loc
(* From an expression [expr], build the expression [fun () -> expr] *) (* From an expression [expr], build the expression [fun () -> expr] *)
let functionalize (e:AST.annotated_expression) : AST.lambda * AST.type_value = let functionalize (e:AST.annotated_expression) : AST.lambda * AST.type_value =
@ -484,7 +579,7 @@ let translate_entry (lst:AST.program) (name:string) : anon_function result =
let rec aux acc (lst:AST.program) = let rec aux acc (lst:AST.program) =
let%bind acc = acc in let%bind acc = acc in
match lst with match lst with
| [] -> simple_fail "no entry point with given name" | [] -> fail @@ missing_entry_point name
| hd :: tl -> ( | hd :: tl -> (
let (AST.Declaration_constant (an , (pre_env , _))) = temp_unwrap_loc hd in let (AST.Declaration_constant (an , (pre_env , _))) = temp_unwrap_loc hd in
match an.name = name with match an.name = name with
@ -498,11 +593,11 @@ let translate_entry (lst:AST.program) (name:string) : anon_function result =
match an.annotated_expression.expression with match an.annotated_expression.expression with
| E_lambda l -> | E_lambda l ->
let l' = { l with result = acc l.result } in let l' = { l with result = acc l.result } in
translate_main l' translate_main l' an.annotated_expression.location
| _ -> | _ ->
let (l , _) = functionalize an.annotated_expression in let (l , _) = functionalize an.annotated_expression in
let l' = { l with result = acc l.result } in let l' = { l with result = acc l.result } in
translate_main l' translate_main l' an.annotated_expression.location
) )
) )
in in
@ -553,36 +648,62 @@ 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 ("unit", []) -> | T_constant ("unit", []) -> (
let%bind () = get_unit v in let%bind () =
trace_strong (wrong_mini_c_value "unit" v) @@
get_unit v in
return (E_literal Literal_unit) return (E_literal Literal_unit)
| T_constant ("bool", []) -> )
let%bind b = get_bool v in | T_constant ("bool", []) -> (
let%bind b =
trace_strong (wrong_mini_c_value "bool" v) @@
get_bool v in
return (E_literal (Literal_bool b)) return (E_literal (Literal_bool b))
| T_constant ("int", []) -> )
let%bind n = get_int v in | T_constant ("int", []) -> (
let%bind n =
trace_strong (wrong_mini_c_value "int" v) @@
get_int v in
return (E_literal (Literal_int n)) return (E_literal (Literal_int n))
| T_constant ("nat", []) -> )
let%bind n = get_nat v in | T_constant ("nat", []) -> (
let%bind n =
trace_strong (wrong_mini_c_value "nat" v) @@
get_nat v in
return (E_literal (Literal_nat n)) return (E_literal (Literal_nat n))
| T_constant ("tez", []) -> )
let%bind n = get_nat v in | T_constant ("tez", []) -> (
let%bind n =
trace_strong (wrong_mini_c_value "tez" v) @@
get_nat v in
return (E_literal (Literal_tez n)) return (E_literal (Literal_tez n))
| T_constant ("string", []) -> )
let%bind n = get_string v in | T_constant ("string", []) -> (
let%bind n =
trace_strong (wrong_mini_c_value "string" v) @@
get_string v in
return (E_literal (Literal_string n)) return (E_literal (Literal_string n))
| T_constant ("address", []) -> )
let%bind n = get_string v in | T_constant ("address", []) -> (
let%bind n =
trace_strong (wrong_mini_c_value "address" v) @@
get_string v in
return (E_literal (Literal_address n)) return (E_literal (Literal_address n))
)
| T_constant ("option", [o]) -> ( | T_constant ("option", [o]) -> (
match%bind get_option v with let%bind opt =
trace_strong (wrong_mini_c_value "option" v) @@
get_option v in
match opt with
| None -> ok (e_a_empty_none o) | None -> ok (e_a_empty_none o)
| Some s -> | Some s ->
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 ("map", [k_ty;v_ty]) -> ( | T_constant ("map", [k_ty;v_ty]) -> (
let%bind lst = get_map v in let%bind lst =
trace_strong (wrong_mini_c_value "map" v) @@
get_map v in
let%bind lst' = let%bind lst' =
let aux = fun (k, v) -> let aux = fun (k, v) ->
let%bind k' = untranspile k k_ty in let%bind k' = untranspile k k_ty in
@ -592,48 +713,55 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
return (E_map lst') return (E_map lst')
) )
| T_constant ("list", [ty]) -> ( | T_constant ("list", [ty]) -> (
let%bind lst = get_list v in let%bind lst =
trace_strong (wrong_mini_c_value "list" v) @@
get_list v in
let%bind lst' = let%bind lst' =
let aux = fun e -> untranspile e ty in let aux = fun e -> untranspile e ty in
bind_map_list aux lst in bind_map_list aux lst in
return (E_list lst') return (E_list lst')
) )
| T_constant ("contract" , [_ty]) -> | T_constant ("contract" , [_ty]) ->
simple_fail "can't untranspile contract" fail @@ bad_untranspile "contract" v
| T_constant ("operation" , []) -> | T_constant ("operation" , []) -> (
let%bind op = get_operation v in let%bind op =
trace_strong (wrong_mini_c_value "operation" v) @@
get_operation v in
return (E_literal (Literal_operation op)) return (E_literal (Literal_operation op))
| T_constant (name , lst) -> )
let error = | T_constant (name , _lst) ->
let title () = "unknown type_constant" in fail @@ unknown_untranspile name v
let content () = Format.asprintf "%s (%d)" name (List.length lst) in
error title content in
fail error
| T_sum m -> | T_sum m ->
let lst = kv_list_of_map m in let lst = kv_list_of_map m in
let%bind node = match Append_tree.of_list lst with let%bind node = match Append_tree.of_list lst with
| Empty -> simple_fail "empty sum type" | Empty -> fail @@ corner_case ~loc:__LOC__ "empty sum type"
| Full t -> ok t | Full t -> ok t
in in
let%bind (name, v, tv) = extract_constructor v node in let%bind (name, v, tv) =
trace_strong (corner_case ~loc:__LOC__ "sum extract constructor") @@
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 (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 -> simple_fail "empty tuple" | Empty -> fail @@ corner_case ~loc:__LOC__ "empty tuple"
| Full t -> ok t in | Full t -> ok t in
let%bind tpl = extract_tuple v node in let%bind tpl =
trace_strong (corner_case ~loc:__LOC__ "tuple extract") @@
extract_tuple v node in
let%bind tpl' = bind_list let%bind tpl' = bind_list
@@ 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_map m in
let%bind node = match Append_tree.of_list lst with let%bind node = match Append_tree.of_list lst with
| Empty -> simple_fail "empty record" | Empty -> fail @@ corner_case ~loc:__LOC__ "empty record"
| Full t -> ok t in | Full t -> ok t in
let%bind lst = extract_record v node in let%bind lst =
trace_strong (corner_case ~loc:__LOC__ "record extract") @@
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' = map_of_kv_list lst in
return (E_record m') return (E_record m')
| T_function _ -> simple_fail "no untranspilation for functions yet" | T_function _ -> fail @@ bad_untranspile "function" v