From 97dd2db4b84f18869b4d4c6c66eb3a67f42c90f2 Mon Sep 17 00:00:00 2001 From: Christian Rinderknecht Date: Tue, 4 Jun 2019 16:12:17 +0200 Subject: [PATCH] I forbade local entry points in Pascaligo (meaningless). I refactored the projections in Ligodity (AST), so they have the same name and types as in Pascaligo, which will ease the creation of module CommonErrors in a file. --- src/parser/ligodity/AST.ml | 35 ++++--- src/parser/ligodity/AST.mli | 6 +- src/parser/pascaligo/AST.ml | 10 +- src/parser/pascaligo/AST.mli | 5 +- src/parser/pascaligo/Parser.mly | 5 +- src/parser/pascaligo/ParserLog.ml | 3 +- src/simplify/ligodity.ml | 32 ++++-- src/simplify/pascaligo.ml | 164 ++++++++++++++++++++++++------ 8 files changed, 186 insertions(+), 74 deletions(-) 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/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/ligodity.ml b/src/simplify/ligodity.ml index eb4caebcd..e938ad285 100644 --- a/src/simplify/ligodity.ml +++ b/src/simplify/ligodity.ml @@ -23,7 +23,7 @@ module Errors = struct let message () = "" in let data = [ ("expected", fun () -> expected_name); - ("actual_loc" , fun () -> Format.asprintf "%a" Location.pp_lift @@ Raw.region_of_pattern actual) + ("actual_loc" , fun () -> Format.asprintf "%a" Location.pp_lift @@ Raw.pattern_to_region actual) ] in error ~data title message @@ -32,7 +32,7 @@ module Errors = struct 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.region_of_pattern p)) + 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) @@ -53,7 +53,7 @@ module Errors = struct let title () = "arithmetic expressions" in let message () = Format.asprintf "this arithmetic operator is not supported yet" in - let expr_loc = Raw.region_of_expr expr in + let expr_loc = Raw.expr_to_region expr in let data = [ ("expr_loc", fun () -> Format.asprintf "%a" Location.pp_lift @@ expr_loc) @@ -64,7 +64,7 @@ module Errors = struct let title () = "string expressions" in let message () = Format.asprintf "string concatenation is not supported yet" in - let expr_loc = Raw.region_of_expr expr in + let expr_loc = Raw.expr_to_region expr in let data = [ ("expr_loc", fun () -> Format.asprintf "%a" Location.pp_lift @@ expr_loc) @@ -86,7 +86,7 @@ module Errors = struct let title () = "tuple pattern" in let message () = Format.asprintf "tuple patterns are not supported yet" in - let pattern_loc = Raw.region_of_pattern p in + let pattern_loc = Raw.pattern_to_region p in let data = [ ("pattern_loc", fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc) @@ -97,7 +97,7 @@ module Errors = struct let title () = "constant constructor" in let message () = Format.asprintf "constant constructors are not supported yet" in - let pattern_loc = Raw.region_of_pattern p in + let pattern_loc = Raw.pattern_to_region p in let data = [ ("pattern_loc", fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc) @@ -109,7 +109,7 @@ module Errors = struct let message () = Format.asprintf "non-variable patterns in constructors \ are not supported yet" in - let pattern_loc = Raw.region_of_pattern p in + let pattern_loc = Raw.pattern_to_region p in let data = [ ("pattern_loc", fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc) @@ -129,7 +129,7 @@ module Errors = struct let title () = "constructors in patterns" in let message () = Format.asprintf "currently, only constructors are supported in patterns" in - let pattern_loc = Raw.region_of_pattern p in + let pattern_loc = Raw.pattern_to_region p in let data = [ ("pattern_loc", fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc) @@ -146,6 +146,18 @@ module Errors = struct 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 @@ -559,14 +571,14 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap result = 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 bindings" + | [] -> fail @@ corner_case ~loc:__LOC__ "let without bindings" | hd :: tl -> ok (hd , tl) in let%bind var = pattern_to_var hd in 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 -> (