From 388c5e6a097a9568085717306dbcc47a5921cc8d Mon Sep 17 00:00:00 2001 From: Galfour Date: Tue, 4 Jun 2019 08:21:13 +0000 Subject: [PATCH] errorm messages for the transpiler --- src/main/run_source.ml | 2 +- src/main/run_typed.ml | 2 +- src/simplify/ligodity.ml | 9 +- src/transpiler/transpiler.ml | 312 ++++++++++++++++++++++++----------- 4 files changed, 227 insertions(+), 98 deletions(-) diff --git a/src/main/run_source.ml b/src/main/run_source.ml index 1c452c91d..26a3cd87e 100644 --- a/src/main/run_source.ml +++ b/src/main/run_source.ml @@ -51,7 +51,7 @@ let transpile_value let%bind f = let open Transpiler in let (f , _) = functionalize e in - let%bind main = translate_main f in + let%bind main = translate_main f e.location in ok main in diff --git a/src/main/run_typed.ml b/src/main/run_typed.ml index a7f9fdc58..47a67469d 100644 --- a/src/main/run_typed.ml +++ b/src/main/run_typed.ml @@ -5,7 +5,7 @@ let transpile_value let%bind f = let open Transpiler in let (f , _) = functionalize e in - let%bind main = translate_main f in + let%bind main = translate_main f e.location in ok main in diff --git a/src/simplify/ligodity.ml b/src/simplify/ligodity.ml index 640a1cfb8..b217325ce 100644 --- a/src/simplify/ligodity.ml +++ b/src/simplify/ligodity.ml @@ -79,7 +79,7 @@ let rec simpl_type_expression : Raw.type_expr -> type_expression result = fun te in ok @@ T_function (a , b) ) - | TApp x -> + | TApp x -> ( let (name, tuple) = x.value in let lst = npseq_to_list tuple.value.inside in let%bind cst = @@ -88,10 +88,11 @@ let rec simpl_type_expression : Raw.type_expr -> type_expression result = fun te in let%bind lst' = bind_map_list simpl_type_expression lst in ok @@ T_constant (cst , lst') - | TProd p -> - let%bind tpl = simpl_list_type_expression - @@ npseq_to_list p.value in + ) + | TProd p -> ( + let%bind tpl = simpl_list_type_expression @@ npseq_to_list p.value in ok tpl + ) | TRecord r -> let aux = fun (x, y) -> let%bind y = simpl_type_expression y in ok (x, y) in let%bind lst = diff --git a/src/transpiler/transpiler.ml b/src/transpiler/transpiler.ml index a146358fa..7523e08dd 100644 --- a/src/transpiler/transpiler.ml +++ b/src/transpiler/transpiler.ml @@ -15,7 +15,78 @@ let map_of_kv_list lst = let open AST.SMap in 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 = + trace (simple_info "") @@ match t.type_value' with | T_constant ("bool", []) -> ok (T_base Base_bool) | 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]) -> let%bind o' = translate_type o in ok (T_option o') - | T_constant (name , lst) -> - 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_constant (name , _lst) -> fail @@ unrecognized_type_constant name | T_sum m -> let node = Append_tree.of_list @@ list_of_map m in 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 return ?(tv = tv) expr = ok @@ Combinators.Expression.make_tpl (expr, tv) 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 - (* Optimise immediate application as a let-in *) | E_let_in {binder; rhs; result} -> let%bind rhs' = translate_annotated_expression rhs 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 b = translate_annotated_expression b in return @@ E_application (a, b) - | E_constructor (m, param) -> + | E_constructor (m, param) -> ( let%bind param' = translate_annotated_expression 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 = if k = m then ( 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 ok (Some (param'_expr), param'_tv) ) else ( @@ -204,16 +276,17 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re let%bind b = b in match (a, b) with | (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)) | (None, a), (Some v, b) -> ok (Some (E_constant ("RIGHT", [Combinators.Expression.make_tpl (v, b)])), T_or (a, b)) in let%bind (ae_opt, tv) = Append_tree.fold_ne leaf node node_tv in 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 return ~tv ae - | E_tuple lst -> + ) + | E_tuple lst -> ( let node = Append_tree.of_list lst in let aux (a:expression result) (b:expression result) : expression result = 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]) in 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_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 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 c = match lr with | `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 expr = List.fold_left aux tpl' path in ok expr - | E_record m -> + ) + | E_record m -> ( let node = Append_tree.of_list @@ list_of_map m in let aux a b : expression result = 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 return ~tv @@ E_constant ("PAIR", [a; b]) in + trace_strong (corner_case ~loc:__LOC__ "record build") @@ Append_tree.fold_ne (translate_annotated_expression) aux node + ) | E_record_accessor (record, property) -> 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 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 c = match lr with | `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 expr = List.fold_left aux record' path in ok expr - | E_constant (name, lst) -> - let%bind lst' = bind_list @@ List.map (translate_annotated_expression) lst in ( - match name, lst with - | "NONE", [] -> - let%bind o = Mini_c.Combinators.get_t_option tv in - return @@ E_make_none o - | _ -> return @@ E_constant (name, lst') - ) + | E_constant (name, lst) -> ( + let%bind lst' = bind_map_list (translate_annotated_expression) lst in + match name, lst with + | "NONE", [] -> + 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_constant (name, lst') + ) | 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 - | E_list lst -> - let%bind t = Mini_c.Combinators.get_t_list tv in + | E_list lst -> ( + 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 aux : expression -> expression -> expression result = fun prev cur -> return @@ E_constant ("CONS", [cur ; prev]) in let%bind (init : expression) = return @@ E_make_empty_list t in 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%bind prev' = prev in let%bind (k', v') = 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']) in let init = return @@ E_make_empty_map (src, dst) in List.fold_left aux init m - | E_look_up dsi -> + ) + | E_look_up dsi -> ( let%bind (ds', i') = bind_map_pair f dsi in return @@ E_constant ("MAP_GET", [i' ; ds']) + ) | E_sequence (a , b) -> ( let%bind a' = translate_annotated_expression a 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 -> let%bind ty' = translate_type prev in match cur with - | Access_tuple ind -> - let%bind ty_lst = AST.Combinators.get_t_tuple prev in + | Access_tuple ind -> ( + 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 path = tuple_access_to_lr ty' ty'_lst ind in let path' = List.map snd path in ok (List.nth ty_lst ind, acc @ path') - | Access_record prop -> - let%bind ty_map = - let error = - 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 @@ + ) + | Access_record prop -> ( + let%bind ty_map = + trace_strong (corner_case ~loc:__LOC__ "not a record") @@ AST.Combinators.get_t_record prev in let%bind ty'_map = bind_map_smap translate_type ty_map in let%bind path = record_access_to_lr ty' ty'_map prop in let path' = List.map snd path in - ok (Map.String.find prop ty_map, acc @ path') - | Access_map _k -> simple_fail "no patch for map yet" + ok (Map.String.find prop ty_map, acc @ path') + ) + | Access_map _k -> fail (corner_case ~loc:__LOC__ "no patch for map yet") in let%bind (_, path) = bind_fold_right_list aux (ty, []) path 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 return @@ E_if_none (expr' , n , ((name , tv') , s')) | 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 - | Empty -> simple_fail "match empty variant" + | Empty -> fail (corner_case ~loc:__LOC__ "match empty variant") | Full x -> ok x in let%bind tree'' = let rec aux t = @@ -371,7 +467,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re match t with | ((`Leaf constructor_name) , tv) -> ( 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 let%bind body' = translate_annotated_expression body in return @@ E_let_in ((name , tv) , top , body') @@ -391,10 +487,11 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re in return @@ E_if_left (top , a' , b') in + trace_strong (corner_case ~loc:__LOC__ "building constructor") @@ aux expr' tree'' ) - | AST.Match_list _ | AST.Match_tuple (_, _) -> - simple_fail "only match bool, option and variants are translated yet" + | AST.Match_list _ -> fail @@ unsupported_pattern_matching "list" ae.location + | 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 -> @@ -433,7 +530,6 @@ and translate_lambda env l = | [] -> ( let%bind result' = translate_annotated_expression result in let result' = ez_e_return result' in - trace (simple_error "translate quote") @@ let%bind input = translate_type input_type in let%bind output = translate_type output_type 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) ) | _ -> ( - trace (simple_error "translate lambda deep") @@ translate_lambda_deep env l ) in 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 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 match Combinators.Expression.get_content expr with | 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] *) 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%bind acc = acc in match lst with - | [] -> simple_fail "no entry point with given name" + | [] -> fail @@ missing_entry_point name | hd :: tl -> ( let (AST.Declaration_constant (an , (pre_env , _))) = temp_unwrap_loc hd in 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 | E_lambda l -> 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' = { l with result = acc l.result } in - translate_main l' + translate_main l' an.annotated_expression.location ) ) in @@ -553,36 +648,62 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression let open! AST in let return e = ok (make_a_e_empty e t) in match t.type_value' with - | T_constant ("unit", []) -> - let%bind () = get_unit v in + | T_constant ("unit", []) -> ( + let%bind () = + trace_strong (wrong_mini_c_value "unit" v) @@ + get_unit v in 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)) - | 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)) - | 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)) - | 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)) - | 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)) - | 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)) + ) | 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) | Some s -> let%bind s' = untranspile s o in ok (e_a_empty_some s') ) | 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 aux = fun (k, v) -> 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') ) | 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 aux = fun e -> untranspile e ty in bind_map_list aux lst in return (E_list lst') ) | T_constant ("contract" , [_ty]) -> - simple_fail "can't untranspile contract" - | T_constant ("operation" , []) -> - let%bind op = get_operation v in + fail @@ bad_untranspile "contract" v + | T_constant ("operation" , []) -> ( + let%bind op = + trace_strong (wrong_mini_c_value "operation" v) @@ + get_operation v in return (E_literal (Literal_operation op)) - | T_constant (name , lst) -> - let error = - let title () = "unknown type_constant" in - let content () = Format.asprintf "%s (%d)" name (List.length lst) in - error title content in - fail error + ) + | T_constant (name , _lst) -> + fail @@ unknown_untranspile name v | T_sum m -> let lst = kv_list_of_map m in 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 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 return (E_constructor (name, sub)) | T_tuple lst -> 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 - 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 @@ List.map (fun (x, y) -> untranspile x y) tpl in return (E_tuple tpl') | T_record m -> let lst = kv_list_of_map m in let%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 - 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 @@ 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 return (E_record m') - | T_function _ -> simple_fail "no untranspilation for functions yet" + | T_function _ -> fail @@ bad_untranspile "function" v