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

I forbade local entry points in Pascaligo (meaningless).

Browse Source 
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.
This commit is contained in:
Christian Rinderknecht 2019-06-04 16:12:17 +02:00
parent 8562586bbd
commit 97dd2db4b8
8 changed files with 186 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
src/parser/ligodity/AST.ml
View File

@ -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; _}

6
src/parser/ligodity/AST.mli
View File

@ -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 *)

8
src/parser/pascaligo/AST.ml
View File

@ -315,7 +315,8 @@ and statement =
| Data of data_decl
and local_decl =
LocalLam of lambda_decl
LocalFun of fun_decl reg
| LocalProc of proc_decl reg
| LocalData of data_decl
and data_decl =
@ -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

3
src/parser/pascaligo/AST.mli
View File

@ -299,7 +299,8 @@ and statement =
| Data of data_decl
and local_decl =
LocalLam of lambda_decl
LocalFun of fun_decl reg
| LocalProc of proc_decl reg
| LocalData of data_decl
and data_decl =

3
src/parser/pascaligo/Parser.mly
View File

@ -426,7 +426,8 @@ open_var_decl:
in {region; value}}
local_decl:
lambda_decl { LocalLam $1 }
fun_decl { LocalFun $1 }
| proc_decl { LocalProc $1 }
| data_decl { LocalData $1 }
data_decl:

3
src/parser/pascaligo/ParserLog.ml
View File

@ -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

32
src/simplify/ligodity.ml
View File

@ -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

156
src/simplify/pascaligo.ml
View File

@ -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,7 +316,8 @@ 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 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
@ -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
@ -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 -> (