Merge branch 'rinderknecht-dev' into 'dev'
Moved stuff to module [SyntaxError] from [AST] and [Parser]. See merge request ligolang/ligo!317
This commit is contained in:
Christian Rinderknecht
commit
3b5c25114d
@ -28,6 +28,15 @@ module Errors = struct
|
||||
] in
|
||||
error ~data title message
|
||||
|
||||
let non_linear_pattern Region.{value; region} =
|
||||
let title () = Printf.sprintf "repeated variable \"%s\" in this pattern" value in
|
||||
let message () = "" in
|
||||
let data = [
|
||||
("location",
|
||||
fun () -> Format.asprintf "%a" Location.pp_lift @@ region)
|
||||
] in
|
||||
error ~data title message
|
||||
|
||||
let duplicate_parameter Region.{value; region} =
|
||||
let title () = Printf.sprintf "duplicate parameter \"%s\"" value in
|
||||
let message () = "" in
|
||||
@ -118,7 +127,9 @@ let parse (parser: 'a parser) source lexbuf =
|
||||
try
|
||||
ok (parser read lexbuf)
|
||||
with
|
||||
SyntaxError.Error (Duplicate_parameter name) ->
|
||||
SyntaxError.Error (Non_linear_pattern var) ->
|
||||
fail @@ (non_linear_pattern var)
|
||||
| SyntaxError.Error (Duplicate_parameter name) ->
|
||||
fail @@ (duplicate_parameter name)
|
||||
| SyntaxError.Error (Duplicate_variant name) ->
|
||||
fail @@ (duplicate_variant name)
|
||||
|
||||
@ -2,7 +2,7 @@
|
||||
|
||||
(* To disable warning about multiply-defined record labels. *)
|
||||
|
||||
[@@@warning "-30-42"]
|
||||
[@@@warning "-30-40-42"]
|
||||
|
||||
(* Utilities *)
|
||||
|
||||
@ -21,22 +21,6 @@ open Utils
|
||||
|
||||
type 'a reg = 'a Region.reg
|
||||
|
||||
let rec last to_region = function
|
||||
[] -> Region.ghost
|
||||
| [x] -> to_region x
|
||||
| _::t -> last to_region t
|
||||
|
||||
let nseq_to_region to_region (hd,tl) =
|
||||
Region.cover (to_region hd) (last to_region tl)
|
||||
|
||||
let nsepseq_to_region to_region (hd,tl) =
|
||||
let reg (_, item) = to_region item in
|
||||
Region.cover (to_region hd) (last reg tl)
|
||||
|
||||
let sepseq_to_region to_region = function
|
||||
None -> Region.ghost
|
||||
| Some seq -> nsepseq_to_region to_region seq
|
||||
|
||||
(* Keywords of LIGO *)
|
||||
|
||||
type keyword = Region.t
|
||||
@ -85,32 +69,32 @@ type c_Unit = Region.t
|
||||
|
||||
(* Symbols *)
|
||||
|
||||
type semi = Region.t
|
||||
type comma = Region.t
|
||||
type lpar = Region.t
|
||||
type rpar = Region.t
|
||||
type lbrace = Region.t
|
||||
type rbrace = Region.t
|
||||
type lbracket = Region.t
|
||||
type rbracket = Region.t
|
||||
type cons = Region.t
|
||||
type vbar = Region.t
|
||||
type arrow = Region.t
|
||||
type assign = Region.t
|
||||
type equal = Region.t
|
||||
type colon = Region.t
|
||||
type lt = Region.t
|
||||
type leq = Region.t
|
||||
type gt = Region.t
|
||||
type geq = Region.t
|
||||
type neq = Region.t
|
||||
type plus = Region.t
|
||||
type minus = Region.t
|
||||
type slash = Region.t
|
||||
type times = Region.t
|
||||
type dot = Region.t
|
||||
type wild = Region.t
|
||||
type cat = Region.t
|
||||
type semi = Region.t (* ";" *)
|
||||
type comma = Region.t (* "," *)
|
||||
type lpar = Region.t (* "(" *)
|
||||
type rpar = Region.t (* ")" *)
|
||||
type lbrace = Region.t (* "{" *)
|
||||
type rbrace = Region.t (* "}" *)
|
||||
type lbracket = Region.t (* "[" *)
|
||||
type rbracket = Region.t (* "]" *)
|
||||
type cons = Region.t (* "#" *)
|
||||
type vbar = Region.t (* "|" *)
|
||||
type arrow = Region.t (* "->" *)
|
||||
type assign = Region.t (* ":=" *)
|
||||
type equal = Region.t (* "=" *)
|
||||
type colon = Region.t (* ":" *)
|
||||
type lt = Region.t (* "<" *)
|
||||
type leq = Region.t (* "<=" *)
|
||||
type gt = Region.t (* ">" *)
|
||||
type geq = Region.t (* ">=" *)
|
||||
type neq = Region.t (* "=/=" *)
|
||||
type plus = Region.t (* "+" *)
|
||||
type minus = Region.t (* "-" *)
|
||||
type slash = Region.t (* "/" *)
|
||||
type times = Region.t (* "*" *)
|
||||
type dot = Region.t (* "." *)
|
||||
type wild = Region.t (* "_" *)
|
||||
type cat = Region.t (* "^" *)
|
||||
|
||||
(* Virtual tokens *)
|
||||
|
||||
@ -613,9 +597,24 @@ and list_pattern =
|
||||
| PParCons of (pattern * cons * pattern) par reg
|
||||
| PCons of (pattern, cons) nsepseq reg
|
||||
|
||||
|
||||
(* Projecting regions *)
|
||||
|
||||
open! Region
|
||||
let rec last to_region = function
|
||||
[] -> Region.ghost
|
||||
| [x] -> to_region x
|
||||
| _::t -> last to_region t
|
||||
|
||||
let nseq_to_region to_region (hd,tl) =
|
||||
Region.cover (to_region hd) (last to_region tl)
|
||||
|
||||
let nsepseq_to_region to_region (hd,tl) =
|
||||
let reg (_, item) = to_region item in
|
||||
Region.cover (to_region hd) (last reg tl)
|
||||
|
||||
let sepseq_to_region to_region = function
|
||||
None -> Region.ghost
|
||||
| Some seq -> nsepseq_to_region to_region seq
|
||||
|
||||
let type_expr_to_region = function
|
||||
TProd {region; _}
|
||||
@ -760,49 +759,4 @@ let rhs_to_region = expr_to_region
|
||||
|
||||
let selection_to_region = function
|
||||
FieldName {region; _}
|
||||
| Component {region; _} -> region
|
||||
|
||||
(* Extracting variables from patterns *)
|
||||
|
||||
module Ord =
|
||||
struct
|
||||
type t = string Region.reg
|
||||
let compare v1 v2 =
|
||||
compare v1.value v2.value
|
||||
end
|
||||
|
||||
module VSet = Set.Make (Ord)
|
||||
|
||||
let rec vars_of_pattern env = function
|
||||
PConstr p -> vars_of_pconstr env p
|
||||
| PVar v -> VSet.add v env
|
||||
| PWild _ | PInt _ | PNat _ | PBytes _ | PString _ -> env
|
||||
| PList l -> vars_of_plist env l
|
||||
| PTuple t -> vars_of_ptuple env t.value
|
||||
|
||||
and vars_of_pconstr env = function
|
||||
PUnit _ | PFalse _ | PTrue _ | PNone _ -> env
|
||||
| PSomeApp {value=_, {value={inside; _};_}; _} ->
|
||||
vars_of_pattern env inside
|
||||
| PConstrApp {value=_, Some tuple; _} ->
|
||||
vars_of_ptuple env tuple.value
|
||||
| PConstrApp {value=_,None; _} -> env
|
||||
|
||||
and vars_of_plist env = function
|
||||
PListComp {value; _} ->
|
||||
vars_of_pinj env value
|
||||
| PNil _ ->
|
||||
env
|
||||
| PParCons {value={inside; _}; _} ->
|
||||
let head, _, tail = inside in
|
||||
vars_of_pattern (vars_of_pattern env head) tail
|
||||
| PCons {value; _} ->
|
||||
Utils.nsepseq_foldl vars_of_pattern env value
|
||||
|
||||
and vars_of_pinj env inj =
|
||||
Utils.sepseq_foldl vars_of_pattern env inj.elements
|
||||
|
||||
and vars_of_ptuple env {inside; _} =
|
||||
Utils.nsepseq_foldl vars_of_pattern env inside
|
||||
|
||||
let vars_of_pattern = vars_of_pattern VSet.empty
|
||||
| Component {region; _} -> region
|
||||
|
||||
@ -1,623 +0,0 @@
|
||||
(* Abstract Syntax Tree (AST) for Pascaligo *)
|
||||
|
||||
[@@@warning "-30"]
|
||||
|
||||
open Utils
|
||||
|
||||
(* Regions
|
||||
|
||||
The AST carries all the regions where tokens have been found by the
|
||||
lexer, plus additional regions corresponding to whole subtrees
|
||||
(like entire expressions, patterns etc.). These regions are needed
|
||||
for error reporting and source-to-source transformations. To make
|
||||
these pervasive regions more legible, we define singleton types for
|
||||
the symbols, keywords etc. with suggestive names like "kwd_and"
|
||||
denoting the _region_ of the occurrence of the keyword "and".
|
||||
*)
|
||||
|
||||
type 'a reg = 'a Region.reg
|
||||
|
||||
val nseq_to_region : ('a -> Region.t) -> 'a nseq -> Region.t
|
||||
val nsepseq_to_region : ('a -> Region.t) -> ('a,'sep) nsepseq -> Region.t
|
||||
val sepseq_to_region : ('a -> Region.t) -> ('a,'sep) sepseq -> Region.t
|
||||
|
||||
(* Keywords of LIGO *)
|
||||
|
||||
type keyword = Region.t
|
||||
type kwd_and = Region.t
|
||||
type kwd_begin = Region.t
|
||||
type kwd_block = Region.t
|
||||
type kwd_case = Region.t
|
||||
type kwd_const = Region.t
|
||||
type kwd_contains = Region.t
|
||||
type kwd_down = Region.t
|
||||
type kwd_else = Region.t
|
||||
type kwd_end = Region.t
|
||||
type kwd_for = Region.t
|
||||
type kwd_from = Region.t
|
||||
type kwd_function = Region.t
|
||||
type kwd_if = Region.t
|
||||
type kwd_in = Region.t
|
||||
type kwd_is = Region.t
|
||||
type kwd_list = Region.t
|
||||
type kwd_map = Region.t
|
||||
type kwd_mod = Region.t
|
||||
type kwd_nil = Region.t
|
||||
type kwd_not = Region.t
|
||||
type kwd_of = Region.t
|
||||
type kwd_or = Region.t
|
||||
type kwd_patch = Region.t
|
||||
type kwd_record = Region.t
|
||||
type kwd_remove = Region.t
|
||||
type kwd_set = Region.t
|
||||
type kwd_skip = Region.t
|
||||
type kwd_step = Region.t
|
||||
type kwd_then = Region.t
|
||||
type kwd_to = Region.t
|
||||
type kwd_type = Region.t
|
||||
type kwd_var = Region.t
|
||||
type kwd_while = Region.t
|
||||
type kwd_with = Region.t
|
||||
|
||||
(* Data constructors *)
|
||||
|
||||
type c_False = Region.t
|
||||
type c_None = Region.t
|
||||
type c_Some = Region.t
|
||||
type c_True = Region.t
|
||||
type c_Unit = Region.t
|
||||
|
||||
(* Symbols *)
|
||||
|
||||
type semi = Region.t (* ";" *)
|
||||
type comma = Region.t (* "," *)
|
||||
type lpar = Region.t (* "(" *)
|
||||
type rpar = Region.t (* ")" *)
|
||||
type lbrace = Region.t (* "{" *)
|
||||
type rbrace = Region.t (* "}" *)
|
||||
type lbracket = Region.t (* "[" *)
|
||||
type rbracket = Region.t (* "]" *)
|
||||
type cons = Region.t (* "#" *)
|
||||
type vbar = Region.t (* "|" *)
|
||||
type arrow = Region.t (* "->" *)
|
||||
type assign = Region.t (* ":=" *)
|
||||
type equal = Region.t (* "=" *)
|
||||
type colon = Region.t (* ":" *)
|
||||
type lt = Region.t (* "<" *)
|
||||
type leq = Region.t (* "<=" *)
|
||||
type gt = Region.t (* ">" *)
|
||||
type geq = Region.t (* ">=" *)
|
||||
type neq = Region.t (* "=/=" *)
|
||||
type plus = Region.t (* "+" *)
|
||||
type minus = Region.t (* "-" *)
|
||||
type slash = Region.t (* "/" *)
|
||||
type times = Region.t (* "*" *)
|
||||
type dot = Region.t (* "." *)
|
||||
type wild = Region.t (* "_" *)
|
||||
type cat = Region.t (* "^" *)
|
||||
|
||||
(* Virtual tokens *)
|
||||
|
||||
type eof = Region.t
|
||||
|
||||
(* Literals *)
|
||||
|
||||
type variable = string reg
|
||||
type fun_name = string reg
|
||||
type type_name = string reg
|
||||
type field_name = string reg
|
||||
type map_name = string reg
|
||||
type set_name = string reg
|
||||
type constr = string reg
|
||||
|
||||
(* Parentheses *)
|
||||
|
||||
type 'a par = {
|
||||
lpar : lpar;
|
||||
inside : 'a;
|
||||
rpar : rpar
|
||||
}
|
||||
|
||||
(* Brackets compounds *)
|
||||
|
||||
type 'a brackets = {
|
||||
lbracket : lbracket;
|
||||
inside : 'a;
|
||||
rbracket : rbracket
|
||||
}
|
||||
|
||||
(* Braced compounds *)
|
||||
|
||||
type 'a braces = {
|
||||
lbrace : lbrace;
|
||||
inside : 'a;
|
||||
rbrace : rbrace
|
||||
}
|
||||
|
||||
(** The Abstract Syntax Tree
|
||||
|
||||
The AST mirrors the contents of Parser.mly, which defines a tree of parsing
|
||||
productions that are used to make a syntax tree from a given program input.
|
||||
|
||||
This file defines the concrete AST for PascaLIGO, which is used to associate
|
||||
regions of the source code text with the contents of the syntax tree.
|
||||
|
||||
*)
|
||||
type t = {
|
||||
decl : declaration nseq;
|
||||
eof : eof
|
||||
}
|
||||
|
||||
and ast = t
|
||||
|
||||
and declaration =
|
||||
TypeDecl of type_decl reg
|
||||
| ConstDecl of const_decl reg
|
||||
| FunDecl of fun_decl reg
|
||||
|
||||
and const_decl = {
|
||||
kwd_const : kwd_const;
|
||||
name : variable;
|
||||
colon : colon;
|
||||
const_type : type_expr;
|
||||
equal : equal;
|
||||
init : expr;
|
||||
terminator : semi option
|
||||
}
|
||||
|
||||
(* Type declarations *)
|
||||
|
||||
and type_decl = {
|
||||
kwd_type : kwd_type;
|
||||
name : type_name;
|
||||
kwd_is : kwd_is;
|
||||
type_expr : type_expr;
|
||||
terminator : semi option
|
||||
}
|
||||
|
||||
and type_expr =
|
||||
TProd of cartesian
|
||||
| TSum of (variant reg, vbar) nsepseq reg
|
||||
| TRecord of field_decl reg ne_injection reg
|
||||
| TApp of (type_name * type_tuple) reg
|
||||
| TFun of (type_expr * arrow * type_expr) reg
|
||||
| TPar of type_expr par reg
|
||||
| TVar of variable
|
||||
|
||||
and cartesian = (type_expr, times) nsepseq reg
|
||||
|
||||
and variant = {
|
||||
constr : constr;
|
||||
arg : (kwd_of * type_expr) option
|
||||
}
|
||||
|
||||
and field_decl = {
|
||||
field_name : field_name;
|
||||
colon : colon;
|
||||
field_type : type_expr
|
||||
}
|
||||
|
||||
and type_tuple = (type_expr, comma) nsepseq par reg
|
||||
|
||||
(* Function declarations *)
|
||||
|
||||
and fun_expr = {
|
||||
kwd_function : kwd_function;
|
||||
name : variable option;
|
||||
param : parameters;
|
||||
colon : colon;
|
||||
ret_type : type_expr;
|
||||
kwd_is : kwd_is;
|
||||
block_with : (block reg * kwd_with) option;
|
||||
return : expr
|
||||
}
|
||||
|
||||
and fun_decl = {
|
||||
fun_expr : fun_expr reg;
|
||||
terminator : semi option
|
||||
}
|
||||
|
||||
and parameters = (param_decl, semi) nsepseq par reg
|
||||
|
||||
and param_decl =
|
||||
ParamConst of param_const reg
|
||||
| ParamVar of param_var reg
|
||||
|
||||
and param_const = {
|
||||
kwd_const : kwd_const;
|
||||
var : variable;
|
||||
colon : colon;
|
||||
param_type : type_expr
|
||||
}
|
||||
|
||||
and param_var = {
|
||||
kwd_var : kwd_var;
|
||||
var : variable;
|
||||
colon : colon;
|
||||
param_type : type_expr
|
||||
}
|
||||
|
||||
and block = {
|
||||
opening : block_opening;
|
||||
statements : statements;
|
||||
terminator : semi option;
|
||||
closing : block_closing
|
||||
}
|
||||
|
||||
and block_opening =
|
||||
Block of kwd_block * lbrace
|
||||
| Begin of kwd_begin
|
||||
|
||||
and block_closing =
|
||||
Block of rbrace
|
||||
| End of kwd_end
|
||||
|
||||
and statements = (statement, semi) nsepseq
|
||||
|
||||
and statement =
|
||||
Instr of instruction
|
||||
| Data of data_decl
|
||||
|
||||
and data_decl =
|
||||
LocalConst of const_decl reg
|
||||
| LocalVar of var_decl reg
|
||||
| LocalFun of fun_decl reg
|
||||
|
||||
and var_decl = {
|
||||
kwd_var : kwd_var;
|
||||
name : variable;
|
||||
colon : colon;
|
||||
var_type : type_expr;
|
||||
assign : assign;
|
||||
init : expr;
|
||||
terminator : semi option
|
||||
}
|
||||
|
||||
and instruction =
|
||||
Cond of conditional reg
|
||||
| CaseInstr of if_clause case reg
|
||||
| Assign of assignment reg
|
||||
| Loop of loop
|
||||
| ProcCall of fun_call
|
||||
| Skip of kwd_skip
|
||||
| RecordPatch of record_patch reg
|
||||
| MapPatch of map_patch reg
|
||||
| SetPatch of set_patch reg
|
||||
| MapRemove of map_remove reg
|
||||
| SetRemove of set_remove reg
|
||||
|
||||
and set_remove = {
|
||||
kwd_remove : kwd_remove;
|
||||
element : expr;
|
||||
kwd_from : kwd_from;
|
||||
kwd_set : kwd_set;
|
||||
set : path
|
||||
}
|
||||
|
||||
and map_remove = {
|
||||
kwd_remove : kwd_remove;
|
||||
key : expr;
|
||||
kwd_from : kwd_from;
|
||||
kwd_map : kwd_map;
|
||||
map : path
|
||||
}
|
||||
|
||||
and set_patch = {
|
||||
kwd_patch : kwd_patch;
|
||||
path : path;
|
||||
kwd_with : kwd_with;
|
||||
set_inj : expr ne_injection reg
|
||||
}
|
||||
|
||||
and map_patch = {
|
||||
kwd_patch : kwd_patch;
|
||||
path : path;
|
||||
kwd_with : kwd_with;
|
||||
map_inj : binding reg ne_injection reg
|
||||
}
|
||||
|
||||
and binding = {
|
||||
source : expr;
|
||||
arrow : arrow;
|
||||
image : expr
|
||||
}
|
||||
|
||||
and record_patch = {
|
||||
kwd_patch : kwd_patch;
|
||||
path : path;
|
||||
kwd_with : kwd_with;
|
||||
record_inj : field_assign reg ne_injection reg
|
||||
}
|
||||
|
||||
and cond_expr = {
|
||||
kwd_if : kwd_if;
|
||||
test : expr;
|
||||
kwd_then : kwd_then;
|
||||
ifso : expr;
|
||||
terminator : semi option;
|
||||
kwd_else : kwd_else;
|
||||
ifnot : expr
|
||||
}
|
||||
|
||||
and conditional = {
|
||||
kwd_if : kwd_if;
|
||||
test : expr;
|
||||
kwd_then : kwd_then;
|
||||
ifso : if_clause;
|
||||
terminator : semi option;
|
||||
kwd_else : kwd_else;
|
||||
ifnot : if_clause
|
||||
}
|
||||
|
||||
and if_clause =
|
||||
ClauseInstr of instruction
|
||||
| ClauseBlock of clause_block
|
||||
|
||||
and clause_block =
|
||||
LongBlock of block reg
|
||||
| ShortBlock of (statements * semi option) braces reg
|
||||
|
||||
and set_membership = {
|
||||
set : expr;
|
||||
kwd_contains : kwd_contains;
|
||||
element : expr
|
||||
}
|
||||
|
||||
and 'a case = {
|
||||
kwd_case : kwd_case;
|
||||
expr : expr;
|
||||
opening : opening;
|
||||
lead_vbar : vbar option;
|
||||
cases : ('a case_clause reg, vbar) nsepseq reg;
|
||||
closing : closing
|
||||
}
|
||||
|
||||
and 'a case_clause = {
|
||||
pattern : pattern;
|
||||
arrow : arrow;
|
||||
rhs : 'a
|
||||
}
|
||||
|
||||
and assignment = {
|
||||
lhs : lhs;
|
||||
assign : assign;
|
||||
rhs : rhs;
|
||||
}
|
||||
|
||||
and lhs =
|
||||
Path of path
|
||||
| MapPath of map_lookup reg
|
||||
|
||||
and rhs = expr
|
||||
|
||||
and loop =
|
||||
While of while_loop reg
|
||||
| For of for_loop
|
||||
|
||||
and while_loop = {
|
||||
kwd_while : kwd_while;
|
||||
cond : expr;
|
||||
block : block reg
|
||||
}
|
||||
|
||||
and for_loop =
|
||||
ForInt of for_int reg
|
||||
| ForCollect of for_collect reg
|
||||
|
||||
and for_int = {
|
||||
kwd_for : kwd_for;
|
||||
assign : var_assign reg;
|
||||
kwd_to : kwd_to;
|
||||
bound : expr;
|
||||
block : block reg
|
||||
}
|
||||
|
||||
and var_assign = {
|
||||
name : variable;
|
||||
assign : assign;
|
||||
expr : expr
|
||||
}
|
||||
|
||||
and for_collect = {
|
||||
kwd_for : kwd_for;
|
||||
var : variable;
|
||||
bind_to : (arrow * variable) option;
|
||||
kwd_in : kwd_in;
|
||||
collection : collection;
|
||||
expr : expr;
|
||||
block : block reg
|
||||
}
|
||||
|
||||
and collection =
|
||||
Map of kwd_map
|
||||
| Set of kwd_set
|
||||
| List of kwd_list
|
||||
|
||||
(* Expressions *)
|
||||
|
||||
and expr =
|
||||
ECase of expr case reg
|
||||
| ECond of cond_expr reg
|
||||
| EAnnot of annot_expr reg
|
||||
| ELogic of logic_expr
|
||||
| EArith of arith_expr
|
||||
| EString of string_expr
|
||||
| EList of list_expr
|
||||
| ESet of set_expr
|
||||
| EConstr of constr_expr
|
||||
| ERecord of field_assign reg ne_injection reg
|
||||
| EProj of projection reg
|
||||
| EMap of map_expr
|
||||
| EVar of Lexer.lexeme reg
|
||||
| ECall of fun_call
|
||||
| EBytes of (Lexer.lexeme * Hex.t) reg
|
||||
| EUnit of c_Unit
|
||||
| ETuple of tuple_expr
|
||||
| EPar of expr par reg
|
||||
| EFun of fun_expr reg
|
||||
|
||||
and annot_expr = (expr * type_expr)
|
||||
|
||||
and set_expr =
|
||||
SetInj of expr injection reg
|
||||
| SetMem of set_membership reg
|
||||
|
||||
and 'a injection = {
|
||||
opening : opening;
|
||||
elements : ('a, semi) sepseq;
|
||||
terminator : semi option;
|
||||
closing : closing
|
||||
}
|
||||
|
||||
and 'a ne_injection = {
|
||||
opening : opening;
|
||||
ne_elements : ('a, semi) nsepseq;
|
||||
terminator : semi option;
|
||||
closing : closing
|
||||
}
|
||||
|
||||
and opening =
|
||||
Kwd of keyword
|
||||
| KwdBracket of keyword * lbracket
|
||||
|
||||
and closing =
|
||||
End of kwd_end
|
||||
| RBracket of rbracket
|
||||
|
||||
and map_expr =
|
||||
MapLookUp of map_lookup reg
|
||||
| MapInj of binding reg injection reg
|
||||
| BigMapInj of binding reg injection reg
|
||||
|
||||
and map_lookup = {
|
||||
path : path;
|
||||
index : expr brackets reg
|
||||
}
|
||||
|
||||
and path =
|
||||
Name of variable
|
||||
| Path of projection reg
|
||||
|
||||
and logic_expr =
|
||||
BoolExpr of bool_expr
|
||||
| CompExpr of comp_expr
|
||||
|
||||
and bool_expr =
|
||||
Or of kwd_or bin_op reg
|
||||
| And of kwd_and bin_op reg
|
||||
| Not of kwd_not un_op reg
|
||||
| False of c_False
|
||||
| True of c_True
|
||||
|
||||
and 'a bin_op = {
|
||||
op : 'a;
|
||||
arg1 : expr;
|
||||
arg2 : expr
|
||||
}
|
||||
|
||||
and 'a un_op = {
|
||||
op : 'a;
|
||||
arg : expr
|
||||
}
|
||||
|
||||
and comp_expr =
|
||||
Lt of lt bin_op reg
|
||||
| Leq of leq bin_op reg
|
||||
| Gt of gt bin_op reg
|
||||
| Geq of geq bin_op reg
|
||||
| Equal of equal bin_op reg
|
||||
| Neq of neq bin_op reg
|
||||
|
||||
and arith_expr =
|
||||
Add of plus bin_op reg
|
||||
| Sub of minus bin_op reg
|
||||
| Mult of times bin_op reg
|
||||
| Div of slash bin_op reg
|
||||
| Mod of kwd_mod bin_op reg
|
||||
| Neg of minus un_op reg
|
||||
| Int of (Lexer.lexeme * Z.t) reg
|
||||
| Nat of (Lexer.lexeme * Z.t) reg
|
||||
| Mutez of (Lexer.lexeme * Z.t) reg
|
||||
|
||||
and string_expr =
|
||||
Cat of cat bin_op reg
|
||||
| String of Lexer.lexeme reg
|
||||
|
||||
and list_expr =
|
||||
ECons of cons bin_op reg
|
||||
| EListComp of expr injection reg
|
||||
| ENil of kwd_nil
|
||||
|
||||
and constr_expr =
|
||||
SomeApp of (c_Some * arguments) reg
|
||||
| NoneExpr of c_None
|
||||
| ConstrApp of (constr * arguments option) reg
|
||||
|
||||
and field_assign = {
|
||||
field_name : field_name;
|
||||
equal : equal;
|
||||
field_expr : expr
|
||||
}
|
||||
|
||||
and projection = {
|
||||
struct_name : variable;
|
||||
selector : dot;
|
||||
field_path : (selection, dot) nsepseq
|
||||
}
|
||||
|
||||
and selection =
|
||||
FieldName of field_name
|
||||
| Component of (Lexer.lexeme * Z.t) reg
|
||||
|
||||
and tuple_expr = (expr, comma) nsepseq par reg
|
||||
|
||||
and fun_call = (expr * arguments) reg
|
||||
|
||||
and arguments = tuple_expr
|
||||
|
||||
(* Patterns *)
|
||||
|
||||
and pattern =
|
||||
PConstr of constr_pattern
|
||||
| PVar of Lexer.lexeme reg
|
||||
| PWild of wild
|
||||
| PInt of (Lexer.lexeme * Z.t) reg
|
||||
| PNat of (Lexer.lexeme * Z.t) reg
|
||||
| PBytes of (Lexer.lexeme * Hex.t) reg
|
||||
| PString of Lexer.lexeme reg
|
||||
| PList of list_pattern
|
||||
| PTuple of tuple_pattern
|
||||
|
||||
and constr_pattern =
|
||||
PUnit of c_Unit
|
||||
| PFalse of c_False
|
||||
| PTrue of c_True
|
||||
| PNone of c_None
|
||||
| PSomeApp of (c_Some * pattern par reg) reg
|
||||
| PConstrApp of (constr * tuple_pattern option) reg
|
||||
|
||||
and tuple_pattern = (pattern, comma) nsepseq par reg
|
||||
|
||||
and list_pattern =
|
||||
PListComp of pattern injection reg
|
||||
| PNil of kwd_nil
|
||||
| PParCons of (pattern * cons * pattern) par reg
|
||||
| PCons of (pattern, cons) nsepseq reg
|
||||
|
||||
(* Projecting regions *)
|
||||
|
||||
val type_expr_to_region : type_expr -> Region.t
|
||||
val expr_to_region : expr -> Region.t
|
||||
val instr_to_region : instruction -> Region.t
|
||||
val pattern_to_region : pattern -> Region.t
|
||||
val path_to_region : path -> Region.t
|
||||
val lhs_to_region : lhs -> Region.t
|
||||
val rhs_to_region : rhs -> Region.t
|
||||
val if_clause_to_region : if_clause -> Region.t
|
||||
val selection_to_region : selection -> Region.t
|
||||
|
||||
(* Extracting variables from patterns *)
|
||||
|
||||
module VSet : Set.S with type elt = string Region.reg
|
||||
|
||||
val vars_of_pattern : pattern -> VSet.t
|
||||
@ -6,60 +6,7 @@
|
||||
open Region
|
||||
open AST
|
||||
|
||||
module SSet = Utils.String.Set
|
||||
|
||||
let reserved =
|
||||
let open SSet in
|
||||
empty
|
||||
|> add "get_force"
|
||||
|> add "get_chain_id"
|
||||
|> add "transaction"
|
||||
|> add "get_contract"
|
||||
|> add "get_entrypoint"
|
||||
|> add "size"
|
||||
|> add "int"
|
||||
|> add "abs"
|
||||
|> add "is_nat"
|
||||
|> add "amount"
|
||||
|> add "balance"
|
||||
|> add "now"
|
||||
|> add "unit"
|
||||
|> add "source"
|
||||
|> add "sender"
|
||||
|> add "failwith"
|
||||
|> add "bitwise_or"
|
||||
|> add "bitwise_and"
|
||||
|> add "bitwise_xor"
|
||||
|> add "string_concat"
|
||||
|> add "string_slice"
|
||||
|> add "crypto_check"
|
||||
|> add "crypto_hash_key"
|
||||
|> add "bytes_concat"
|
||||
|> add "bytes_slice"
|
||||
|> add "bytes_pack"
|
||||
|> add "bytes_unpack"
|
||||
|> add "set_empty"
|
||||
|> add "set_mem"
|
||||
|> add "set_add"
|
||||
|> add "set_remove"
|
||||
|> add "set_iter"
|
||||
|> add "set_fold"
|
||||
|> add "list_iter"
|
||||
|> add "list_fold"
|
||||
|> add "list_map"
|
||||
|> add "map_iter"
|
||||
|> add "map_map"
|
||||
|> add "map_fold"
|
||||
|> add "map_remove"
|
||||
|> add "map_update"
|
||||
|> add "map_get"
|
||||
|> add "map_mem"
|
||||
|> add "sha_256"
|
||||
|> add "sha_512"
|
||||
|> add "blake2b"
|
||||
|> add "cons"
|
||||
|
||||
(* END HEADER *)
|
||||
(* END HEADER *)
|
||||
%}
|
||||
|
||||
(* See [ParToken.mly] for the definition of tokens. *)
|
||||
@ -171,10 +118,7 @@ declaration:
|
||||
|
||||
type_decl:
|
||||
"type" type_name "is" type_expr ";"? {
|
||||
let () =
|
||||
if SSet.mem $2.value reserved then
|
||||
let open! SyntaxError in
|
||||
raise (Error (Reserved_name $2)) in
|
||||
ignore (SyntaxError.check_reserved_name $2);
|
||||
let stop =
|
||||
match $5 with
|
||||
Some region -> region
|
||||
@ -242,14 +186,7 @@ type_tuple:
|
||||
|
||||
sum_type:
|
||||
"|"? nsepseq(variant,"|") {
|
||||
let add acc {value; _} =
|
||||
if VSet.mem value.constr acc then
|
||||
let open! SyntaxError in
|
||||
raise (Error (Duplicate_variant value.constr))
|
||||
else VSet.add value.constr acc in
|
||||
let variants =
|
||||
Utils.nsepseq_foldl add VSet.empty $2 in
|
||||
let () = ignore variants in
|
||||
SyntaxError.check_variants (Utils.nsepseq_to_list $2);
|
||||
let region = nsepseq_to_region (fun x -> x.region) $2
|
||||
in TSum {region; value=$2} }
|
||||
|
||||
@ -263,6 +200,8 @@ variant:
|
||||
record_type:
|
||||
"record" sep_or_term_list(field_decl,";") "end" {
|
||||
let ne_elements, terminator = $2 in
|
||||
let () = Utils.nsepseq_to_list ne_elements
|
||||
|> SyntaxError.check_fields in
|
||||
let region = cover $1 $3
|
||||
and value = {opening = Kwd $1;
|
||||
ne_elements;
|
||||
@ -290,13 +229,7 @@ fun_expr:
|
||||
"function" fun_name? parameters ":" type_expr "is"
|
||||
block
|
||||
"with" expr {
|
||||
let () =
|
||||
match $2 with
|
||||
Some name ->
|
||||
if SSet.mem name.value reserved then
|
||||
let open! SyntaxError in
|
||||
raise (Error (Reserved_name name))
|
||||
| None -> () in
|
||||
let () = SyntaxError.check_reserved_name_opt $2 in
|
||||
let stop = expr_to_region $9 in
|
||||
let region = cover $1 stop
|
||||
and value = {kwd_function = $1;
|
||||
@ -309,13 +242,7 @@ fun_expr:
|
||||
return = $9}
|
||||
in {region; value} }
|
||||
| "function" fun_name? parameters ":" type_expr "is" expr {
|
||||
let () =
|
||||
match $2 with
|
||||
Some name ->
|
||||
if SSet.mem name.value reserved then
|
||||
let open! SyntaxError in
|
||||
raise (Error (Reserved_name name))
|
||||
| None -> () in
|
||||
let () = SyntaxError.check_reserved_name_opt $2 in
|
||||
let stop = expr_to_region $7 in
|
||||
let region = cover $1 stop
|
||||
and value = {kwd_function = $1;
|
||||
@ -346,47 +273,28 @@ open_fun_decl:
|
||||
|
||||
parameters:
|
||||
par(nsepseq(param_decl,";")) {
|
||||
let open! AST in
|
||||
let contents : (param_decl, semi) Utils.nsepseq par reg = $1 in
|
||||
let add acc = function
|
||||
ParamConst {value; _} ->
|
||||
if VSet.mem value.var acc then
|
||||
let open! SyntaxError in
|
||||
raise (Error (Duplicate_parameter value.var))
|
||||
else VSet.add value.var acc
|
||||
| ParamVar {value; _} ->
|
||||
if VSet.mem value.var acc then
|
||||
let open! SyntaxError in
|
||||
raise (Error (Duplicate_parameter value.var))
|
||||
else VSet.add value.var acc in
|
||||
let params =
|
||||
Utils.nsepseq_foldl add VSet.empty contents.value.inside in
|
||||
let () = ignore params
|
||||
in $1 }
|
||||
Utils.nsepseq_to_list ($1.value: _ par).inside
|
||||
in SyntaxError.check_parameters params;
|
||||
$1 }
|
||||
|
||||
param_decl:
|
||||
"var" var ":" param_type {
|
||||
let () =
|
||||
if SSet.mem $2.value reserved then
|
||||
let open! SyntaxError in
|
||||
raise (Error (Reserved_name $2)) in
|
||||
let var = SyntaxError.check_reserved_name $2 in
|
||||
let stop = type_expr_to_region $4 in
|
||||
let region = cover $1 stop
|
||||
and value = {kwd_var = $1;
|
||||
var = $2;
|
||||
var;
|
||||
colon = $3;
|
||||
param_type = $4}
|
||||
in ParamVar {region; value}
|
||||
}
|
||||
| "const" var ":" param_type {
|
||||
let () =
|
||||
if SSet.mem $2.value reserved then
|
||||
let open! SyntaxError in
|
||||
raise (Error (Reserved_name $2)) in
|
||||
let var = SyntaxError.check_reserved_name $2 in
|
||||
let stop = type_expr_to_region $4 in
|
||||
let region = cover $1 stop
|
||||
and value = {kwd_const = $1;
|
||||
var = $2;
|
||||
var;
|
||||
colon = $3;
|
||||
param_type = $4}
|
||||
in ParamConst {region; value} }
|
||||
@ -450,12 +358,9 @@ open_var_decl:
|
||||
|
||||
unqualified_decl(OP):
|
||||
var ":" type_expr OP expr {
|
||||
let () =
|
||||
if SSet.mem $1.value reserved then
|
||||
let open! SyntaxError in
|
||||
raise (Error (Reserved_name $1)) in
|
||||
let var = SyntaxError.check_reserved_name $1 in
|
||||
let region = expr_to_region $5
|
||||
in $1, $2, $3, $4, $5, region }
|
||||
in var, $2, $3, $4, $5, region }
|
||||
|
||||
const_decl:
|
||||
open_const_decl ";"? {
|
||||
@ -662,14 +567,7 @@ cases(rhs):
|
||||
|
||||
case_clause(rhs):
|
||||
pattern "->" rhs {
|
||||
let vars = AST.vars_of_pattern $1 in
|
||||
let is_reserved elt = SSet.mem elt.value reserved in
|
||||
let inter = VSet.filter is_reserved vars in
|
||||
let () =
|
||||
if not (VSet.is_empty inter) then
|
||||
let clash = VSet.choose inter in
|
||||
let open! SyntaxError in
|
||||
raise (Error (Reserved_name clash)) in
|
||||
SyntaxError.check_pattern $1;
|
||||
fun rhs_to_region ->
|
||||
let start = pattern_to_region $1 in
|
||||
let region = cover start (rhs_to_region $3)
|
||||
@ -711,13 +609,10 @@ for_loop:
|
||||
in For (ForInt {region; value})
|
||||
}
|
||||
| "for" var arrow_clause? "in" collection expr block {
|
||||
let () =
|
||||
if SSet.mem $2.value reserved then
|
||||
let open! SyntaxError in
|
||||
raise (Error (Reserved_name $2)) in
|
||||
let var = SyntaxError.check_reserved_name $2 in
|
||||
let region = cover $1 $7.region in
|
||||
let value = {kwd_for = $1;
|
||||
var = $2;
|
||||
var;
|
||||
bind_to = $3;
|
||||
kwd_in = $4;
|
||||
collection = $5;
|
||||
@ -732,21 +627,13 @@ collection:
|
||||
|
||||
var_assign:
|
||||
var ":=" expr {
|
||||
let () =
|
||||
if SSet.mem $1.value reserved then
|
||||
let open! SyntaxError in
|
||||
raise (Error (Reserved_name $1)) in
|
||||
let region = cover $1.region (expr_to_region $3)
|
||||
and value = {name=$1; assign=$2; expr=$3}
|
||||
let name = SyntaxError.check_reserved_name $1 in
|
||||
let region = cover name.region (expr_to_region $3)
|
||||
and value = {name; assign=$2; expr=$3}
|
||||
in {region; value} }
|
||||
|
||||
arrow_clause:
|
||||
"->" var {
|
||||
let () =
|
||||
if SSet.mem $2.value reserved then
|
||||
let open! SyntaxError in
|
||||
raise (Error (Reserved_name $2))
|
||||
in $1,$2 }
|
||||
"->" var { $1, SyntaxError.check_reserved_name $2 }
|
||||
|
||||
(* Expressions *)
|
||||
|
||||
|
||||
@ -64,10 +64,42 @@ let () =
|
||||
let () = Unit.close_all () in
|
||||
let token =
|
||||
MyLexer.Token.mk_constr name.Region.value name.Region.region in
|
||||
let point = "Duplicate variant in this type declaration.\n\
|
||||
let point = "Duplicate variant in this sum type declaration.\n\
|
||||
Hint: Change the name.\n",
|
||||
None, token in
|
||||
let error =
|
||||
Unit.format_error ~offsets:IO.options#offsets
|
||||
IO.options#mode point
|
||||
in Printf.eprintf "\027[31m%s\027[0m%!" error
|
||||
|
||||
| Error (Non_linear_pattern var) ->
|
||||
let () = Unit.close_all () in
|
||||
let token =
|
||||
MyLexer.Token.mk_ident var.Region.value var.Region.region in
|
||||
(match token with
|
||||
Stdlib.Error _ ->
|
||||
assert false (* Should not fail if [name] is valid. *)
|
||||
| Ok invalid ->
|
||||
let point = "Repeated variable in this pattern.\n\
|
||||
Hint: Change the name.\n",
|
||||
None, invalid in
|
||||
let error =
|
||||
Unit.format_error ~offsets:IO.options#offsets
|
||||
IO.options#mode point
|
||||
in Printf.eprintf "\027[31m%s\027[0m%!" error)
|
||||
|
||||
| Error (Duplicate_field name) ->
|
||||
let () = Unit.close_all () in
|
||||
let token =
|
||||
MyLexer.Token.mk_ident name.Region.value name.Region.region in
|
||||
(match token with
|
||||
Stdlib.Error _ ->
|
||||
assert false (* Should not fail if [name] is valid. *)
|
||||
| Ok invalid ->
|
||||
let point = "Duplicate field name in this record declaration.\n\
|
||||
Hint: Change the name.\n",
|
||||
None, invalid in
|
||||
let error =
|
||||
Unit.format_error ~offsets:IO.options#offsets
|
||||
IO.options#mode point
|
||||
in Printf.eprintf "\027[31m%s\027[0m%!" error)
|
||||
|
||||
@ -1,8 +1,185 @@
|
||||
[@@@warning "-42"]
|
||||
|
||||
type t =
|
||||
Reserved_name of string Region.reg
|
||||
| Duplicate_parameter of string Region.reg
|
||||
| Duplicate_variant of string Region.reg
|
||||
Reserved_name of AST.variable
|
||||
| Duplicate_parameter of AST.variable
|
||||
| Duplicate_variant of AST.variable
|
||||
| Non_linear_pattern of AST.variable
|
||||
| Duplicate_field of AST.variable
|
||||
|
||||
type error = t
|
||||
|
||||
exception Error of t
|
||||
|
||||
open Region
|
||||
|
||||
(* Useful modules *)
|
||||
|
||||
module SSet = Utils.String.Set
|
||||
|
||||
module Ord =
|
||||
struct
|
||||
type t = AST.variable
|
||||
let compare v1 v2 =
|
||||
compare v1.value v2.value
|
||||
end
|
||||
|
||||
module VarSet = Set.Make (Ord)
|
||||
|
||||
(* Checking the definition of reserved names (shadowing) *)
|
||||
|
||||
let reserved =
|
||||
let open SSet in
|
||||
empty
|
||||
|> add "get_force"
|
||||
|> add "get_chain_id"
|
||||
|> add "transaction"
|
||||
|> add "get_contract"
|
||||
|> add "get_entrypoint"
|
||||
|> add "size"
|
||||
|> add "int"
|
||||
|> add "abs"
|
||||
|> add "is_nat"
|
||||
|> add "amount"
|
||||
|> add "balance"
|
||||
|> add "now"
|
||||
|> add "unit"
|
||||
|> add "source"
|
||||
|> add "sender"
|
||||
|> add "failwith"
|
||||
|> add "bitwise_or"
|
||||
|> add "bitwise_and"
|
||||
|> add "bitwise_xor"
|
||||
|> add "string_concat"
|
||||
|> add "string_slice"
|
||||
|> add "crypto_check"
|
||||
|> add "crypto_hash_key"
|
||||
|> add "bytes_concat"
|
||||
|> add "bytes_slice"
|
||||
|> add "bytes_pack"
|
||||
|> add "bytes_unpack"
|
||||
|> add "set_empty"
|
||||
|> add "set_mem"
|
||||
|> add "set_add"
|
||||
|> add "set_remove"
|
||||
|> add "set_iter"
|
||||
|> add "set_fold"
|
||||
|> add "list_iter"
|
||||
|> add "list_fold"
|
||||
|> add "list_map"
|
||||
|> add "map_iter"
|
||||
|> add "map_map"
|
||||
|> add "map_fold"
|
||||
|> add "map_remove"
|
||||
|> add "map_update"
|
||||
|> add "map_get"
|
||||
|> add "map_mem"
|
||||
|> add "sha_256"
|
||||
|> add "sha_512"
|
||||
|> add "blake2b"
|
||||
|> add "cons"
|
||||
|> add "address"
|
||||
|> add "self_address"
|
||||
|> add "implicit_account"
|
||||
|> add "set_delegate"
|
||||
|
||||
let check_reserved_names vars =
|
||||
let is_reserved elt = SSet.mem elt.value reserved in
|
||||
let inter = VarSet.filter is_reserved vars in
|
||||
if not (VarSet.is_empty inter) then
|
||||
let clash = VarSet.choose inter in
|
||||
raise (Error (Reserved_name clash))
|
||||
else vars
|
||||
|
||||
let check_reserved_name var =
|
||||
if SSet.mem var.value reserved then
|
||||
raise (Error (Reserved_name var))
|
||||
else var
|
||||
|
||||
let check_reserved_name_opt = function
|
||||
Some var -> ignore (check_reserved_name var)
|
||||
| None -> ()
|
||||
|
||||
(* Checking the linearity of patterns *)
|
||||
|
||||
open! AST
|
||||
|
||||
let rec vars_of_pattern env = function
|
||||
PConstr p -> vars_of_pconstr env p
|
||||
| PWild _ | PInt _ | PNat _ | PBytes _ | PString _ -> env
|
||||
| PList l -> vars_of_plist env l
|
||||
| PTuple t -> vars_of_ptuple env t.value
|
||||
| PVar var ->
|
||||
if VarSet.mem var env then
|
||||
raise (Error (Non_linear_pattern var))
|
||||
else VarSet.add var env
|
||||
|
||||
and vars_of_pconstr env = function
|
||||
PUnit _ | PFalse _ | PTrue _ | PNone _ -> env
|
||||
| PSomeApp {value=_, {value={inside; _};_}; _} ->
|
||||
vars_of_pattern env inside
|
||||
| PConstrApp {value=_, Some tuple; _} ->
|
||||
vars_of_ptuple env tuple.value
|
||||
| PConstrApp {value=_,None; _} -> env
|
||||
|
||||
and vars_of_plist env = function
|
||||
PListComp {value; _} ->
|
||||
vars_of_pinj env value
|
||||
| PNil _ ->
|
||||
env
|
||||
| PParCons {value={inside; _}; _} ->
|
||||
let head, _, tail = inside in
|
||||
vars_of_pattern (vars_of_pattern env head) tail
|
||||
| PCons {value; _} ->
|
||||
Utils.nsepseq_foldl vars_of_pattern env value
|
||||
|
||||
and vars_of_pinj env inj =
|
||||
Utils.sepseq_foldl vars_of_pattern env inj.elements
|
||||
|
||||
and vars_of_ptuple env {inside; _} =
|
||||
Utils.nsepseq_foldl vars_of_pattern env inside
|
||||
|
||||
let check_linearity = vars_of_pattern VarSet.empty
|
||||
|
||||
(* Checking patterns *)
|
||||
|
||||
let check_pattern p =
|
||||
check_linearity p |> check_reserved_names |> ignore
|
||||
|
||||
(* Checking variants for duplicates *)
|
||||
|
||||
let check_variants variants =
|
||||
let add acc {value; _} =
|
||||
if VarSet.mem value.constr acc then
|
||||
raise (Error (Duplicate_variant value.constr))
|
||||
else VarSet.add value.constr acc in
|
||||
let variants =
|
||||
List.fold_left add VarSet.empty variants
|
||||
in ignore variants
|
||||
|
||||
(* Checking parameters *)
|
||||
|
||||
let check_parameters params =
|
||||
let add acc = function
|
||||
ParamConst {value; _} ->
|
||||
if VarSet.mem value.var acc then
|
||||
raise (Error (Duplicate_parameter value.var))
|
||||
else VarSet.add value.var acc
|
||||
| ParamVar {value; _} ->
|
||||
if VarSet.mem value.var acc then
|
||||
raise (Error (Duplicate_parameter value.var))
|
||||
else VarSet.add value.var acc in
|
||||
let params =
|
||||
List.fold_left add VarSet.empty params
|
||||
in ignore params
|
||||
|
||||
(* Checking record fields *)
|
||||
|
||||
let check_fields fields =
|
||||
let add acc {value; _} =
|
||||
if VarSet.mem (value: field_decl).field_name acc then
|
||||
raise (Error (Duplicate_field value.field_name))
|
||||
else VarSet.add value.field_name acc in
|
||||
let fields =
|
||||
List.fold_left add VarSet.empty fields
|
||||
in ignore fields
|
||||
|
||||
@ -1,8 +1,26 @@
|
||||
type t =
|
||||
Reserved_name of string Region.reg
|
||||
| Duplicate_parameter of string Region.reg
|
||||
| Duplicate_variant of string Region.reg
|
||||
Reserved_name of AST.variable
|
||||
| Duplicate_parameter of AST.variable
|
||||
| Duplicate_variant of AST.variable
|
||||
| Non_linear_pattern of AST.variable
|
||||
| Duplicate_field of AST.variable
|
||||
|
||||
type error = t
|
||||
|
||||
exception Error of t
|
||||
|
||||
module Ord :
|
||||
sig
|
||||
type t = AST.variable
|
||||
val compare : t -> t -> int
|
||||
end
|
||||
|
||||
module VarSet : Set.S with type elt = Ord.t
|
||||
|
||||
val check_reserved_name : AST.variable -> AST.variable
|
||||
val check_reserved_name_opt : AST.variable option -> unit
|
||||
val check_reserved_names : VarSet.t -> VarSet.t
|
||||
val check_pattern : AST.pattern -> unit
|
||||
val check_variants : AST.variant Region.reg list -> unit
|
||||
val check_parameters : AST.param_decl list -> unit
|
||||
val check_fields : AST.field_decl Region.reg list -> unit
|
||||
|
||||
@ -1,9 +1,15 @@
|
||||
;; Build of the lexer
|
||||
|
||||
(ocamllex LexToken)
|
||||
|
||||
;; Build of the parser
|
||||
|
||||
(menhir
|
||||
(merge_into Parser)
|
||||
(modules ParToken Parser)
|
||||
(flags -la 1 --table --strict --explain --external-tokens LexToken))
|
||||
(flags -la 1 --table --strict --external-tokens LexToken))
|
||||
|
||||
;; Build of the parser as a library
|
||||
|
||||
(library
|
||||
(name parser_pascaligo)
|
||||
@ -20,6 +26,18 @@
|
||||
(pps bisect_ppx --conditional))
|
||||
(flags (:standard -open Parser_shared -open Simple_utils)))
|
||||
|
||||
;; Build of the unlexer (for covering the
|
||||
;; error states of the LR automaton)
|
||||
|
||||
(executable
|
||||
(name Unlexer)
|
||||
(libraries str)
|
||||
(preprocess
|
||||
(pps bisect_ppx --conditional))
|
||||
(modules Unlexer))
|
||||
|
||||
;; Local build of a standalone lexer
|
||||
|
||||
(executable
|
||||
(name LexerMain)
|
||||
(libraries
|
||||
@ -29,6 +47,8 @@
|
||||
(pps bisect_ppx --conditional))
|
||||
(flags (:standard -open Parser_shared -open Parser_pascaligo)))
|
||||
|
||||
;; Local build of a standalone parser
|
||||
|
||||
(executable
|
||||
(name ParserMain)
|
||||
(libraries parser_pascaligo)
|
||||
@ -37,25 +57,3 @@
|
||||
(preprocess
|
||||
(pps bisect_ppx --conditional))
|
||||
(flags (:standard -open Simple_utils -open Parser_shared -open Parser_pascaligo)))
|
||||
|
||||
(executable
|
||||
(name Unlexer)
|
||||
(libraries str)
|
||||
(preprocess
|
||||
(pps bisect_ppx --conditional))
|
||||
(modules Unlexer))
|
||||
|
||||
;; Les deux directives (rule) qui suivent sont pour le dev local.
|
||||
;; Il suffit de faire "dune build Parser.exe" pour avoir un Parser.exe dans le dossier.
|
||||
;; Pour le purger, il faut faire "dune clean".
|
||||
;(rule
|
||||
; (targets Parser.exe)
|
||||
; (deps ParserMain.exe)
|
||||
; (action (copy ParserMain.exe Parser.exe))
|
||||
; (mode promote-until-clean))
|
||||
|
||||
;(rule
|
||||
; (targets Lexer.exe)
|
||||
; (deps LexerMain.exe)
|
||||
; (action (copy LexerMain.exe Lexer.exe))
|
||||
; (mode promote-until-clean))
|
||||
|
||||
162
src/test/#multisig_tests.ml#
Normal file
162
src/test/#multisig_tests.ml#
Normal file
@ -0,0 +1,162 @@
|
||||
open Trace
|
||||
open Test_helpers
|
||||
|
||||
let type_file f =
|
||||
let%bind (typed , state , _env) = Ligo.Compile.Wrapper.source_to_typed (Syntax_name "pascaligo") f in
|
||||
ok @@ (typed,state)
|
||||
|
||||
let get_program =
|
||||
let s = ref None in
|
||||
fun () -> match !s with
|
||||
| Some s -> ok s
|
||||
| None -> (
|
||||
let%bind program = type_file "./contracts/multisig.ligo" in
|
||||
s := Some program ;
|
||||
ok program
|
||||
)
|
||||
|
||||
let compile_main () =
|
||||
let%bind program,_ = get_program () in
|
||||
let%bind michelson = Compile.Wrapper.typed_to_michelson_value_as_function program "main" in
|
||||
" let%bind _ex_ty_value = Ligo.Run.Of_michelson.evaluate michelson in
|
||||
ok ()
|
||||
|
||||
open Ast_simplified
|
||||
|
||||
let init_storage threshold counter pkeys =
|
||||
let keys = List.map
|
||||
(fun el ->
|
||||
let (_,pk_str,_) = str_keys el in
|
||||
e_key @@ pk_str)
|
||||
pkeys in
|
||||
ez_e_record [
|
||||
("id" , e_string "MULTISIG" ) ;
|
||||
("counter" , e_nat counter ) ;
|
||||
("threshold" , e_nat threshold) ;
|
||||
("auth" , e_typed_list keys t_key ) ;
|
||||
]
|
||||
|
||||
let empty_op_list =
|
||||
(e_typed_list [] t_operation)
|
||||
let empty_message = e_lambda (Var.of_name "arguments")
|
||||
(Some t_unit) (Some (t_list t_operation))
|
||||
empty_op_list
|
||||
let chain_id_zero = e_chain_id @@ Tezos_crypto.Base58.simple_encode
|
||||
Tezos_base__TzPervasives.Chain_id.b58check_encoding
|
||||
Tezos_base__TzPervasives.Chain_id.zero
|
||||
|
||||
(* sign the message 'msg' with 'keys', if 'is_valid'=false the providid signature will be incorrect *)
|
||||
let params counter msg keys is_validl =
|
||||
let%bind program,_ = get_program () in
|
||||
let aux = fun acc (key,is_valid) ->
|
||||
let (_,_pk,sk) = key in
|
||||
let (pkh,_,_) = str_keys key in
|
||||
let payload = e_tuple
|
||||
[ msg ;
|
||||
e_nat counter ;
|
||||
e_string (if is_valid then "MULTISIG" else "XX") ;
|
||||
chain_id_zero ] in
|
||||
let%bind signature = sign_message program payload sk in
|
||||
ok @@ (e_pair (e_key_hash pkh) (e_signature signature))::acc in
|
||||
let%bind signed_msgs = Trace.bind_fold_list aux [] (List.rev @@ List.combine keys is_validl) in
|
||||
ok @@ e_constructor
|
||||
"CheckMessage"
|
||||
(ez_e_record [
|
||||
("counter" , e_nat counter ) ;
|
||||
("message" , msg) ;
|
||||
("signatures" , e_typed_list signed_msgs (t_pair (t_key_hash,t_signature)) ) ;
|
||||
])
|
||||
|
||||
(* Provide one valid signature when the threshold is two of two keys *)
|
||||
let not_enough_1_of_2 () =
|
||||
let%bind program,_ = get_program () in
|
||||
let exp_failwith = "Not enough signatures passed the check" in
|
||||
let keys = gen_keys () in
|
||||
let%bind test_params = params 0 empty_message [keys] [true] in
|
||||
let%bind () = expect_string_failwith
|
||||
program "main" (e_pair test_params (init_storage 2 0 [keys;gen_keys()])) exp_failwith in
|
||||
ok ()
|
||||
|
||||
let unmatching_counter () =
|
||||
let%bind program,_ = get_program () in
|
||||
let exp_failwith = "Counters does not match" in
|
||||
let keys = gen_keys () in
|
||||
let%bind test_params = params 1 empty_message [keys] [true] in
|
||||
let%bind () = expect_string_failwith
|
||||
program "main" (e_pair test_params (init_storage 1 0 [keys])) exp_failwith in
|
||||
ok ()
|
||||
|
||||
(* Provide one invalid signature (correct key but incorrect signature)
|
||||
when the threshold is one of one key *)
|
||||
let invalid_1_of_1 () =
|
||||
let%bind program,_ = get_program () in
|
||||
let exp_failwith = "Invalid signature" in
|
||||
let keys = [gen_keys ()] in
|
||||
let%bind test_params = params 0 empty_message keys [false] in
|
||||
let%bind () = expect_string_failwith
|
||||
program "main" (e_pair test_params (init_storage 1 0 keys)) exp_failwith in
|
||||
ok ()
|
||||
|
||||
(* Provide one valid signature when the threshold is one of one key *)
|
||||
let valid_1_of_1 () =
|
||||
let%bind program,_ = get_program () in
|
||||
let keys = gen_keys () in
|
||||
let%bind () = expect_eq_n_trace_aux [0;1;2] program "main"
|
||||
(fun n ->
|
||||
let%bind params = params n empty_message [keys] [true] in
|
||||
ok @@ e_pair params (init_storage 1 n [keys])
|
||||
)
|
||||
(fun n ->
|
||||
ok @@ e_pair empty_op_list (init_storage 1 (n+1) [keys])
|
||||
) in
|
||||
ok ()
|
||||
|
||||
(* Provive two valid signatures when the threshold is two of three keys *)
|
||||
let valid_2_of_3 () =
|
||||
let%bind program,_ = get_program () in
|
||||
let param_keys = [gen_keys (); gen_keys ()] in
|
||||
let st_keys = param_keys @ [gen_keys ()] in
|
||||
let%bind () = expect_eq_n_trace_aux [0;1;2] program "main"
|
||||
(fun n ->
|
||||
let%bind params = params n empty_message param_keys [true;true] in
|
||||
ok @@ e_pair params (init_storage 2 n st_keys)
|
||||
)
|
||||
(fun n ->
|
||||
ok @@ e_pair empty_op_list (init_storage 2 (n+1) st_keys)
|
||||
) in
|
||||
ok ()
|
||||
|
||||
(* Provide one invalid signature and two valid signatures when the threshold is two of three keys *)
|
||||
let invalid_3_of_3 () =
|
||||
let%bind program,_ = get_program () in
|
||||
let valid_keys = [gen_keys() ; gen_keys()] in
|
||||
let invalid_key = gen_keys () in
|
||||
let param_keys = valid_keys @ [invalid_key] in
|
||||
let st_keys = valid_keys @ [gen_keys ()] in
|
||||
let%bind test_params = params 0 empty_message param_keys [false;true;true] in
|
||||
let exp_failwith = "Invalid signature" in
|
||||
let%bind () = expect_string_failwith
|
||||
program "main" (e_pair test_params (init_storage 2 0 st_keys)) exp_failwith in
|
||||
ok ()
|
||||
|
||||
(* Provide two valid signatures when the threshold is three of three keys *)
|
||||
let not_enough_2_of_3 () =
|
||||
let%bind program,_ = get_program () in
|
||||
let valid_keys = [gen_keys() ; gen_keys()] in
|
||||
let st_keys = gen_keys () :: valid_keys in
|
||||
let%bind test_params = params 0 empty_message (valid_keys) [true;true] in
|
||||
let exp_failwith = "Not enough signatures passed the check" in
|
||||
let%bind () = expect_string_failwith
|
||||
program "main" (e_pair test_params (init_storage 3 0 st_keys)) exp_failwith in
|
||||
ok ()
|
||||
|
||||
let main = test_suite "Multisig" [
|
||||
test "compile" compile_main ;
|
||||
test "unmatching_counter" unmatching_counter ;
|
||||
test "valid_1_of_1" valid_1_of_1 ;
|
||||
test "invalid_1_of_1" invalid_1_of_1 ;
|
||||
test "not_enough_signature" not_enough_1_of_2 ;
|
||||
test "valid_2_of_3" valid_2_of_3 ;
|
||||
test "invalid_3_of_3" invalid_3_of_3 ;
|
||||
test "not_enough_2_of_3" not_enough_2_of_3 ;
|
||||
]
|
||||
@ -1,5 +1,6 @@
|
||||
(* Test that a string is cast to an address given a type annotation *)
|
||||
|
||||
const lst : list(int) = list [] ;
|
||||
const lst : list(int) = list []
|
||||
|
||||
const address : address = ("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address) ;
|
||||
const my_address : address =
|
||||
("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address)
|
||||
|
||||
@ -51,7 +51,7 @@ let annotation () : unit result =
|
||||
expect_eq_evaluate program "lst" (e_list [])
|
||||
in
|
||||
let%bind () =
|
||||
expect_eq_evaluate program "address" (e_address "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx")
|
||||
expect_eq_evaluate program "my_address" (e_address "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx")
|
||||
in
|
||||
ok ()
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user