diff --git a/src/ast_simplified/PP.ml b/src/ast_simplified/PP.ml index 5cd46827c..e136988d2 100644 --- a/src/ast_simplified/PP.ml +++ b/src/ast_simplified/PP.ml @@ -113,6 +113,22 @@ and matching : type a . (formatter -> a -> unit) -> formatter -> a matching -> u | Match_option {match_none ; match_some = (some, match_some)} -> fprintf ppf "| None -> %a @.| Some %s -> %a" f match_none some f match_some +(* Shows the type expected for the matched value *) +and matching_type ppf m = match m with + | Match_tuple _ -> + fprintf ppf "tuple" + | Match_variant lst -> + fprintf ppf "variant %a" (list_sep matching_variant_case_type (tag "@.")) lst + | Match_bool _ -> + fprintf ppf "boolean" + | Match_list _ -> + fprintf ppf "list" + | Match_option _ -> + fprintf ppf "option" + +and matching_variant_case_type ppf ((c,n),_a) = + fprintf ppf "| %s %s" c n + let declaration ppf (d:declaration) = match d with | Declaration_type (type_name , te) -> fprintf ppf "type %s = %a" type_name type_expression te diff --git a/src/ast_typed/misc.ml b/src/ast_typed/misc.ml index 733f576c7..c1393fe53 100644 --- a/src/ast_typed/misc.ml +++ b/src/ast_typed/misc.ml @@ -204,7 +204,6 @@ let rec assert_type_value_eq (a, b: (type_value * type_value)) : unit result = m @@ Assert.assert_list_same_size sa' sb' in trace (simple_error "sum type") @@ bind_list_iter aux (List.combine sa' sb') - ) | T_sum _, _ -> fail @@ different_kinds a b | T_record ra, T_record rb -> ( diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 81480236e..13ca1f970 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -4,8 +4,8 @@ open Trace let toplevel x = match x with | Trace.Ok ((), annotations) -> ignore annotations; () - | Errors ss -> - Format.printf "Errors: %a\n%!" errors_pp @@ List.map (fun f -> f()) ss + | Error ss -> + Format.printf "%a%!" error_pp (ss ()) let main = let term = Term.(const print_endline $ const "Ligo needs a command. Do ligo --help") in 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/parser/ligodity.ml b/src/parser/ligodity.ml index 81ee4183e..fba239b59 100644 --- a/src/parser/ligodity.ml +++ b/src/parser/ligodity.ml @@ -3,7 +3,7 @@ open Parser_ligodity module Parser = Parser_ligodity.Parser module AST = Parser_ligodity.AST -let parse_file (source: string) : AST.t result = +let parse_file (source: string) : AST.t result = (* let pp_input = * let prefix = Filename.(source |> basename |> remove_extension) * and suffix = ".pp.ligo" @@ -50,7 +50,7 @@ let parse_file (source: string) : AST.t result = ok raw let parse_string (s:string) : AST.t result = - + let lexbuf = Lexing.from_string s in let read = Lexer.get_token in specific_try (function @@ -94,5 +94,5 @@ let parse_expression (s:string) : AST.expr result = start.pos_fname s in simple_error str - ) @@ (fun () -> Parser.expr read lexbuf) >>? fun raw -> + ) @@ (fun () -> Parser.interactive_expr read lexbuf) >>? fun raw -> ok raw diff --git a/src/parser/ligodity/AST.ml b/src/parser/ligodity/AST.ml index 9d3be1095..aecb8c277 100644 --- a/src/parser/ligodity/AST.ml +++ b/src/parser/ligodity/AST.ml @@ -346,7 +346,7 @@ and conditional = { let sprintf = Printf.sprintf -let region_of_type_expr = function +let type_expr_to_region = function TProd {region; _} | TSum {region; _} | TRecord {region; _} @@ -355,12 +355,11 @@ let region_of_type_expr = function | TPar {region; _} | TAlias {region; _} -> region - -let region_of_list_pattern = function +let list_pattern_to_region = function Sugar {region; _} | PCons {region; _} -> region -let region_of_pattern = function - PList p -> region_of_list_pattern p +let pattern_to_region = function + PList p -> list_pattern_to_region p | PTuple {region;_} | PVar {region;_} | PUnit {region;_} | PInt {region;_} | PTrue region | PFalse region @@ -368,38 +367,38 @@ let region_of_pattern = function | PConstr {region; _} | PPar {region;_} | PRecord {region; _} | PTyped {region; _} -> region -let region_of_bool_expr = function +let bool_expr_to_region = function Or {region;_} | And {region;_} | True region | False region | Not {region;_} -> region -let region_of_comp_expr = function +let comp_expr_to_region = function Lt {region;_} | Leq {region;_} | Gt {region;_} | Geq {region;_} | Neq {region;_} | Equal {region;_} -> region -let region_of_logic_expr = function - BoolExpr e -> region_of_bool_expr e -| CompExpr e -> region_of_comp_expr e +let logic_expr_to_region = function + BoolExpr e -> bool_expr_to_region e +| CompExpr e -> comp_expr_to_region e -let region_of_arith_expr = function +let arith_expr_to_region = function Add {region;_} | Sub {region;_} | Mult {region;_} | Div {region;_} | Mod {region;_} | Neg {region;_} | Int {region;_} | Mtz {region; _} | Nat {region; _} -> region -let region_of_string_expr = function +let string_expr_to_region = function String {region;_} | Cat {region;_} -> region -let region_of_list_expr = function +let list_expr_to_region = function Cons {region; _} | List {region; _} (* | Append {region; _}*) -> region -let region_of_expr = function - ELogic e -> region_of_logic_expr e -| EArith e -> region_of_arith_expr e -| EString e -> region_of_string_expr e -| EList e -> region_of_list_expr e +let expr_to_region = function + ELogic e -> logic_expr_to_region e +| EArith e -> arith_expr_to_region e +| EString e -> string_expr_to_region e +| EList e -> list_expr_to_region e | EAnnot {region;_ } | ELetIn {region;_} | EFun {region;_} | ECond {region;_} | ETuple {region;_} | ECase {region;_} | ECall {region;_} | EVar {region; _} | EProj {region; _} diff --git a/src/parser/ligodity/AST.mli b/src/parser/ligodity/AST.mli index fbad9289e..f782ebd10 100644 --- a/src/parser/ligodity/AST.mli +++ b/src/parser/ligodity/AST.mli @@ -470,9 +470,9 @@ val print_tokens : (*?undo:bool ->*) ast -> unit (* Projecting regions from sundry nodes of the AST. See the first comment at the beginning of this file. *) -val region_of_pattern : pattern -> Region.t -val region_of_expr : expr -> Region.t -val region_of_type_expr : type_expr -> Region.t +val pattern_to_region : pattern -> Region.t +val expr_to_region : expr -> Region.t +val type_expr_to_region : type_expr -> Region.t (* Simplifications *) diff --git a/src/parser/ligodity/Parser.mly b/src/parser/ligodity/Parser.mly index 7221f6fd8..cc76a8867 100644 --- a/src/parser/ligodity/Parser.mly +++ b/src/parser/ligodity/Parser.mly @@ -47,9 +47,9 @@ let rec mk_field_path (rank, tail) = (* Entry points *) -%start program expr +%start program interactive_expr %type program -%type expr +%type interactive_expr %% @@ -285,7 +285,7 @@ entry_binding: {bindings = pattern :: hd :: tl; lhs_type=$3; eq=$4; let_rhs} } | ident type_annotation? eq fun_expr(expr) { - let pattern = PVar $1 in + let pattern = PVar $1 in {bindings = [pattern]; lhs_type=$2; eq=$3; let_rhs=$4} } (* Top-level non-recursive definitions *) @@ -382,6 +382,9 @@ tail: (* Expressions *) +interactive_expr: + expr EOF { $1 } + expr: base_cond__open(expr) { $1 } | reg(match_expr(base_cond)) { ECase $1 } @@ -468,7 +471,7 @@ fun_expr(right_expr): } in EFun { region=$1.region; value=f } } - + disj_expr_level: reg(disj_expr) { ELogic (BoolExpr (Or $1)) } | conj_expr_level { $1 } diff --git a/src/parser/pascaligo/AST.ml b/src/parser/pascaligo/AST.ml index 84930a580..14557beda 100644 --- a/src/parser/pascaligo/AST.ml +++ b/src/parser/pascaligo/AST.ml @@ -315,8 +315,9 @@ and statement = | Data of data_decl and local_decl = - LocalLam of lambda_decl -| LocalData of data_decl + LocalFun of fun_decl reg +| LocalProc of proc_decl reg +| LocalData of data_decl and data_decl = LocalConst of const_decl reg @@ -785,9 +786,8 @@ let pattern_to_region = function | PTuple {region; _} -> region let local_decl_to_region = function - LocalLam FunDecl {region; _} -| LocalLam ProcDecl {region; _} -| LocalLam EntryDecl {region; _} + LocalFun {region; _} +| LocalProc {region; _} | LocalData LocalConst {region; _} | LocalData LocalVar {region; _} -> region diff --git a/src/parser/pascaligo/AST.mli b/src/parser/pascaligo/AST.mli index 7de078bea..ccb9b7712 100644 --- a/src/parser/pascaligo/AST.mli +++ b/src/parser/pascaligo/AST.mli @@ -299,8 +299,9 @@ and statement = | Data of data_decl and local_decl = - LocalLam of lambda_decl -| LocalData of data_decl + LocalFun of fun_decl reg +| LocalProc of proc_decl reg +| LocalData of data_decl and data_decl = LocalConst of const_decl reg diff --git a/src/parser/pascaligo/Parser.mly b/src/parser/pascaligo/Parser.mly index 940825a13..9c68a6e09 100644 --- a/src/parser/pascaligo/Parser.mly +++ b/src/parser/pascaligo/Parser.mly @@ -426,8 +426,9 @@ open_var_decl: in {region; value}} local_decl: - lambda_decl { LocalLam $1 } -| data_decl { LocalData $1 } + fun_decl { LocalFun $1 } +| proc_decl { LocalProc $1 } +| data_decl { LocalData $1 } data_decl: const_decl { LocalConst $1 } diff --git a/src/parser/pascaligo/ParserLog.ml b/src/parser/pascaligo/ParserLog.ml index 61dcc9f2f..671e9d916 100644 --- a/src/parser/pascaligo/ParserLog.ml +++ b/src/parser/pascaligo/ParserLog.ml @@ -251,7 +251,8 @@ and print_local_decls sequence = List.iter print_local_decl sequence and print_local_decl = function - LocalLam decl -> print_lambda_decl decl + LocalFun decl -> print_fun_decl decl +| LocalProc decl -> print_proc_decl decl | LocalData decl -> print_data_decl decl and print_data_decl = function diff --git a/src/simplify/camligo.ml b/src/simplify/camligo.ml.old similarity index 100% rename from src/simplify/camligo.ml rename to src/simplify/camligo.ml.old diff --git a/src/simplify/dune b/src/simplify/dune index 7035f2eef..5e4e7d88b 100644 --- a/src/simplify/dune +++ b/src/simplify/dune @@ -7,7 +7,7 @@ parser ast_simplified operators) - (modules ligodity pascaligo camligo simplify) + (modules ligodity pascaligo simplify) (preprocess (pps simple-utils.ppx_let_generalized diff --git a/src/simplify/ligodity.ml b/src/simplify/ligodity.ml index 77c2954c8..e938ad285 100644 --- a/src/simplify/ligodity.ml +++ b/src/simplify/ligodity.ml @@ -17,6 +17,151 @@ let pseq_to_list = function | Some lst -> npseq_to_list lst let get_value : 'a Raw.reg -> 'a = fun x -> x.value +module Errors = struct + let wrong_pattern expected_name actual = + let title () = "wrong pattern" in + let message () = "" in + let data = [ + ("expected", fun () -> expected_name); + ("actual_loc" , fun () -> Format.asprintf "%a" Location.pp_lift @@ Raw.pattern_to_region actual) + ] in + error ~data title message + + let multiple_patterns construct (patterns: Raw.pattern list) = + let title () = "multiple patterns" in + let message () = + Format.asprintf "multiple patterns in \"%s\" are not supported yet" construct in + let patterns_loc = + List.fold_left (fun a p -> Region.cover a (Raw.pattern_to_region p)) + Region.min patterns in + let data = [ + ("patterns_loc", fun () -> Format.asprintf "%a" Location.pp_lift @@ patterns_loc) + ] in + error ~data title message + + let unknown_predefined_type name = + let title () = "type constants" in + let message () = + Format.asprintf "unknown predefined type \"%s\"" name.Region.value in + let data = [ + ("typename_loc", + fun () -> Format.asprintf "%a" Location.pp_lift @@ name.Region.region) + ] in + error ~data title message + + let unsupported_arith_op expr = + let title () = "arithmetic expressions" in + let message () = + Format.asprintf "this arithmetic operator is not supported yet" in + let expr_loc = Raw.expr_to_region expr in + let data = [ + ("expr_loc", + fun () -> Format.asprintf "%a" Location.pp_lift @@ expr_loc) + ] in + error ~data title message + + let unsupported_string_catenation expr = + let title () = "string expressions" in + let message () = + Format.asprintf "string concatenation is not supported yet" in + let expr_loc = Raw.expr_to_region expr in + let data = [ + ("expr_loc", + fun () -> Format.asprintf "%a" Location.pp_lift @@ expr_loc) + ] in + error ~data title message + + let untyped_fun_param var = + let title () = "function parameter" in + let message () = + Format.asprintf "untyped function parameters are not supported yet" in + let param_loc = var.Region.region in + let data = [ + ("param_loc", + fun () -> Format.asprintf "%a" Location.pp_lift @@ param_loc) + ] in + error ~data title message + + let unsupported_tuple_pattern p = + let title () = "tuple pattern" in + let message () = + Format.asprintf "tuple patterns are not supported yet" in + let pattern_loc = Raw.pattern_to_region p in + let data = [ + ("pattern_loc", + fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc) + ] in + error ~data title message + + let unsupported_cst_constr p = + let title () = "constant constructor" in + let message () = + Format.asprintf "constant constructors are not supported yet" in + let pattern_loc = Raw.pattern_to_region p in + let data = [ + ("pattern_loc", + fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc) + ] in + error ~data title message + + let unsupported_non_var_pattern p = + let title () = "pattern is not a variable" in + let message () = + Format.asprintf "non-variable patterns in constructors \ + are not supported yet" in + let pattern_loc = Raw.pattern_to_region p in + let data = [ + ("pattern_loc", + fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc) + ] in + error ~data title message + + let simplifying_expr t = + let title () = "simplifying expression" in + let message () = "" in + let data = [ + ("expression" , + thunk @@ Format.asprintf "%a" (PP_helpers.printer Raw.print_expr) t) + ] in + error ~data title message + + let only_constructors p = + let title () = "constructors in patterns" in + let message () = + Format.asprintf "currently, only constructors are supported in patterns" in + let pattern_loc = Raw.pattern_to_region p in + let data = [ + ("pattern_loc", + fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc) + ] in + error ~data title message + + let unsupported_sugared_lists region = + let title () = "lists in patterns" in + let message () = + Format.asprintf "currently, only empty lists and constructors (::) \ + are supported in patterns" in + let data = [ + ("pattern_loc", + fun () -> Format.asprintf "%a" Location.pp_lift @@ region) + ] in + error ~data title message + + 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 +end + +open Errors + open Operators.Simplify.Ligodity let r_split = Location.r_split @@ -25,7 +170,7 @@ let rec pattern_to_var : Raw.pattern -> _ = fun p -> match p with | Raw.PPar p -> pattern_to_var p.value.inside | Raw.PVar v -> ok v - | _ -> simple_fail "not a var" + | _ -> fail @@ wrong_pattern "var" p let rec pattern_to_typed_var : Raw.pattern -> _ = fun p -> match p with @@ -36,7 +181,7 @@ let rec pattern_to_typed_var : Raw.pattern -> _ = fun p -> ok (v , Some tp.type_expr) ) | Raw.PVar v -> ok (v , None) - | _ -> simple_fail "not a var" + | _ -> fail @@ wrong_pattern "typed variable" p let rec expr_to_typed_expr : Raw.expr -> _ = fun e -> match e with @@ -45,11 +190,13 @@ let rec expr_to_typed_expr : Raw.expr -> _ = fun e -> | _ -> ok (e , None) let patterns_to_var : Raw.pattern list -> _ = fun ps -> - let%bind () = Assert.assert_list_size ps 1 in - pattern_to_var @@ List.hd ps + match ps with + | [ pattern ] -> pattern_to_var pattern + | _ -> fail @@ multiple_patterns "let" ps -let rec simpl_type_expression : Raw.type_expr -> type_expression result = - function +let rec simpl_type_expression : Raw.type_expr -> type_expression result = fun te -> + trace (simple_info "simplifying this type expression...") @@ + match te with | TPar x -> simpl_type_expression x.value.inside | TAlias v -> ( match List.assoc_opt v.value type_constants with @@ -59,26 +206,34 @@ let rec simpl_type_expression : Raw.type_expr -> type_expression result = | TFun x -> ( let%bind (a , b) = let (a , _ , b) = x.value in - bind_map_pair simpl_type_expression (a , b) in + let%bind a = simpl_type_expression a in + let%bind b = simpl_type_expression b in + ok (a , b) + 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 = - trace_option (simple_error "unrecognized type constants") @@ - List.assoc_opt name.value type_constants in - let%bind lst' = bind_list @@ List.map simpl_type_expression lst in + trace_option (unknown_predefined_type name) @@ + List.assoc_opt name.value type_constants + in + let%bind lst' = bind_map_list simpl_type_expression lst in ok @@ T_constant (cst , lst') - | 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 = bind_list + let apply (x:Raw.field_decl Raw.reg) = + (x.value.field_name.value, x.value.field_type) in + let%bind lst = + bind_list @@ List.map aux - @@ List.map (fun (x:Raw.field_decl Raw.reg) -> (x.value.field_name.value, x.value.field_type)) + @@ List.map apply @@ pseq_to_list r.value.elements in let m = List.fold_left (fun m (x, y) -> SMap.add x y m) SMap.empty lst in ok @@ T_record m @@ -104,7 +259,7 @@ and simpl_list_type_expression (lst:Raw.type_expr list) : type_expression result | [] -> assert false | [hd] -> simpl_type_expression hd | lst -> - let%bind lst = bind_list @@ List.map simpl_type_expression lst in + let%bind lst = bind_map_list simpl_type_expression lst in ok @@ T_tuple lst let rec simpl_expression : @@ -128,14 +283,7 @@ let rec simpl_expression : return @@ e_accessor ~loc var path' in - trace ( - let title () = "simplifying expression" in - let message () = "" in - let data = [ - ("expression" , thunk @@ Format.asprintf "%a" (PP_helpers.printer Raw.print_expr) t) - ] in - error ~data title message - ) @@ + trace (simplifying_expr t) @@ match t with | Raw.ELetIn e -> ( let Raw.{binding ; body ; _} = e.value in @@ -240,7 +388,8 @@ let rec simpl_expression : let n = Z.to_int @@ snd @@ n in return @@ e_literal ~loc (Literal_tez n) ) - | EArith _ -> simple_fail "arith: not supported yet" + | EArith _ as e -> + fail @@ unsupported_arith_op e | EString (String s) -> ( let (s , loc) = r_split s in let s' = @@ -249,7 +398,8 @@ let rec simpl_expression : in return @@ e_literal ~loc (Literal_string s') ) - | EString _ -> simple_fail "string: not supported yet" + | EString (Cat _) as e -> + fail @@ unsupported_string_catenation e | ELogic l -> simpl_logic_expression l | EList l -> simpl_list_expression l | ECase c -> ( @@ -321,7 +471,7 @@ and simpl_fun lamb' : expr result = | "storage" , None -> ok (var , T_variable "storage") | _ , None -> - simple_fail "untyped function parameter" + fail @@ untyped_fun_param var | _ , Some ty -> ( let%bind ty' = simpl_type_expression ty in ok (var , ty') @@ -411,21 +561,24 @@ and simpl_tuple_expression ?loc (lst:Raw.expr list) : expression result = let%bind lst = bind_list @@ List.map simpl_expression lst in return @@ e_tuple ?loc lst -and simpl_declaration : Raw.declaration -> declaration Location.wrap result = fun t -> +and simpl_declaration : Raw.declaration -> declaration Location.wrap result = + fun t -> let open! Raw in - let loc : 'a . 'a Raw.reg -> _ -> _ = fun x v -> Location.wrap ~loc:(File x.region) v in + let loc : 'a . 'a Raw.reg -> _ -> _ = + fun x v -> Location.wrap ~loc:(File x.region) v in match t with | TypeDecl x -> let {name;type_expr} : Raw.type_decl = x.value in let%bind type_expression = simpl_type_expression type_expr in ok @@ loc x @@ Declaration_type (name.value , type_expression) - | LetEntry x (* -> simple_fail "no entry point yet" *) + | LetEntry x | Let x -> ( let _ , binding = x.value in let {bindings ; lhs_type ; let_rhs} = binding in let%bind (var , args) = - let%bind (hd , tl) = match bindings with - | [] -> simple_fail "let without bindgings" + let%bind (hd , tl) = + match bindings with + | [] -> fail @@ corner_case ~loc:__LOC__ "let without bindings" | hd :: tl -> ok (hd , tl) in let%bind var = pattern_to_var hd in @@ -452,55 +605,58 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap result = fu ) ) -and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t -> +and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = + fun t -> let open Raw in - let get_var (t:Raw.pattern) = match t with + let rec get_var (t:Raw.pattern) = + match t with | PVar v -> ok v.value - | _ -> - let error = - let title () = "not a var" in - let content () = Format.asprintf "%a" (PP_helpers.printer Raw.print_pattern) t in - error title content - in - fail error + | PPar p -> get_var p.value.inside + | _ -> fail @@ unsupported_non_var_pattern t in - let get_tuple (t:Raw.pattern) = match t with + let rec get_tuple (t:Raw.pattern) = + match t with | PTuple v -> npseq_to_list v.value + | PPar p -> get_tuple p.value.inside | x -> [ x ] in let get_single (t:Raw.pattern) = let t' = get_tuple t in let%bind () = - trace_strong (simple_error "not single") @@ + trace_strong (unsupported_tuple_pattern t) @@ Assert.assert_list_size t' 1 in - ok (List.hd t') in - let get_constr (t:Raw.pattern) = match t with + ok (List.hd t') + in + let rec get_constr (t:Raw.pattern) = + match t with + | PPar p -> get_constr p.value.inside | PConstr v -> ( let (const , pat_opt) = v.value in let%bind pat = - trace_option (simple_error "No constructor without variable yet") @@ + trace_option (unsupported_cst_constr t) @@ pat_opt in let%bind single_pat = get_single pat in let%bind var = get_var single_pat in ok (const.value , var) ) - | _ -> simple_fail "not a constr" + | _ -> fail @@ only_constructors t in let%bind patterns = let aux (x , y) = let xs = get_tuple x in - trace_strong (simple_error "no tuple in patterns yet") @@ + trace_strong (unsupported_tuple_pattern x) @@ Assert.assert_list_size xs 1 >>? fun () -> ok (List.hd xs , y) in bind_map_list aux t in match patterns with | [(PFalse _ , f) ; (PTrue _ , t)] - | [(PTrue _ , t) ; (PFalse _ , f)] -> ok @@ Match_bool {match_true = t ; match_false = f} + | [(PTrue _ , t) ; (PFalse _ , f)] -> + ok @@ Match_bool {match_true = t ; match_false = f} | [(PList (PCons c) , cons) ; (PList (Sugar sugar_nil) , nil)] | [(PList (Sugar sugar_nil) , nil) ; (PList (PCons c), cons)] -> ( let%bind () = - trace_strong (simple_error "Only empty list patterns and cons are allowed yet") + trace_strong (unsupported_sugared_lists sugar_nil.region) @@ Assert.assert_list_empty @@ pseq_to_list @@ sugar_nil.value.elements in @@ -513,7 +669,8 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t - ok @@ Match_list {match_cons = (a, b, cons) ; match_nil = nil} ) | lst -> ( - trace (simple_error "weird patterns not supported yet") @@ + trace (simple_info "currently, only booleans, lists and constructors \ + are supported in patterns") @@ let%bind constrs = let aux (x , y) = let error = diff --git a/src/simplify/pascaligo.ml b/src/simplify/pascaligo.ml index c5af5e80c..cc5a027f9 100644 --- a/src/simplify/pascaligo.ml +++ b/src/simplify/pascaligo.ml @@ -14,6 +14,94 @@ let pseq_to_list = function | Some lst -> npseq_to_list lst let get_value : 'a Raw.reg -> 'a = fun x -> x.value +module Errors = struct + let unsupported_entry_decl decl = + let title () = "entry point declarations" in + let message () = + Format.asprintf "entry points within the contract are not supported yet" in + let data = [ + ("declaration", + fun () -> Format.asprintf "%a" Location.pp_lift @@ decl.Region.region) + ] in + error ~data title message + + let unsupported_proc_decl decl = + let title () = "procedure declarations" in + let message () = + Format.asprintf "procedures are not supported yet" in + let data = [ + ("declaration", + fun () -> Format.asprintf "%a" Location.pp_lift @@ decl.Region.region) + ] in + error ~data title message + + let unsupported_local_proc region = + let title () = "local procedure declarations" in + let message () = + Format.asprintf "local procedures are not supported yet" in + let data = [ + ("declaration", + fun () -> Format.asprintf "%a" Location.pp_lift @@ region) + ] in + error ~data title message + + 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 unknown_predefined_type name = + let title () = "type constants" in + let message () = + Format.asprintf "unknown predefined type \"%s\"" name.Region.value in + let data = [ + ("typename_loc", + fun () -> Format.asprintf "%a" Location.pp_lift @@ name.Region.region) + ] in + error ~data title message + + let unsupported_arith_op expr = + let title () = "arithmetic expressions" in + let message () = + Format.asprintf "this arithmetic operator is not supported yet" in + let expr_loc = Raw.expr_to_region expr in + let data = [ + ("expr_loc", + fun () -> Format.asprintf "%a" Location.pp_lift @@ expr_loc) + ] in + error ~data title message + + let unsupported_string_catenation expr = + let title () = "string expressions" in + let message () = + Format.asprintf "string concatenation is not supported yet" in + let expr_loc = Raw.expr_to_region expr in + let data = [ + ("expr_loc", + fun () -> Format.asprintf "%a" Location.pp_lift @@ expr_loc) + ] in + error ~data title message + + let unsupported_set_expr expr = + let title () = "set expressions" in + let message () = + Format.asprintf "set type is not supported yet" in + let expr_loc = Raw.expr_to_region expr in + let data = [ + ("expr_loc", + fun () -> Format.asprintf "%a" Location.pp_lift @@ expr_loc) + ] in + error ~data title message +end + +open Errors open Operators.Simplify.Pascaligo let r_split = Location.r_split @@ -26,7 +114,7 @@ let return expr = ok @@ fun expr'_opt -> let return_let_in ?loc binder rhs = ok @@ fun expr'_opt -> match expr'_opt with - | None -> simple_fail "missing return" (* Hard to explain. Shouldn't happen in prod. *) + | None -> fail @@ corner_case ~loc:__LOC__ "missing return" | Some expr' -> ok @@ e_let_in ?loc binder rhs expr' let rec simpl_type_expression (t:Raw.type_expr) : type_expression result = @@ -48,7 +136,7 @@ let rec simpl_type_expression (t:Raw.type_expr) : type_expression result = let lst = npseq_to_list tuple.value.inside in let%bind lst' = bind_list @@ List.map simpl_type_expression lst in let%bind cst = - trace_option (simple_error "unrecognized type constants") @@ + trace_option (unknown_predefined_type name) @@ List.assoc_opt name.value type_constants in ok @@ T_constant (cst , lst') | TProd p -> @@ -57,9 +145,11 @@ let rec simpl_type_expression (t:Raw.type_expr) : type_expression result = ok tpl | TRecord r -> let aux = fun (x, y) -> let%bind y = simpl_type_expression y in ok (x, y) in + let apply = + fun (x:Raw.field_decl Raw.reg) -> (x.value.field_name.value, x.value.field_type) in let%bind lst = bind_list @@ List.map aux - @@ List.map (fun (x:Raw.field_decl Raw.reg) -> (x.value.field_name.value, x.value.field_type)) + @@ List.map apply @@ pseq_to_list r.value.elements in let m = List.fold_left (fun m (x, y) -> SMap.add x y m) SMap.empty lst in ok @@ T_record m @@ -194,18 +284,20 @@ let rec simpl_expression (t:Raw.expr) : expr result = let n = Z.to_int @@ snd @@ n in return @@ e_literal ~loc (Literal_tez n) ) - | EArith _ -> simple_fail "arith: not supported yet" + | EArith _ as e -> + fail @@ unsupported_arith_op e | EString (String s) -> let (s , loc) = r_split s in let s' = (* S contains quotes *) - String.(sub s 1 ((length s) - 2)) + String.(sub s 1 (length s - 2)) in return @@ e_literal ~loc (Literal_string s') - | EString _ -> simple_fail "string: not supported yet" + | EString (Cat _) as e -> + fail @@ unsupported_string_catenation e | ELogic l -> simpl_logic_expression l | EList l -> simpl_list_expression l - | ESet _ -> simple_fail "set: not supported yet" + | ESet _ -> fail @@ unsupported_set_expr t | ECase c -> ( let (c , loc) = r_split c in let%bind e = simpl_expression c.expr in @@ -224,10 +316,11 @@ let rec simpl_expression (t:Raw.expr) : expr result = let (mi , loc) = r_split mi in let%bind lst = let lst = List.map get_value @@ pseq_to_list mi.elements in - let aux : Raw.binding -> (expression * expression) result = fun b -> - let%bind src = simpl_expression b.source in - let%bind dst = simpl_expression b.image in - ok (src, dst) in + let aux : Raw.binding -> (expression * expression) result = + fun b -> + let%bind src = simpl_expression b.source in + let%bind dst = simpl_expression b.image in + ok (src, dst) in bind_map_list aux lst in return @@ e_map ~loc lst ) @@ -309,26 +402,20 @@ and simpl_tuple_expression ?loc (lst:Raw.expr list) : expression result = match lst with | [] -> return @@ e_literal Literal_unit | [hd] -> simpl_expression hd - | lst -> ( + | lst -> let%bind lst = bind_list @@ List.map simpl_expression lst in return @@ e_tuple ?loc lst - ) and simpl_local_declaration : Raw.local_decl -> _ result = fun t -> match t with - | LocalData d -> simpl_data_declaration d - | LocalLam l -> simpl_lambda_declaration l - -and simpl_lambda_declaration : Raw.lambda_decl -> _ result = fun l -> - match l with - | FunDecl f -> ( + | LocalData d -> + simpl_data_declaration d + | LocalFun f -> let (f , loc) = r_split f in let%bind (name , e) = simpl_fun_declaration ~loc f in return_let_in ~loc name e - ) - | ProcDecl _ -> simple_fail "no local procedure yet" - | EntryDecl _ -> simple_fail "no local entry-point yet" - + | LocalProc d -> + fail @@ unsupported_local_proc d.Region.region and simpl_data_declaration : Raw.data_decl -> _ result = fun t -> match t with | LocalVar x -> @@ -344,7 +431,8 @@ and simpl_data_declaration : Raw.data_decl -> _ result = fun t -> let%bind expression = simpl_expression x.init in return_let_in ~loc (name , Some t) expression -and simpl_param : Raw.param_decl -> (type_name * type_expression) result = fun t -> +and simpl_param : Raw.param_decl -> (type_name * type_expression) result = + fun t -> match t with | ParamConst c -> let c = c.value in @@ -357,11 +445,15 @@ and simpl_param : Raw.param_decl -> (type_name * type_expression) result = fun t let%bind type_expression = simpl_type_expression c.param_type in ok (type_name , type_expression) -and simpl_fun_declaration : loc:_ -> Raw.fun_decl -> ((name * type_expression option) * expression) result = fun ~loc x -> +and simpl_fun_declaration : + loc:_ -> Raw.fun_decl -> ((name * type_expression option) * expression) result = + fun ~loc x -> let open! Raw in let {name;param;ret_type;local_decls;block;return} : fun_decl = x in (match npseq_to_list param.value.inside with - | [] -> simple_fail "function without parameters are not allowed" + | [] -> + fail @@ + corner_case ~loc:__LOC__ "parameter-less function should not exist" | [a] -> ( let%bind input = simpl_param a in let name = name.value in @@ -390,7 +482,7 @@ and simpl_fun_declaration : loc:_ -> Raw.fun_decl -> ((name * type_expression op (arguments_name , type_expression) in let%bind tpl_declarations = 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 ass = return_let_in (fst x , type_) expr in ass @@ -407,12 +499,14 @@ and simpl_fun_declaration : loc:_ -> Raw.fun_decl -> ((name * type_expression op let%bind result = let aux prec cur = cur (Some prec) in bind_fold_right_list aux result body in - let expression = e_lambda ~loc binder (Some input_type) (Some output_type) result in + let expression = + e_lambda ~loc binder (Some input_type) (Some output_type) result in let type_annotation = Some (T_function (input_type, output_type)) in ok ((name.value , type_annotation) , expression) ) ) -and simpl_declaration : Raw.declaration -> declaration Location.wrap result = fun t -> +and simpl_declaration : Raw.declaration -> declaration Location.wrap result = + fun t -> let open! Raw in match t with | TypeDecl x -> ( @@ -434,15 +528,19 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap result = fu let%bind ((name , ty_opt) , expr) = simpl_fun_declaration ~loc x in ok @@ Location.wrap ~loc (Declaration_constant (name , ty_opt , expr)) ) - | LambdaDecl (ProcDecl _) -> simple_fail "no proc declaration yet" - | LambdaDecl (EntryDecl _)-> simple_fail "no entry point yet" + | LambdaDecl (ProcDecl decl) -> + fail @@ unsupported_proc_decl decl + | LambdaDecl (EntryDecl decl) -> + fail @@ unsupported_entry_decl decl -and simpl_statement : Raw.statement -> (_ -> expression result) result = fun s -> +and simpl_statement : Raw.statement -> (_ -> expression result) result = + fun s -> match s with | Instr i -> simpl_instruction i | Data d -> simpl_data_declaration d -and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) result = fun t -> +and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) result = + fun t -> match t with | ProcCall _ -> simple_fail "no proc call" | Fail e -> ( diff --git a/src/simplify/simplify.ml b/src/simplify/simplify.ml index d798d0ed1..0fb8fd3d3 100644 --- a/src/simplify/simplify.ml +++ b/src/simplify/simplify.ml @@ -1,3 +1,2 @@ module Pascaligo = Pascaligo -module Camligo = Camligo module Ligodity = Ligodity diff --git a/src/test/bin_tests.ml b/src/test/bin_tests.ml index cef36ab94..d54239a64 100644 --- a/src/test/bin_tests.ml +++ b/src/test/bin_tests.ml @@ -8,6 +8,6 @@ let compile_contract_basic () : unit result = in ok () -let main = "Bin", [ +let main = test_suite "Bin" [ test "compile contract basic" compile_contract_basic ; ] diff --git a/src/test/coase_tests.ml b/src/test/coase_tests.ml index a0e176a29..2f16212d4 100644 --- a/src/test/coase_tests.ml +++ b/src/test/coase_tests.ml @@ -229,7 +229,7 @@ let sell () = ok () -let main = "Coase (End to End)", [ +let main = test_suite "Coase (End to End)" [ test "buy" buy ; test "dispatch buy" dispatch_buy ; test "transfer" transfer ; diff --git a/src/test/compiler_tests.ml b/src/test/compiler_tests.ml index 2424d0cd4..af26e74d4 100644 --- a/src/test/compiler_tests.ml +++ b/src/test/compiler_tests.ml @@ -28,7 +28,7 @@ let multiple_vars () : unit result = let%bind _ = Assert.assert_equal_int ~msg:__LOC__ 42 result in ok () -let main = "Compiler (from Mini_C)", [ +let main = test_suite "Compiler (from Mini_C)" [ test "identity" identity ; test "multiple_vars" multiple_vars ; ] diff --git a/src/test/heap_tests.ml b/src/test/heap_tests.ml index c52205720..a7be1fbb4 100644 --- a/src/test/heap_tests.ml +++ b/src/test/heap_tests.ml @@ -106,9 +106,9 @@ let pop () : unit result = | Trace.Ok (output , _) -> ( Format.printf "\nPop output on %d : %a\n" n Ast_typed.PP.annotated_expression output ; ) - | Errors errs -> ( + | Trace.Error err -> ( Format.printf "\nPop output on %d : error\n" n) ; - Format.printf "Errors : {\n%a}\n%!" errors_pp (List.rev (List.rev_map (fun f -> f ()) errs)) ; + Format.printf "Errors : {\n%a}\n%!" error_pp (err ()) ; ) ; ok () in @@ -118,7 +118,7 @@ let pop () : unit result = simple_fail "display" (* ok () *) -let main = "Heap (End to End)", [ +let main = test_suite "Heap (End to End)" [ test "is_empty" is_empty ; test "get_top" get_top ; test "pop_switch" pop_switch ; diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 6c8e78eff..e303ac29f 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -456,7 +456,7 @@ let guess_the_hash_mligo () : unit result = let make_expected = fun n -> e_pair (e_typed_list [] t_operation) (e_int (42 + n)) in expect_eq_n program "main" make_input make_expected -let main = "Integration (End to End)", [ +let main = test_suite "Integration (End to End)" [ test "type alias" type_alias ; test "function" function_ ; test "assign" assign ; diff --git a/src/test/test.ml b/src/test/test.ml index c4b9cd3f4..e07209be2 100644 --- a/src/test/test.ml +++ b/src/test/test.ml @@ -1,9 +1,50 @@ (* -*- compile-command: "cd .. ; dune runtest" -*- *) +open Test_helpers + +let rec test_height : test -> int = fun t -> + match t with + | Test _ -> 1 + | Test_suite (_ , lst) -> (List.fold_left max 1 @@ List.map test_height lst) + 1 + +let extract_test : test -> test_case = fun t -> + match t with + | Test tc -> tc + | _ -> assert false + +let extract_param : test -> (string * (string * test_case list) list) = + let extract_element = extract_test in + let extract_group : test -> (string * test_case list) = fun t -> + match t with + | Test tc -> ("isolated" , [ tc ]) + | Test_suite (name , lst) -> (name , List.map extract_element lst) in + fun t -> + match t with + | Test tc -> ("" , [ ("isolated" , [ tc ] ) ]) + | Test_suite (name , lst) -> (name , List.map extract_group lst) + +let x : _ -> (unit Alcotest.test) = fun x -> x + +(* + Alcotest.run parameters: + string * (string * f list) list +*) + +let rec run_test ?(prefix = "") : test -> unit = fun t -> + match t with + | Test case -> Alcotest.run "isolated test" [ ("" , [ case ]) ] + | Test_suite (name , lst) -> ( + if (test_height t <= 3) then ( + let (name , tests) = extract_param t in + Alcotest.run (prefix ^ name) tests + ) else ( + List.iter (run_test ~prefix:(prefix ^ name ^ "_")) lst + ) + ) + let () = (* Printexc.record_backtrace true ; *) - Alcotest.run "LIGO" [ - Multifix_tests.main ; + run_test @@ test_suite "LIGO" [ Integration_tests.main ; Compiler_tests.main ; Transpiler_tests.main ; diff --git a/src/test/test_helpers.ml b/src/test/test_helpers.ml index e1a026af3..03ae9e73d 100644 --- a/src/test/test_helpers.ml +++ b/src/test/test_helpers.ml @@ -1,16 +1,25 @@ open! Trace -let test name f = - Alcotest.test_case name `Quick @@ fun () -> - let result = - trace (fun () -> error (thunk "running test") (thunk name) ()) @@ - f () in - match result with - | Ok ((), annotations) -> ignore annotations; () - | Errors errs -> - Format.printf "Errors : {\n%a}\n%!" errors_pp (List.rev (List.rev_map (fun f -> f ()) errs)) ; - raise Alcotest.Test_error +type test_case = unit Alcotest.test_case +type test = + | Test_suite of (string * test list) + | Test of test_case +let test name f = + Test ( + Alcotest.test_case name `Quick @@ fun () -> + let result = + trace (fun () -> error (thunk "running test") (thunk name) ()) @@ + f () in + match result with + | Ok ((), annotations) -> ignore annotations; () + | Error err -> + Format.printf "Errors : {\n%a}\n%!" error_pp (err ()) ; + raise Alcotest.Test_error + ) + +let test_suite name lst = Test_suite (name , lst) + open Ast_simplified.Combinators let expect ?options program entry_point input expecter = diff --git a/src/test/transpiler_tests.ml b/src/test/transpiler_tests.ml index e0e2abf3b..8b05fe665 100644 --- a/src/test/transpiler_tests.ml +++ b/src/test/transpiler_tests.ml @@ -1,12 +1,7 @@ (* open Ligo_helpers.Trace * open Ligo.Mini_c - * open Combinators - * open Test_helpers *) + * open Combinators *) +open Test_helpers -(* - How should one test the transpiler? - I'm doing the dumb thing. -*) - -let main = "Transpiler (from Ast_typed)", [ +let main = test_suite "Transpiler (from Ast_typed)" [ ] diff --git a/src/test/typer_tests.ml b/src/test/typer_tests.ml index 88bcd1a14..89500c2a7 100644 --- a/src/test/typer_tests.ml +++ b/src/test/typer_tests.ml @@ -65,7 +65,7 @@ end (* TODO: deep types (e.g. record of record) TODO: negative tests (expected type error) *) -let main = "Typer (from simplified AST)", [ +let main = test_suite "Typer (from simplified AST)" [ test "int" int ; test "unit" TestExpressions.unit ; test "int2" TestExpressions.int ; diff --git a/src/transpiler/transpiler.ml b/src/transpiler/transpiler.ml index a146358fa..7da6985e9 100644 --- a/src/transpiler/transpiler.ml +++ b/src/transpiler/transpiler.ml @@ -15,6 +15,76 @@ 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 = match t.type_value' with | T_constant ("bool", []) -> ok (T_base Base_bool) @@ -37,12 +107,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 = @@ -77,23 +142,13 @@ let tuple_access_to_lr : type_value -> type_value list -> int -> (type_value * [ let node_tv = Append_tree.of_list @@ List.mapi (fun i a -> (i, a)) tys in let%bind path = let aux (i , _) = i = ind in - trace_option (simple_error "no leaf with given index") @@ + trace_option (corner_case ~loc:__LOC__ "tuple access leaf") @@ Append_tree.exists_path aux node_tv in let lr_path = List.map (fun b -> if b then `Right else `Left) path in let%bind (_ , lst) = let aux = fun (ty' , acc) cur -> let%bind (a , b) = - let error = - let title () = "expected a pair" in - let content () = Format.asprintf "Big: %a.\tGot: %a\tFull path: %a\tSmall path: %a" - Mini_c.PP.type_ ty - Mini_c.PP.type_ ty' - PP_helpers.(list_sep bool (const ".")) path - PP_helpers.(list_sep lr (const ".")) (List.map snd acc) - in - error title content - in - trace_strong error @@ + trace_strong (corner_case ~loc:__LOC__ "tuple access pair") @@ Mini_c.get_t_pair ty' in match cur with | `Left -> ok (a , acc @ [(a , `Left)]) @@ -107,12 +162,14 @@ let record_access_to_lr : type_value -> type_value AST.type_name_map -> string - let node_tv = Append_tree.of_list tys in let%bind path = let aux (i , _) = i = ind in - trace_option (simple_error "no leaf with given index") @@ + trace_option (corner_case ~loc:__LOC__ "record access leaf") @@ Append_tree.exists_path aux node_tv in let lr_path = List.map (fun b -> if b then `Right else `Left) path in let%bind (_ , lst) = let aux = fun (ty , acc) cur -> - let%bind (a , b) = Mini_c.get_t_pair ty in + let%bind (a , b) = + trace_strong (corner_case ~loc:__LOC__ "recard access pair") @@ + Mini_c.get_t_pair ty in match cur with | `Left -> ok (a , acc @ [(a , `Left)]) | `Right -> ok (b , acc @ [(b , `Right)] ) in @@ -147,7 +204,6 @@ and transpile_small_environment : AST.small_environment -> Environment.t result ok @@ Environment.add (name , tv') prec in let%bind result = - trace (simple_error "transpiling small environment") @@ bind_fold_right_list aux Environment.empty x' in ok result @@ -163,8 +219,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 @@ -176,7 +236,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re | E_literal l -> return @@ E_literal (translate_literal l) | E_variable name -> ( let%bind ele = - trace_option (simple_error "name not in environment") @@ + trace_option (corner_case ~loc:__LOC__ "name not in environment") @@ AST.Environment.get_opt name ae.environment in let%bind tv = transpile_environment_element_type ele in return ~tv @@ E_variable name @@ -185,14 +245,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 +266,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 +287,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 +305,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 +316,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 +336,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 +395,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 +433,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 +457,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 +477,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 +520,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 +527,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 +548,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 +569,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 +583,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 +638,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 +703,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 diff --git a/src/typer/typer.ml b/src/typer/typer.ml index 65dbc66d2..1779837ce 100644 --- a/src/typer/typer.ml +++ b/src/typer/typer.ml @@ -13,39 +13,199 @@ type environment = Environment.t module Errors = struct let unbound_type_variable (e:environment) (n:string) () = let title = (thunk "unbound type variable") in - let full () = Format.asprintf "%s in %a" n Environment.PP.full_environment e in - error title full () + let message () = "" in + let data = [ + ("variable" , fun () -> Format.asprintf "%s" n) ; + (* TODO: types don't have srclocs for now. *) + (* ("location" , fun () -> Format.asprintf "%a" Location.pp (n.location)) ; *) + ("in" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) + ] in + error ~data title message () - let unbound_variable (e:environment) (n:string) () = + let unbound_variable (e:environment) (n:string) (loc:Location.t) () = let title = (thunk "unbound variable") in - let full () = Format.asprintf "%s in %a" n Environment.PP.full_environment e in - error title full () + let message () = "" in + let data = [ + ("variable" , fun () -> Format.asprintf "%s" n) ; + ("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () - let unrecognized_constant (n:string) () = + let match_empty_variant : type a . a I.matching -> Location.t -> unit -> _ = + fun matching loc () -> + let title = (thunk "match with no cases") in + let message () = "" in + let data = [ + ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let match_missing_case : type a . a I.matching -> Location.t -> unit -> _ = + fun matching loc () -> + let title = (thunk "missing case in match") in + let message () = "" in + let data = [ + ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let match_redundant_case : type a . a I.matching -> Location.t -> unit -> _ = + fun matching loc () -> + let title = (thunk "missing case in match") in + let message () = "" in + let data = [ + ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let unbound_constructor (e:environment) (n:string) (loc:Location.t) () = + let title = (thunk "unbound constructor") in + let message () = "" in + let data = [ + ("constructor" , fun () -> Format.asprintf "%s" n) ; + ("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let unrecognized_constant (n:string) (loc:Location.t) () = let title = (thunk "unrecognized constant") in - let full () = n in - error title full () + 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) () = + let wrong_arity (n:string) (expected:int) (actual:int) (loc : Location.t) () = let title () = "wrong arity" in - let full () = - Format.asprintf "Wrong number of args passed to [%s]. Expected was %d, received was %d" - n expected actual - in - error title full () + let message () = "" in + let data = [ + ("function" , fun () -> Format.asprintf "%s" n) ; + ("expected" , fun () -> Format.asprintf "%d" expected) ; + ("actual" , fun () -> Format.asprintf "%d" actual) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + let match_tuple_wrong_arity (expected:'a list) (actual:'b list) (loc:Location.t) () = + let title () = "matching tuple of different size" in + let message () = "" in + let data = [ + ("expected" , fun () -> Format.asprintf "%d" (List.length expected)) ; + ("actual" , fun () -> Format.asprintf "%d" (List.length actual)) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + (* TODO: this should be a trace_info? *) let program_error (p:I.program) () = + let message () = "" in let title = (thunk "typing program") in - let full () = Format.asprintf "%a" I.PP.program p in - error title full () + let data = [ + ("program" , fun () -> Format.asprintf "%a" I.PP.program p) + ] in + error ~data title message () - let constant_declaration_error (name:string) (ae:I.expr) () = + let constant_declaration_error (name:string) (ae:I.expr) (expected: O.type_value option) () = let title = (thunk "typing constant declaration") in - let full () = - Format.asprintf "%s = %a" name - I.PP.expression ae - in - error title full () + let message () = "" in + let data = [ + ("constant" , fun () -> Format.asprintf "%s" name) ; + ("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ; + ("expected" , fun () -> + match expected with + None -> "(no annotation for the expected type)" + | Some expected -> Format.asprintf "%a" O.PP.type_value expected) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp ae.location) + ] in + error ~data title message () + + let match_error : type a . ?msg:string -> expected: a I.matching -> actual: O.type_value -> Location.t -> unit -> _ = + fun ?(msg = "") ~expected ~actual loc () -> + let title = (thunk "typing match") in + let message () = msg in + let data = [ + ("expected" , fun () -> Format.asprintf "%a" I.PP.matching_type expected); + ("actual" , fun () -> Format.asprintf "%a" O.PP.type_value actual) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let needs_annotation (e : I.expression) (case : string) () = + let title = (thunk "this expression must be annotated with its type") in + let message () = Format.asprintf "%s needs an annotation" case in + let data = [ + ("expression" , fun () -> Format.asprintf "%a" I.PP.expression e) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp e.location) + ] in + error ~data title message () + + let type_error_approximate ?(msg="") ~(expected: string) ~(actual: O.type_value) ~(expression : O.value) (loc:Location.t) () = + let title = (thunk "type error") in + let message () = msg in + let data = [ + ("expected" , fun () -> Format.asprintf "%s" expected); + ("actual" , fun () -> Format.asprintf "%a" O.PP.type_value actual); + ("expression" , fun () -> Format.asprintf "%a" O.PP.value expression) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let type_error ?(msg="") ~(expected: O.type_value) ~(actual: O.type_value) ~(expression : O.value) (loc:Location.t) () = + let title = (thunk "type error") in + let message () = msg in + let data = [ + ("expected" , fun () -> Format.asprintf "%a" O.PP.type_value expected); + ("actual" , fun () -> Format.asprintf "%a" O.PP.type_value actual); + ("expression" , fun () -> Format.asprintf "%a" O.PP.value expression) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let bad_tuple_index (index : int) (ae : I.expression) (t : O.type_value) (loc:Location.t) () = + let title = (thunk "invalid tuple index") in + let message () = "" in + let data = [ + ("index" , fun () -> Format.asprintf "%d" index) ; + ("tuple_value" , fun () -> Format.asprintf "%a" I.PP.expression ae) ; + ("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_value t) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let bad_record_access (field : string) (ae : I.expression) (t : O.type_value) (loc:Location.t) () = + let title = (thunk "invalid record field") in + let message () = "" in + let data = [ + ("field" , fun () -> Format.asprintf "%s" field) ; + ("record_value" , fun () -> Format.asprintf "%a" I.PP.expression ae) ; + ("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_value t) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let not_supported_yet (message : string) (ae : I.expression) () = + let title = (thunk "not suported yet") in + let message () = message in + let data = [ + ("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp ae.location) + ] in + error ~data title message () + + let not_supported_yet_untranspile (message : string) (ae : O.expression) () = + let title = (thunk "not suported yet") in + let message () = message in + let data = [ + ("expression" , fun () -> Format.asprintf "%a" O.PP.expression ae) + ] in + error ~data title message () + end open Errors @@ -71,24 +231,24 @@ and type_declaration env : I.declaration -> (environment * O.declaration option) | Declaration_constant (name , tv_opt , expression) -> ( let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in let%bind ae' = - trace (constant_declaration_error name expression) @@ + trace (constant_declaration_error name expression tv'_opt) @@ type_expression ?tv_opt:tv'_opt env expression in let env' = Environment.add_ez_ae name ae' env in ok (env', 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 -> o O.matching result = - fun f e t i -> match i with +and type_match : type i o . (environment -> i -> o result) -> environment -> O.type_value -> i I.matching -> Location.t -> o O.matching result = + fun f e t i loc -> match i with | Match_bool {match_true ; match_false} -> let%bind _ = - trace_strong (simple_error "Matching bool on not-a-bool") + trace_strong (match_error ~expected:i ~actual:t loc) @@ get_t_bool t in let%bind match_true = f e match_true in let%bind match_false = f e match_false in ok (O.Match_bool {match_true ; match_false}) | Match_option {match_none ; match_some} -> let%bind t_opt = - trace_strong (simple_error "Matching option on not-an-option") + trace_strong (match_error ~expected:i ~actual:t loc) @@ get_t_option t in let%bind match_none = f e match_none in let (n, b) = match_some in @@ -98,7 +258,7 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t ok (O.Match_option {match_none ; match_some = (n', b')}) | Match_list {match_nil ; match_cons} -> let%bind t_list = - trace_strong (simple_error "Matching list on not-an-list") + trace_strong (match_error ~expected:i ~actual:t loc) @@ get_t_list t in let%bind match_nil = f e match_nil in let (hd, tl, b) = match_cons in @@ -108,10 +268,10 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t ok (O.Match_list {match_nil ; match_cons = (hd, tl, b')}) | Match_tuple (lst, b) -> let%bind t_tuple = - trace_strong (simple_error "Matching tuple on not-a-tuple") + trace_strong (match_error ~expected:i ~actual:t loc) @@ get_t_tuple t in let%bind lst' = - generic_try (simple_error "Matching tuple of different size") + generic_try (match_tuple_wrong_arity t_tuple lst loc) @@ (fun () -> List.combine lst t_tuple) in let aux prev (name, tv) = Environment.add_ez_binder name tv prev in let e' = List.fold_left aux e lst' in @@ -121,7 +281,7 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t let%bind variant_opt = let aux acc ((constructor_name , _) , _) = let%bind (_ , variant) = - trace_option (simple_error "bad constructor") @@ + trace_option (unbound_constructor e constructor_name loc) @@ Environment.get_constructor constructor_name e in let%bind acc = match acc with | None -> ok (Some variant) @@ -130,30 +290,32 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t ok (Some variant) ) in ok acc in - trace (simple_error "in match variant") @@ + trace (simple_info "in match variant") @@ bind_fold_list aux None lst in let%bind variant = - trace_option (simple_error "empty variant") @@ + trace_option (match_empty_variant i loc) @@ variant_opt in - let%bind () = - let%bind variant_cases' = Ast_typed.Combinators.get_t_sum variant in + let%bind () = + let%bind variant_cases' = + trace (match_error ~expected:i ~actual:t loc) + @@ Ast_typed.Combinators.get_t_sum variant in let variant_cases = List.map fst @@ Map.String.to_kv_list variant_cases' in let match_cases = List.map (Function.compose fst fst) lst in let test_case = fun c -> Assert.assert_true (List.mem c match_cases) in let%bind () = - trace (simple_error "missing case match") @@ + trace_strong (match_missing_case i loc) @@ bind_iter_list test_case variant_cases in let%bind () = - trace_strong (simple_error "redundant case match") @@ + trace_strong (match_redundant_case i loc) @@ Assert.assert_true List.(length variant_cases = length match_cases) in ok () in let%bind lst' = let aux ((constructor_name , name) , b) = let%bind (constructor , _) = - trace_option (simple_error "bad constructor??") @@ + trace_option (unbound_constructor e constructor_name loc) @@ Environment.get_constructor constructor_name e in let e' = Environment.add_ez_binder name constructor e in let%bind b' = f e' b in @@ -219,10 +381,10 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a trace main_error @@ match Location.unwrap ae with (* Basic *) - | E_failwith _ -> simple_fail "can't type failwith in isolation" + | E_failwith _ -> fail @@ needs_annotation ae "the failwith keyword" | E_variable name -> let%bind tv' = - trace_option (unbound_variable e name) + trace_option (unbound_variable e name ae.location) @@ Environment.get_opt name e in return (E_variable name) tv'.type_value | E_literal (Literal_bool b) -> @@ -252,33 +414,33 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a let%bind lst' = bind_list @@ List.map (type_expression e) lst in let tv_lst = List.map get_type_annotation lst' in return (E_tuple lst') (t_tuple tv_lst ()) - | E_accessor (ae, path) -> - let%bind e' = type_expression e ae in + | E_accessor (ae', path) -> + let%bind e' = type_expression e ae' in let aux (prev:O.annotated_expression) (a:I.access) : O.annotated_expression result = match a with | Access_tuple index -> ( let%bind tpl_tv = get_t_tuple prev.type_annotation in let%bind tv = - generic_try (simple_error "bad tuple index") + generic_try (bad_tuple_index index ae' prev.type_annotation ae.location) @@ (fun () -> List.nth tpl_tv index) in return (E_tuple_accessor (prev , index)) tv ) | Access_record property -> ( let%bind r_tv = get_t_record prev.type_annotation in let%bind tv = - generic_try (simple_error "bad record index") + generic_try (bad_record_access property ae' prev.type_annotation ae.location) @@ (fun () -> SMap.find property r_tv) in return (E_record_accessor (prev , property)) tv ) - | Access_map ae -> ( - let%bind ae' = type_expression e ae in + | Access_map ae' -> ( + let%bind ae'' = type_expression e ae' in let%bind (k , v) = get_t_map prev.type_annotation in let%bind () = - Ast_typed.assert_type_value_eq (k , get_type_annotation ae') in - return (E_look_up (prev , ae')) v + Ast_typed.assert_type_value_eq (k , get_type_annotation ae'') in + return (E_look_up (prev , ae'')) v ) in - trace (simple_error "accessing") @@ + trace (simple_info "accessing") @@ bind_fold_list aux e' path (* Sum *) @@ -322,7 +484,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a let%bind ty = let%bind opt = bind_fold_list aux init @@ List.map get_type_annotation lst' in - trace_option (simple_error "empty list expression without annotation") opt in + trace_option (needs_annotation ae "empty list") opt in ok (t_list ty ()) in return (E_list lst') tv @@ -341,7 +503,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a @@ List.map get_type_annotation @@ List.map fst lst' in let%bind annot = bind_map_option get_t_map_key tv_opt in - trace (simple_error "untyped empty map expression") @@ + trace (simple_info "empty map expression without a type annotation") @@ O.merge_annotation annot sub in let%bind value_type = @@ -350,7 +512,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a @@ List.map get_type_annotation @@ List.map snd lst' in let%bind annot = bind_map_option get_t_map_value tv_opt in - trace (simple_error "untyped empty map expression") @@ + trace (simple_info "empty map expression without a type annotation") @@ O.merge_annotation annot sub in ok (t_map key_type value_type ()) @@ -365,7 +527,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a let%bind input_type = let%bind input_type = (* Hack to take care of let_in introduced by `simplify/ligodity.ml` in ECase's hack *) - let default_action () = simple_fail "no input type provided" in + let default_action e () = fail @@ (needs_annotation e "the returned value") in match input_type with | Some ty -> ok ty | None -> ( @@ -375,11 +537,11 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a | I.E_variable name when name = (fst binder) -> ( match snd li.binder with | Some ty -> ok ty - | None -> default_action () + | None -> default_action li.rhs () ) - | _ -> default_action () + | _ -> default_action li.rhs () ) - | _ -> default_action () + | _ -> default_action result () ) in evaluate_type e input_type in @@ -394,7 +556,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a | E_constant (name, lst) -> let%bind lst' = bind_list @@ List.map (type_expression e) lst in let tv_lst = List.map get_type_annotation lst' in - let%bind (name', tv) = type_constant name tv_lst tv_opt in + let%bind (name', tv) = type_constant name tv_lst tv_opt ae.location in return (E_constant (name' , lst')) tv | E_application (f, arg) -> let%bind f = type_expression e f in @@ -403,7 +565,12 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a | T_function (param, result) -> let%bind _ = O.assert_type_value_eq (param, arg.type_annotation) in ok result - | _ -> simple_fail "applying to not-a-function" + | _ -> + fail @@ type_error_approximate + ~expected:"should be a function type" + ~expression:f + ~actual:f.type_annotation + f.location in return (E_application (f , arg)) tv | E_look_up dsi -> @@ -420,11 +587,16 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a let%bind fw = I.get_e_failwith match_true in let%bind fw' = type_expression e fw in let%bind mf' = type_expression e match_false in + let t = get_type_annotation ex' in let%bind () = - trace_strong (simple_error "Matching bool on not-a-bool") - @@ assert_t_bool (get_type_annotation ex') in + trace_strong (match_error ~expected:m ~actual:t ae.location) + @@ assert_t_bool t in let%bind () = - trace_strong (simple_error "Matching not-unit on an assert") + trace_strong (match_error + ~msg:"matching not-unit on an assert" + ~expected:m + ~actual:t + ae.location) @@ assert_t_unit (get_type_annotation mf') in let mt' = make_a_e (E_constant ("ASSERT" , [ex' ; fw'])) @@ -435,7 +607,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a return (O.E_matching (ex' , m')) (t_unit ()) ) | _ -> ( - let%bind m' = type_match (type_expression ?tv_opt:None) e ex'.type_annotation m in + let%bind m' = type_match (type_expression ?tv_opt:None) e ex'.type_annotation m ae.location in let tvs = let aux (cur:O.value O.matching) = match cur with @@ -453,7 +625,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a ok (Some cur) in let%bind tv_opt = bind_fold_list aux None tvs in let%bind tv = - trace_option (simple_error "empty matching") @@ + trace_option (match_empty_variant m ae.location) @@ tv_opt in return (O.E_matching (ex', m')) tv ) @@ -461,19 +633,37 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a | E_sequence (a , b) -> let%bind a' = type_expression e a in let%bind b' = type_expression e b in + let a'_type_annot = get_type_annotation a' in let%bind () = - trace_strong (simple_error "first part of the sequence isn't of unit type") @@ - Ast_typed.assert_type_value_eq (t_unit () , get_type_annotation a') in + trace_strong (type_error + ~msg:"first part of the sequence should be of unit type" + ~expected:(O.t_unit ()) + ~actual:a'_type_annot + ~expression:a' + a'.location) @@ + Ast_typed.assert_type_value_eq (t_unit () , a'_type_annot) in return (O.E_sequence (a' , b')) (get_type_annotation b') | E_loop (expr , body) -> let%bind expr' = type_expression e expr in let%bind body' = type_expression e body in + let t_expr' = get_type_annotation expr' in let%bind () = - trace_strong (simple_error "while condition isn't of type bool") @@ - Ast_typed.assert_type_value_eq (t_bool () , get_type_annotation expr') in + trace_strong (type_error + ~msg:"while condition isn't of type bool" + ~expected:(O.t_bool ()) + ~actual:t_expr' + ~expression:expr' + expr'.location) @@ + Ast_typed.assert_type_value_eq (t_bool () , t_expr') in + let t_body' = get_type_annotation body' in let%bind () = - trace_strong (simple_error "while body isn't of unit type") @@ - Ast_typed.assert_type_value_eq (t_unit () , get_type_annotation body') in + trace_strong (type_error + ~msg:"while body isn't of unit type" + ~expected:(O.t_unit ()) + ~actual:t_body' + ~expression:body' + body'.location) @@ + Ast_typed.assert_type_value_eq (t_unit () , t_body') in return (O.E_loop (expr' , body')) (t_unit ()) | E_assign (name , path , expr) -> let%bind typed_name = @@ -485,24 +675,31 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a | Access_tuple index -> ( let%bind tpl = get_t_tuple prec_tv in let%bind tv' = - trace_option (simple_error "tuple too small") @@ + trace_option (bad_tuple_index index ae prec_tv ae.location) @@ List.nth_opt tpl index in ok (tv' , prec_path @ [O.Access_tuple index]) ) | Access_record property -> ( let%bind m = get_t_record prec_tv in let%bind tv' = - trace_option (simple_error "tuple too small") @@ + trace_option (bad_record_access property ae prec_tv ae.location) @@ Map.String.find_opt property m in ok (tv' , prec_path @ [O.Access_record property]) ) - | Access_map _ -> simple_fail "no assign expressions with maps yet" + | Access_map _ -> + fail @@ not_supported_yet "assign expressions with maps are not supported yet" ae in bind_fold_list aux (typed_name.type_value , []) path in let%bind expr' = type_expression e expr in + let t_expr' = get_type_annotation expr' in let%bind () = - trace_strong (simple_error "assign type doesn't match left-hand-side") @@ - Ast_typed.assert_type_value_eq (assign_tv , get_type_annotation expr') in + trace_strong (type_error + ~msg:"type of the expression to assign doesn't match left-hand-side" + ~expected:assign_tv + ~actual:t_expr' + ~expression:expr' + expr'.location) @@ + Ast_typed.assert_type_value_eq (assign_tv , t_expr') in return (O.E_assign (typed_name , path' , expr')) (t_unit ()) | E_let_in {binder ; rhs ; result} -> let%bind rhs_tv_opt = bind_map_option (evaluate_type e) (snd binder) in @@ -517,11 +714,11 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a ok {expr' with type_annotation} -and type_constant (name:string) (lst:O.type_value list) (tv_opt:O.type_value option) : (string * O.type_value) result = +and type_constant (name:string) (lst:O.type_value list) (tv_opt:O.type_value option) (loc : Location.t) : (string * O.type_value) result = (* Constant poorman's polymorphism *) let ct = Operators.Typer.constant_typers in let%bind typer = - trace_option (unrecognized_constant name) @@ + trace_option (unrecognized_constant name loc) @@ Map.String.find_opt name ct in typer lst tv_opt @@ -599,7 +796,7 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result = return (e_failwith ae') | E_sequence _ | E_loop _ - | E_assign _ -> simple_fail "not possible to untranspile statements yet" + | E_assign _ -> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e.expression | E_let_in {binder;rhs;result} -> let%bind tv = untype_type_value rhs.type_annotation in let%bind rhs = untype_expression rhs in diff --git a/vendors/ligo-utils/proto-alpha-utils/trace.ml b/vendors/ligo-utils/proto-alpha-utils/trace.ml index 37a45b628..53cffe354 100644 --- a/vendors/ligo-utils/proto-alpha-utils/trace.ml +++ b/vendors/ligo-utils/proto-alpha-utils/trace.ml @@ -12,7 +12,7 @@ let of_alpha_tz_error err = of_tz_error (AE.Ecoproto_error err) let trace_alpha_tzresult err : 'a AE.Error_monad.tzresult -> 'a result = function | Result.Ok x -> ok x - | Error errs -> Errors (err :: List.map of_alpha_tz_error errs) + | Error errs -> fail @@ thunk @@ patch_children (List.map of_alpha_tz_error errs) (err ()) let trace_alpha_tzresult_lwt error (x:_ AE.Error_monad.tzresult Lwt.t) : _ result = trace_alpha_tzresult error @@ Lwt_main.run x @@ -20,21 +20,20 @@ let trace_alpha_tzresult_lwt error (x:_ AE.Error_monad.tzresult Lwt.t) : _ resul let trace_tzresult err = function | Result.Ok x -> ok x - | Error errs -> Errors (err :: List.map of_tz_error errs) + | Error errs -> fail @@ thunk @@ patch_children (List.map of_tz_error errs) (err ()) (* TODO: should be a combination of trace_tzresult and trace_r *) let trace_tzresult_r err_thunk_may_fail = function | Result.Ok x -> ok x - | Error errs -> - let tz_errs = List.map of_tz_error errs in + | Error _errs -> + (* let tz_errs = List.map of_tz_error errs in *) match err_thunk_may_fail () with - | Simple_utils.Trace.Ok (err, annotations) -> ignore annotations; Errors (err :: tz_errs) - | Errors errors_while_generating_error -> + | Simple_utils.Trace.Ok (err, annotations) -> ignore annotations; Error (err) + | Error errors_while_generating_error -> (* TODO: the complexity could be O(n*n) in the worst case, this should use some catenable lists. *) - Errors (errors_while_generating_error - @ tz_errs) + Error (errors_while_generating_error) let trace_tzresult_lwt err (x:_ TP.Error_monad.tzresult Lwt.t) : _ result = trace_tzresult err @@ Lwt_main.run x diff --git a/vendors/ligo-utils/simple-utils/location.ml b/vendors/ligo-utils/simple-utils/location.ml index 27ecec4f3..7087fe899 100644 --- a/vendors/ligo-utils/simple-utils/location.ml +++ b/vendors/ligo-utils/simple-utils/location.ml @@ -12,6 +12,12 @@ type t = | File of Region.t (* file_location *) | Virtual of virtual_location +let pp = fun ppf t -> + match t with + | Virtual s -> Format.fprintf ppf "%s" s + | File f -> Format.fprintf ppf "%s" (f#to_string `Point) + + let make (start_pos:Lexing.position) (end_pos:Lexing.position) : t = (* TODO: give correct unicode offsets (the random number is here so that searching for wrong souce locations appearing in messages @@ -38,6 +44,7 @@ let pp_wrap f ppf { wrap_content ; _ } = Format.fprintf ppf "%a" f wrap_content let lift_region : 'a Region.reg -> 'a wrap = fun x -> wrap ~loc:(File x.region) x.value let lift : Region.region -> t = fun x -> File x +let pp_lift = fun ppf r -> pp ppf @@ lift r let r_extract : 'a Region.reg -> t = fun x -> File x.region let r_split : 'a Region.reg -> ('a * t) = fun x -> x.value , File x.region diff --git a/vendors/ligo-utils/simple-utils/trace.ml b/vendors/ligo-utils/simple-utils/trace.ml index 73dd56366..c175b4149 100644 --- a/vendors/ligo-utils/simple-utils/trace.ml +++ b/vendors/ligo-utils/simple-utils/trace.ml @@ -3,8 +3,23 @@ module J = Yojson.Basic module JSON_string_utils = struct let member = J.Util.member let string = J.Util.to_string_option + let to_list_option = fun x -> + try ( Some (J.Util.to_list x)) + with _ -> None + let to_assoc_option = fun x -> + try ( Some (J.Util.to_assoc x)) + with _ -> None + let list = to_list_option + let assoc = to_assoc_option let int = J.Util.to_int_option + let patch j k v = + match assoc j with + | None -> j + | Some assoc -> `Assoc ( + List.map (fun (k' , v') -> (k' , if k = k' then v else v')) assoc + ) + let swap f l r = f r l let unit x = Some x @@ -60,15 +75,15 @@ type annotation_thunk = annotation thunk point. *) type 'a result = - Ok of 'a * annotation_thunk list - | Errors of error_thunk list + | Ok of 'a * annotation_thunk list + | Error of error_thunk (** Constructors *) let ok x = Ok (x, []) -let fail err = Errors [err] +let fail err = Error err (** Monadic operators @@ -77,12 +92,12 @@ let bind f = function | Ok (x, annotations) -> (match f x with Ok (x', annotations') -> Ok (x', annotations' @ annotations) - | Errors _ as e' -> ignore annotations; e') - | Errors _ as e -> e + | Error _ as e' -> ignore annotations; e') + | Error _ as e -> e let map f = function | Ok (x, annotations) -> Ok (f x, annotations) - | Errors _ as e -> e + | Error _ as e -> e (** Usual bind-syntax is `>>=`, but this is taken from the Tezos code base. Where @@ -125,6 +140,7 @@ let thunk x () = x let mk_error ?(error_code : int thunk option) ?(message : string thunk option) ?(data : (string * string thunk) list option) + ?(children = []) ?(infos = []) ~(title : string thunk) () : error = let error_code' = X_option.map (fun x -> ("error_code" , `Int (x ()))) error_code in let title' = X_option.some ("title" , `String (title ())) in @@ -132,14 +148,57 @@ let mk_error let aux (key , value) = (key , `String (value ())) in X_option.map (fun x -> ("data" , `Assoc (List.map aux x))) data in let message' = X_option.map (fun x -> ("message" , `String (x ()))) message in - `Assoc (X_option.collapse_list [ error_code' ; title' ; message' ; data' ]) + let type' = Some ("type" , `String "error") in + let children' = Some ("children" , `List children) in + let infos' = Some ("infos" , `List infos) in + `Assoc (X_option.collapse_list [ error_code' ; title' ; message' ; data' ; type' ; children' ; infos' ]) + +let error ?data ?error_code ?children ?infos title message () = mk_error ?data ?error_code ?children ?infos ~title:(title) ~message:(message) () + +let prepend_child = fun child err -> + let open JSON_string_utils in + let children_opt = err |> member "children" |> list in + let children = match children_opt with + | Some children -> (child ()) :: children + | None -> [ child () ] in + patch err "children" (`List children) + +let patch_children = fun children err -> + let open JSON_string_utils in + patch err "children" (`List (List.map (fun f -> f ()) children)) + +(** + Build a standard info, with a title, a message, an info code and some data. +*) +let mk_info + ?(info_code : int thunk option) ?(message : string thunk option) + ?(data : (string * string thunk) list option) + ~(title : string thunk) () : error = + let error_code' = X_option.map (fun x -> ("error_code" , `Int (x ()))) info_code in + let title' = X_option.some ("title" , `String (title ())) in + let data' = + let aux (key , value) = (key , `String (value ())) in + X_option.map (fun x -> ("data" , `Assoc (List.map aux x))) data in + let message' = X_option.map (fun x -> ("message" , `String (x ()))) message in + let type' = Some ("type" , `String "info") in + `Assoc (X_option.collapse_list [ error_code' ; title' ; message' ; data' ; type' ]) + +let info ?data ?info_code title message () = mk_info ?data ?info_code ~title:(title) ~message:(message) () + +let prepend_info = fun info err -> + let open JSON_string_utils in + let infos_opt = err |> member "infos" |> list in + let infos = match infos_opt with + | Some infos -> info :: infos + | None -> [ info ] in + patch err "infos" (`List infos) -let error ?data ?error_code title message () = mk_error ?data ?error_code ~title:(title) ~message:(message) () (** Helpers that ideally shouldn't be used in production. *) let simple_error str () = mk_error ~title:(thunk str) () +let simple_info str () = mk_info ~title:(thunk str) () let simple_fail str = fail @@ simple_error str (** @@ -176,31 +235,62 @@ let dummy_fail = simple_fail "dummy" ``` And this will pass along the error triggered by "get key map". *) -let trace err = function +let trace info = function | Ok _ as o -> o - | Errors errs -> Errors (err :: errs) + | Error err -> Error (fun () -> prepend_info (info ()) (err ())) (** Erase the current error stack, and replace it by the given error. It's useful - when using `Asserts` and you want to discard its auto-generated message. + when using `Assert` and you want to discard its auto-generated message. *) let trace_strong err = function | Ok _ as o -> o - | Errors _ -> Errors [err] + | Error _ -> Error err + +(** + Sometimes, when you have a list of potentially erroneous elements, you need + to retrieve all the errors, instead of just the first one. In that case, do: + ``` + let type_list lst = + let%bind lst' = + trace_list (simple_error "Error while typing a list") @@ + List.map type_element lst in + ... + ``` + Where before you would have written: + ``` + let type_list lst = + let%bind lst' = bind_map_list type_element lst in + ... + ``` +*) +let trace_list err lst = + let oks = + let aux = function + | Ok (x , _) -> Some x + | _ -> None in + X_list.filter_map aux lst in + let errs = + let aux = function + | Error x -> Some x + | _ -> None in + X_list.filter_map aux lst in + match errs with + | [] -> ok oks + | errs -> fail (fun () -> patch_children errs err) (** Trace, but with an error which generation may itself fail. *) let trace_r err_thunk_may_fail = function | Ok _ as o -> o - | Errors errs -> ( + | Error _ -> ( match err_thunk_may_fail () with - | Ok (err, annotations) -> ignore annotations; Errors (err :: errs) - | Errors errors_while_generating_error -> + | Ok (err, annotations) -> ignore annotations; Error (err) + | Error errors_while_generating_error -> (* TODO: the complexity could be O(n*n) in the worst case, this should use some catenable lists. *) - Errors (errors_while_generating_error - @ errs) + Error (errors_while_generating_error) ) (** @@ -231,11 +321,11 @@ let trace_f_2_ez f name = *) let to_bool = function | Ok _ -> true - | Errors _ -> false + | Error _ -> false let to_option = function | Ok (o, annotations) -> ignore annotations; Some o - | Errors _ -> None + | Error _ -> None (** Convert an option to a result, with a given error if the parameter is None. @@ -267,7 +357,8 @@ let rec bind_list = function hd >>? fun hd -> bind_list tl >>? fun tl -> ok @@ hd :: tl - ) + ) + let bind_ne_list = fun (hd , tl) -> hd >>? fun hd -> bind_list tl >>? fun tl -> @@ -341,7 +432,7 @@ let bind_find_map_list error f lst = | [] -> fail error | hd :: tl -> ( match f hd with - | Errors _ -> aux tl + | Error _ -> aux tl | o -> o ) in @@ -360,7 +451,7 @@ let bind_lr (type a b) ((a : a result), (b:b result)) : [`Left of a | `Right of match (a, b) with | (Ok _ as o), _ -> map (fun x -> `Left x) o | _, (Ok _ as o) -> map (fun x -> `Right x) o - | _, Errors b -> Errors b + | _, Error b -> Error b let bind_lr_lazy (type a b) ((a : a result), (b:unit -> b result)) : [`Left of a | `Right of b] result = match a with @@ -368,7 +459,7 @@ let bind_lr_lazy (type a b) ((a : a result), (b:unit -> b result)) : [`Left of a | _ -> ( match b() with | Ok _ as o -> map (fun x -> `Right x) o - | Errors b -> Errors b + | Error b -> Error b ) let bind_and (a, b) =