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

Merge branch 'rinderknecht-dev' into 'dev'

Browse Source 
Refactoring of Ligodity (CameLIGO) and making an AST pretty-printer

See merge request ligolang/ligo!172
This commit is contained in:
Christian Rinderknecht 2019-11-06 12:18:54 +00:00
commit 70a9afcce2
40 changed files with 1689 additions and 1403 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

218
src/passes/1-parser/ligodity/AST.ml
View File

@ -1,6 +1,23 @@
(* Abstract Syntax Tree (AST) for CameLIGO *)
(* To disable warning about multiply-defined record labels. *)
[@@@warning "-30-40-42"]
(* Abstract Syntax Tree (AST) for Mini-ML *)
(* Utilities *)
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
@ -36,6 +53,11 @@ type kwd_type = Region.t
type kwd_with = Region.t
type kwd_let_entry = Region.t
(* Data constructors *)
type c_None = Region.t
type c_Some = Region.t
(* Symbols *)
type arrow = Region.t (* "->" *)
@ -111,7 +133,7 @@ type the_unit = lpar * rpar
(* The Abstract Syntax Tree *)
type t = {
decl : declaration Utils.nseq;
decl : declaration nseq;
eof : eof
}
@ -119,13 +141,12 @@ and ast = t
and declaration =
Let of (kwd_let * let_binding) reg
| LetEntry of (kwd_let_entry * let_binding) reg
| TypeDecl of type_decl reg
(* Non-recursive values *)
and let_binding = {
bindings : pattern list;
binders : pattern nseq;
lhs_type : (colon * type_expr) option;
eq : equal;
let_rhs : expr
@ -142,48 +163,53 @@ and type_decl = {
and type_expr =
TProd of cartesian
| TSum of (variant reg, vbar) Utils.nsepseq reg
| TRecord of record_type
| TSum of (variant reg, vbar) nsepseq reg
| TRecord of field_decl reg ne_injection reg
| TApp of (type_constr * type_tuple) reg
| TFun of (type_expr * arrow * type_expr) reg
| TPar of type_expr par reg
| TAlias of variable
| TVar of variable
and cartesian = (type_expr, times) Utils.nsepseq reg
and cartesian = (type_expr, times) nsepseq reg
and variant = {
constr : constr;
args : (kwd_of * cartesian) option
arg : (kwd_of * type_expr) option
}
and record_type = field_decl reg injection reg
and field_decl = {
field_name : field_name;
colon : colon;
field_type : type_expr
}
and type_tuple = (type_expr, comma) Utils.nsepseq par reg
and type_tuple = (type_expr, comma) nsepseq par reg
and pattern =
PTuple of (pattern, comma) Utils.nsepseq reg
| PList of list_pattern
| PVar of variable
PConstr of constr_pattern
| PUnit of the_unit reg
| PInt of (string * Z.t) reg
| PTrue of kwd_true
| PFalse of kwd_false
| PTrue of kwd_true
| PVar of variable
| PInt of (Lexer.lexeme * Z.t) reg
| PNat of (Lexer.lexeme * Z.t) reg
| PBytes of (Lexer.lexeme * Hex.t) reg
| PString of string reg
| PWild of wild
| PList of list_pattern
| PTuple of (pattern, comma) nsepseq reg
| PPar of pattern par reg
| PConstr of (constr * pattern option) reg
| PRecord of record_pattern
| PRecord of field_pattern reg ne_injection reg
| PTyped of typed_pattern reg
and constr_pattern =
PNone of c_None
| PSomeApp of (c_Some * pattern) reg
| PConstrApp of (constr * pattern option) reg
and list_pattern =
Sugar of pattern injection reg
| PCons of (pattern * cons * pattern) reg
PListComp of pattern injection reg
| PCons of (pattern * cons * pattern) reg
and typed_pattern = {
pattern : pattern;
@ -191,8 +217,6 @@ and typed_pattern = {
type_expr : type_expr
}
and record_pattern = field_pattern reg injection reg
and field_pattern = {
field_name : field_name;
eq : equal;
@ -201,77 +225,77 @@ and field_pattern = {
and expr =
ECase of expr case reg
| EAnnot of annot_expr reg
| ECond of cond_expr reg
| EAnnot of (expr * type_expr) reg
| ELogic of logic_expr
| EArith of arith_expr
| EString of string_expr
| EList of list_expr
| EConstr of constr_expr reg
| ERecord of record_expr
| EConstr of constr_expr
| ERecord of field_assign reg ne_injection reg
| EProj of projection reg
| EVar of variable
| ECall of (expr * expr Utils.nseq) reg
| ECall of (expr * expr nseq) reg
| EBytes of (string * Hex.t) reg
| EUnit of the_unit reg
| ETuple of (expr, comma) Utils.nsepseq reg
| ETuple of (expr, comma) nsepseq reg
| EPar of expr par reg
| ELetIn of let_in reg
| EFun of fun_expr reg
| ECond of conditional reg
| ESeq of sequence
and constr_expr = constr * expr option
and annot_expr = expr * type_expr
| ESeq of expr injection reg
and 'a injection = {
opening : opening;
elements : ('a, semi) Utils.sepseq;
terminator : semi option;
closing : closing
compound : compound;
elements : ('a, semi) sepseq;
terminator : semi option
}
and opening =
Begin of kwd_begin
| With of kwd_with
| LBrace of lbrace
| LBracket of lbracket
and 'a ne_injection = {
compound : compound;
ne_elements : ('a, semi) nsepseq;
terminator : semi option
}
and closing =
End of kwd_end
| RBrace of rbrace
| RBracket of rbracket
and compound =
BeginEnd of kwd_begin * kwd_end
| Braces of lbrace * rbrace
| Brackets of lbracket * rbracket
and list_expr =
Cons of cons bin_op reg
| List of expr injection reg
ECons of cons bin_op reg
| EListComp of expr injection reg
(*| Append of (expr * append * expr) reg*)
and string_expr =
Cat of cat bin_op reg
| String of string reg
| StrLit of string reg
and constr_expr =
ENone of c_None
| ESomeApp of (c_Some * expr) reg
| EConstrApp of (constr * expr option) 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 (string * Z.t) reg
| Nat of (string * Z.t) reg
| Mutez of (string * Z.t) reg
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 (string * Z.t) reg
| Nat of (string * Z.t) reg
| Mutez of (string * Z.t) 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
| True of kwd_true
| False of kwd_false
Or of kwd_or bin_op reg
| And of kwd_and bin_op reg
| Not of kwd_not un_op reg
| True of kwd_true
| False of kwd_false
and 'a bin_op = {
op : 'a;
@ -295,14 +319,12 @@ and comp_expr =
and projection = {
struct_name : variable;
selector : dot;
field_path : (selection, dot) Utils.nsepseq
field_path : (selection, dot) nsepseq
}
and selection =
FieldName of variable
| Component of (string * Z.t) reg par reg
and record_expr = field_assign reg injection reg
| Component of (string * Z.t) reg
and field_assign = {
field_name : field_name;
@ -310,15 +332,12 @@ and field_assign = {
field_expr : expr
}
and sequence = expr injection reg
and 'a case = {
kwd_match : kwd_match;
expr : expr;
opening : opening;
kwd_with : kwd_with;
lead_vbar : vbar option;
cases : ('a case_clause reg, vbar) Utils.nsepseq reg;
closing : closing
cases : ('a case_clause reg, vbar) nsepseq reg
}
and 'a case_clause = {
@ -335,14 +354,14 @@ and let_in = {
}
and fun_expr = {
kwd_fun : kwd_fun;
params : pattern list;
p_annot : (colon * type_expr) option;
arrow : arrow;
body : expr
kwd_fun : kwd_fun;
binders : pattern nseq;
lhs_type : (colon * type_expr) option;
arrow : arrow;
body : expr
}
and conditional = {
and cond_expr = {
kwd_if : kwd_if;
test : expr;
kwd_then : kwd_then;
@ -360,19 +379,27 @@ let type_expr_to_region = function
| TApp {region; _}
| TFun {region; _}
| TPar {region; _}
| TAlias {region; _} -> region
| TVar {region; _} -> region
let list_pattern_to_region = function
Sugar {region; _} | PCons {region; _} -> region
PListComp {region; _} | PCons {region; _} -> region
let constr_pattern_to_region = function
PNone region | PSomeApp {region;_}
| PConstrApp {region;_} -> region
let pattern_to_region = function
PList p -> list_pattern_to_region p
| PTuple {region;_} | PVar {region;_}
| PUnit {region;_} | PInt {region;_}
| PList p -> list_pattern_to_region p
| PConstr c -> constr_pattern_to_region c
| PUnit {region;_}
| PTrue region | PFalse region
| PTuple {region;_} | PVar {region;_}
| PInt {region;_}
| PString {region;_} | PWild region
| PConstr {region; _} | PPar {region;_}
| PRecord {region; _} | PTyped {region; _} -> region
| PPar {region;_}
| PRecord {region; _} | PTyped {region; _}
| PNat {region; _} | PBytes {region; _}
-> region
let bool_expr_to_region = function
Or {region;_} | And {region;_}
@ -395,24 +422,29 @@ let arith_expr_to_region = function
| Nat {region; _} -> region
let string_expr_to_region = function
String {region;_} | Cat {region;_} -> region
StrLit {region;_} | Cat {region;_} -> region
let list_expr_to_region = function
Cons {region; _} | List {region; _}
ECons {region; _} | EListComp {region; _}
(* | Append {region; _}*) -> region
and constr_expr_to_region = function
ENone region
| EConstrApp {region; _}
| ESomeApp {region; _} -> region
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
| EConstr e -> constr_expr_to_region e
| EAnnot {region;_ } | ELetIn {region;_} | EFun {region;_}
| ECond {region;_} | ETuple {region;_} | ECase {region;_}
| ECall {region;_} | EVar {region; _} | EProj {region; _}
| EUnit {region;_} | EPar {region;_} | EBytes {region; _}
| ESeq {region; _} | ERecord {region; _}
| EConstr {region; _} -> region
| ESeq {region; _} | ERecord {region; _} -> region
let rec unpar = function
EPar {value={inside=expr;_}; _} -> unpar expr
| e -> e
let selection_to_region = function
FieldName f -> f.region
| Component c -> c.region

311
src/passes/1-parser/ligodity/AST.mli
View File

@ -43,6 +43,11 @@ type kwd_true = Region.t
type kwd_type = Region.t
type kwd_with = Region.t
(* Data constructors *)
type c_None = Region.t
type c_Some = Region.t
(* Symbols *)
type arrow = Region.t (* "->" *)
@ -114,7 +119,7 @@ type the_unit = lpar * rpar
(* The Abstract Syntax Tree (finally) *)
type t = {
decl : declaration Utils.nseq;
decl : declaration nseq;
eof : eof
}
@ -123,14 +128,13 @@ and ast = t
and eof = Region.t
and declaration =
Let of (kwd_let * let_binding) reg (* let x = e *)
| LetEntry of (kwd_let_entry * let_binding) reg (* let%entry x = e *)
| TypeDecl of type_decl reg (* type ... *)
Let of (kwd_let * let_binding) reg (* let x = e *)
| TypeDecl of type_decl reg (* type ... *)
(* Non-recursive values *)
and let_binding = { (* p = e p : t = e *)
bindings : pattern list;
binders : pattern nseq;
lhs_type : (colon * type_expr) option;
eq : equal;
let_rhs : expr
@ -147,48 +151,53 @@ and type_decl = {
and type_expr =
TProd of cartesian
| TSum of (variant reg, vbar) Utils.nsepseq reg
| TRecord of record_type
| TSum of (variant reg, vbar) nsepseq reg
| TRecord of field_decl reg ne_injection reg
| TApp of (type_constr * type_tuple) reg
| TFun of (type_expr * arrow * type_expr) reg
| TPar of type_expr par reg
| TAlias of variable
| TVar of variable
and cartesian = (type_expr, times) Utils.nsepseq reg
and cartesian = (type_expr, times) nsepseq reg
and variant = {
constr : constr;
args : (kwd_of * cartesian) option
arg : (kwd_of * type_expr) option
}
and record_type = field_decl reg injection reg
and field_decl = {
field_name : field_name;
colon : colon;
field_type : type_expr
}
and type_tuple = (type_expr, comma) Utils.nsepseq par reg
and type_tuple = (type_expr, comma) nsepseq par reg
and pattern =
PTuple of (pattern, comma) Utils.nsepseq reg (* p1, p2, ... *)
| PList of list_pattern
| PVar of variable (* x *)
PConstr of constr_pattern (* True () None A B(3,"") *)
| PUnit of the_unit reg (* () *)
| PInt of (string * Z.t) reg (* 7 *)
| PTrue of kwd_true (* true *)
| PFalse of kwd_false (* false *)
| PTrue of kwd_true (* true *)
| PVar of variable (* x *)
| PInt of (Lexer.lexeme * Z.t) reg (* 7 *)
| PNat of (Lexer.lexeme * Z.t) reg (* 7p 7n *)
| PBytes of (Lexer.lexeme * Hex.t) reg (* 0xAA0F *)
| PString of string reg (* "foo" *)
| PWild of wild (* _ *)
| PList of list_pattern
| PTuple of (pattern, comma) nsepseq reg (* p1, p2, ... *)
| PPar of pattern par reg (* (p) *)
| PConstr of (constr * pattern option) reg (* A B(3,"") *)
| PRecord of record_pattern (* {a=...; ...} *)
| PRecord of field_pattern reg ne_injection reg (* {a=...; ...} *)
| PTyped of typed_pattern reg (* (x : int) *)
and constr_pattern =
| PNone of c_None
| PSomeApp of (c_Some * pattern) reg
| PConstrApp of (constr * pattern option) reg
and list_pattern =
Sugar of pattern injection reg (* [p1; p2; ...] *)
| PCons of (pattern * cons * pattern) reg (* p1 :: p2 *)
PListComp of pattern injection reg (* [p1; p2; ...] *)
| PCons of (pattern * cons * pattern) reg (* p1 :: p2 *)
and typed_pattern = {
pattern : pattern;
@ -196,8 +205,6 @@ and typed_pattern = {
type_expr : type_expr
}
and record_pattern = field_pattern reg injection reg
and field_pattern = {
field_name : field_name;
eq : equal;
@ -205,78 +212,78 @@ and field_pattern = {
}
and expr =
ECase of expr case reg (* p1 -> e1 | p2 -> e2 | ... *)
| EAnnot of annot_expr reg (* e : t *)
ECase of expr case reg (* p1 -> e1 | p2 -> e2 | ... *)
| ECond of cond_expr reg (* if e1 then e2 else e3 *)
| EAnnot of (expr * type_expr) reg (* e : t *)
| ELogic of logic_expr
| EArith of arith_expr
| EString of string_expr
| EList of list_expr
| EConstr of constr_expr reg
| ERecord of record_expr (* {f1=e1; ... } *)
| EProj of projection reg (* x.y.z M.x.y *)
| EVar of variable (* x *)
| ECall of (expr * expr Utils.nseq) reg (* e e1 ... en *)
| EBytes of (string * Hex.t) reg (* 0xAEFF *)
| EUnit of the_unit reg (* () *)
| ETuple of (expr, comma) Utils.nsepseq reg (* e1, e2, ... *)
| EPar of expr par reg (* (e) *)
| ELetIn of let_in reg (* let p1 = e1 and p2 = e2 and ... in e *)
| EFun of fun_expr reg (* fun x -> e *)
| ECond of conditional reg (* if e1 then e2 else e3 *)
| ESeq of sequence (* begin e1; e2; ... ; en end *)
and constr_expr = constr * expr option
and annot_expr = expr * type_expr
| EList of list_expr (* x::y::l [1;2;3] *)
| EConstr of constr_expr (* A B(1,A) (C A) *)
| ERecord of field_assign reg ne_injection reg (* {f1=e1; ... } *)
| EProj of projection reg (* x.y.z M.x.y *)
| EVar of variable (* x *)
| ECall of (expr * expr nseq) reg (* e e1 ... en *)
| EBytes of (string * Hex.t) reg (* 0xAEFF *)
| EUnit of the_unit reg (* () *)
| ETuple of (expr, comma) nsepseq reg (* e1, e2, ... *)
| EPar of expr par reg (* (e) *)
| ELetIn of let_in reg (* let p1 = e1 and p2 = e2 and ... in e *)
| EFun of fun_expr reg (* fun x -> e *)
| ESeq of expr injection reg (* begin e1; e2; ... ; en end *)
and 'a injection = {
opening : opening;
elements : ('a, semi) Utils.sepseq;
terminator : semi option;
closing : closing
compound : compound;
elements : ('a, semi) sepseq;
terminator : semi option
}
and opening =
Begin of kwd_begin
| With of kwd_with
| LBrace of lbrace
| LBracket of lbracket
and 'a ne_injection = {
compound : compound;
ne_elements : ('a, semi) nsepseq;
terminator : semi option
}
and closing =
End of kwd_end
| RBrace of rbrace
| RBracket of rbracket
and compound =
BeginEnd of kwd_begin * kwd_end
| Braces of lbrace * rbrace
| Brackets of lbracket * rbracket
and list_expr =
Cons of cat bin_op reg (* e1 :: e3 *)
| List of expr injection reg (* [e1; e2; ...] *)
(*| Append of (expr * append * expr) reg *) (* e1 @ e2 *)
ECons of cat bin_op reg (* e1 :: e3 *)
| EListComp of expr injection reg (* [e1; e2; ...] *)
(*| Append of (expr * append * expr) reg *) (* e1 @ e2 *)
and string_expr =
Cat of cat bin_op reg (* e1 ^ e2 *)
| String of string reg (* "foo" *)
Cat of cat bin_op reg (* e1 ^ e2 *)
| StrLit of string reg (* "foo" *)
and constr_expr =
ENone of c_None
| ESomeApp of (c_Some * expr) reg
| EConstrApp of (constr * expr option) reg
and arith_expr =
Add of plus bin_op reg (* e1 + e2 *)
| Sub of minus bin_op reg (* e1 - e2 *)
| Mult of times bin_op reg (* e1 * e2 *)
| Div of slash bin_op reg (* e1 / e2 *)
| Mod of kwd_mod bin_op reg (* e1 mod e2 *)
| Neg of minus un_op reg (* -e *)
| Int of (string * Z.t) reg (* 12345 *)
| Nat of (string * Z.t) reg (* 3p *)
| Mutez of (string * Z.t) reg (* 1.00tz 3tz *)
Add of plus bin_op reg (* e1 + e2 *)
| Sub of minus bin_op reg (* e1 - e2 *)
| Mult of times bin_op reg (* e1 * e2 *)
| Div of slash bin_op reg (* e1 / e2 *)
| Mod of kwd_mod bin_op reg (* e1 mod e2 *)
| Neg of minus un_op reg (* -e *)
| Int of (string * Z.t) reg (* 12345 *)
| Nat of (string * Z.t) reg (* 3n *)
| Mutez of (string * Z.t) reg (* 1.00tz 3tz 233mutez *)
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
| True of kwd_true
| False of kwd_false
Or of kwd_or bin_op reg
| And of kwd_and bin_op reg
| Not of kwd_not un_op reg
| True of kwd_true
| False of kwd_false
and 'a bin_op = {
op : 'a;
@ -300,14 +307,12 @@ and comp_expr =
and projection = {
struct_name : variable;
selector : dot;
field_path : (selection, dot) Utils.nsepseq
field_path : (selection, dot) nsepseq
}
and selection =
FieldName of variable
| Component of (string * Z.t) reg par reg
and record_expr = field_assign reg injection reg
| Component of (string * Z.t) reg
and field_assign = {
field_name : field_name;
@ -315,15 +320,12 @@ and field_assign = {
field_expr : expr
}
and sequence = expr injection reg
and 'a case = {
kwd_match : kwd_match;
expr : expr;
opening : opening;
kwd_with : kwd_with;
lead_vbar : vbar option;
cases : ('a case_clause reg, vbar) Utils.nsepseq reg;
closing : closing
cases : ('a case_clause reg, vbar) nsepseq reg
}
and 'a case_clause = {
@ -340,139 +342,26 @@ and let_in = {
}
and fun_expr = {
kwd_fun : kwd_fun;
params : pattern list;
p_annot : (colon * type_expr) option;
arrow : arrow;
body : expr
kwd_fun : kwd_fun;
binders : pattern nseq;
lhs_type : (colon * type_expr) option;
arrow : arrow;
body : expr
}
and conditional = {
kwd_if : kwd_if;
test : expr;
kwd_then : kwd_then;
ifso : expr;
kwd_else : kwd_else;
ifnot : expr
and cond_expr = {
kwd_if : kwd_if;
test : expr;
kwd_then : kwd_then;
ifso : expr;
kwd_else : kwd_else;
ifnot : expr
}
(* Normalising nodes of the AST so the interpreter is more uniform and
no source regions are lost in order to enable all manner of
source-to-source transformations from the rewritten AST and the
initial source.
The first kind of expressions to be normalised is lambdas, like:
fun a -> fun b -> a
fun a b -> a
fun a (b,c) -> a
to become
fun a -> fun b -> a
fun a -> fun b -> a
fun a -> fun x -> let (b,c) = x in a
The second kind is let-bindings introducing functions without the
"fun" keyword, like
let g a b = a
let h a (b,c) = a
which become
let g = fun a -> fun b -> a
let h = fun a -> fun x -> let (b,c) = x in a
The former is actually a subcase of the latter. Indeed, the general
shape of the former is
fun <patterns> -> <expr>
and the latter is
let <ident> <patterns> = <expr>
The isomorphic parts are "<patterns> -> <expr>" and "<patterns> =
<expr>".
The call [norm patterns sep expr], where [sep] is a region either
of an "->" or a "=", evaluates in a function expression (lambda),
as expected. In order to get the regions right in the case of
lambdas, additional regions are passed: [norm ~reg:(total,kwd_fun)
patterns sep expr], where [total] is the region for the whole
lambda (even if the resulting lambda is actually longer: we want to
keep the region of the original), and the region of the original
"fun" keyword.
*)
(*
type sep = Region.t
val norm : ?reg:(Region.t * kwd_fun) -> pattern Utils.nseq -> sep -> expr -> fun_expr
*)
(* Undoing the above rewritings (for debugging by comparison with the
lexer, and to feed the source-to-source transformations with only
tokens that originated from the original input.
Unparsing is performed on an expression which is expected to be a
series "fun ... -> fun ... -> ...". Either this expression is the
right-hand side of a let, or it is not. These two cases are
distinguished by the function [unparse], depending on the first
keyword "fun" being concrete or ghostly (virtual). In the former
case, we are unparsing an expression which was originally starting
with "fun"; in the latter, we are unparsing an expression that was
parsed on the right-hand side of a let construct. In other words,
in the former case, we expect to reconstruct
let f p_1 ... p_n = e
whereas, in the second case, we want to obtain
fun p_1 ... p_n -> e
In any case, the heart of the unparsing is the same, and this is
why the data constructors [`Fun] and [`Let] of the type [unparsed]
share a common type: [pattern * Region.t * expr], the region can
either actually denote the alias type [arrow] or [eq]. Let us
assume a value of this triple [patterns, separator_region,
expression]. Then the context (handled by [unparse]) decides if
[separator_region] is the region of a "=" sign or "->".
There are two forms to be unparsed:
fun x_1 -> let p_1 = x_1 in ... fun x_n -> let p_n = x_n in e
or
fun p_1 -> ... fun p_n -> e
in the first case, the rightmost "=" becomes [separator_region]
above, whereas, in the second case, it is the rightmost "->".
Here are some example covering all cases:
let rec f = fun a -> fun b -> a
let rec g = fun a b -> a
let rec h = fun a (b,c) -> a
let rec fst = fun (x,_) -> x
let rec g a b = a
let rec h (b,c) a (d,e) = a
let len = (fun n _ -> n)
let f l = let n = l in n
*)
(* Projecting regions from sundry nodes of the AST. See the first
comment at the beginning of this file. *)
val pattern_to_region : pattern -> Region.t
val expr_to_region : expr -> Region.t
val type_expr_to_region : type_expr -> Region.t
(* Simplifications *)
(* The call [unpar e] is the expression [e] if [e] is not
parenthesised, otherwise it is the non-parenthesised expressions it
contains. *)
val unpar : expr -> expr
val selection_to_region : selection -> Region.t

13
src/passes/1-parser/ligodity/LexToken.mli
View File

@ -83,7 +83,7 @@ type t =
| Int of (string * Z.t) Region.reg
| Nat of (string * Z.t) Region.reg
| Mutez of (string * Z.t) Region.reg
| Str of string Region.reg
| String of string Region.reg
| Bytes of (string * Hex.t) Region.reg
(* Keywords *)
@ -107,15 +107,10 @@ type t =
| Type of Region.t
| With of Region.t
(* Liquidity-specific *)
(* Data constructors *)
| LetEntry of Region.t
| MatchNat of Region.t
(*
| Contract
| Sig
| Struct
*)
| C_None of Region.t (* "None" *)
| C_Some of Region.t (* "Some" *)
(* Virtual tokens *)

286
src/passes/1-parser/ligodity/LexToken.mll
View File

@ -52,7 +52,7 @@ type t =
| NE of Region.t (* "<>" *)
| LT of Region.t (* "<" *)
| GT of Region.t (* ">" *)
| LE of Region.t (* "=<" *)
| LE of Region.t (* "<=" *)
| GE of Region.t (* ">=" *)
| BOOL_OR of Region.t (* "||" *)
@ -65,7 +65,7 @@ type t =
| Int of (string * Z.t) Region.reg
| Nat of (string * Z.t) Region.reg
| Mutez of (string * Z.t) Region.reg
| Str of string Region.reg
| String of string Region.reg
| Bytes of (string * Hex.t) Region.reg
(* Keywords *)
@ -89,15 +89,10 @@ type t =
| Type of Region.t
| With of Region.t
(* Liquidity-specific *)
(* Data constructors *)
| LetEntry of Region.t
| MatchNat of Region.t
(*
| Contract
| Sig
| Struct
*)
| C_None of Region.t (* "None" *)
| C_Some of Region.t (* "Some" *)
(* Virtual tokens *)
@ -106,125 +101,131 @@ type t =
type token = t
let proj_token = function
| ARROW region -> region, "ARROW"
| CONS region -> region, "CONS"
| CAT region -> region, "CAT"
| MINUS region -> region, "MINUS"
| PLUS region -> region, "PLUS"
| SLASH region -> region, "SLASH"
| TIMES region -> region, "TIMES"
| LPAR region -> region, "LPAR"
| RPAR region -> region, "RPAR"
| LBRACKET region -> region, "LBRACKET"
| RBRACKET region -> region, "RBRACKET"
| LBRACE region -> region, "LBRACE"
| RBRACE region -> region, "RBRACE"
| COMMA region -> region, "COMMA"
| SEMI region -> region, "SEMI"
| VBAR region -> region, "VBAR"
| COLON region -> region, "COLON"
| DOT region -> region, "DOT"
| WILD region -> region, "WILD"
| EQ region -> region, "EQ"
| NE region -> region, "NE"
| LT region -> region, "LT"
| GT region -> region, "GT"
| LE region -> region, "LE"
| GE region -> region, "GE"
| BOOL_OR region -> region, "BOOL_OR"
| BOOL_AND region -> region, "BOOL_AND"
| Ident Region.{region; value} ->
ARROW region -> region, "ARROW"
| CONS region -> region, "CONS"
| CAT region -> region, "CAT"
| MINUS region -> region, "MINUS"
| PLUS region -> region, "PLUS"
| SLASH region -> region, "SLASH"
| TIMES region -> region, "TIMES"
| LPAR region -> region, "LPAR"
| RPAR region -> region, "RPAR"
| LBRACKET region -> region, "LBRACKET"
| RBRACKET region -> region, "RBRACKET"
| LBRACE region -> region, "LBRACE"
| RBRACE region -> region, "RBRACE"
| COMMA region -> region, "COMMA"
| SEMI region -> region, "SEMI"
| VBAR region -> region, "VBAR"
| COLON region -> region, "COLON"
| DOT region -> region, "DOT"
| WILD region -> region, "WILD"
| EQ region -> region, "EQ"
| NE region -> region, "NE"
| LT region -> region, "LT"
| GT region -> region, "GT"
| LE region -> region, "LE"
| GE region -> region, "GE"
| BOOL_OR region -> region, "BOOL_OR"
| BOOL_AND region -> region, "BOOL_AND"
| Ident Region.{region; value} ->
region, sprintf "Ident %s" value
| Constr Region.{region; value} ->
| Constr Region.{region; value} ->
region, sprintf "Constr %s" value
| Int Region.{region; value = s,n} ->
| Int Region.{region; value = s,n} ->
region, sprintf "Int (\"%s\", %s)" s (Z.to_string n)
| Nat Region.{region; value = s,n} ->
| Nat Region.{region; value = s,n} ->
region, sprintf "Nat (\"%s\", %s)" s (Z.to_string n)
| Mutez Region.{region; value = s,n} ->
| Mutez Region.{region; value = s,n} ->
region, sprintf "Mutez (\"%s\", %s)" s (Z.to_string n)
| Str Region.{region; value} ->
| String Region.{region; value} ->
region, sprintf "Str %s" value
| Bytes Region.{region; value = s,b} ->
| Bytes Region.{region; value = s,b} ->
region,
sprintf "Bytes (\"%s\", \"0x%s\")"
s (Hex.to_string b)
| Begin region -> region, "Begin"
| Else region -> region, "Else"
| End region -> region, "End"
| False region -> region, "False"
| Fun region -> region, "Fun"
| If region -> region, "If"
| In region -> region, "In"
| Let region -> region, "Let"
| Match region -> region, "Match"
| Mod region -> region, "Mod"
| Not region -> region, "Not"
| Of region -> region, "Of"
| Or region -> region, "Or"
| Then region -> region, "Then"
| True region -> region, "True"
| Type region -> region, "Type"
| With region -> region, "With"
| LetEntry region -> region, "LetEntry"
| MatchNat region -> region, "MatchNat"
| EOF region -> region, "EOF"
| Begin region -> region, "Begin"
| Else region -> region, "Else"
| End region -> region, "End"
| False region -> region, "False"
| Fun region -> region, "Fun"
| If region -> region, "If"
| In region -> region, "In"
| Let region -> region, "Let"
| Match region -> region, "Match"
| Mod region -> region, "Mod"
| Not region -> region, "Not"
| Of region -> region, "Of"
| Or region -> region, "Or"
| Then region -> region, "Then"
| True region -> region, "True"
| Type region -> region, "Type"
| With region -> region, "With"
| C_None region -> region, "C_None"
| C_Some region -> region, "C_Some"
| EOF region -> region, "EOF"
let to_lexeme = function
| ARROW _ -> "->"
| CONS _ -> "::"
| CAT _ -> "^"
| MINUS _ -> "-"
| PLUS _ -> "+"
| SLASH _ -> "/"
| TIMES _ -> "*"
| LPAR _ -> "("
| RPAR _ -> ")"
| LBRACKET _ -> "["
| RBRACKET _ -> "]"
| LBRACE _ -> "{"
| RBRACE _ -> "}"
| COMMA _ -> ","
| SEMI _ -> ";"
| VBAR _ -> "|"
| COLON _ -> ":"
| DOT _ -> "."
| WILD _ -> "_"
| EQ _ -> "="
| NE _ -> "<>"
| LT _ -> "<"
| GT _ -> ">"
| LE _ -> "=<"
| GE _ -> ">="
| BOOL_OR _ -> "||"
| BOOL_AND _ -> "&&"
| Ident id -> id.Region.value
| Constr id -> id.Region.value
| Int i
| Nat i
| Mutez i -> fst i.Region.value
| Str s -> s.Region.value
| Bytes b -> fst b.Region.value
| Begin _ -> "begin"
| Else _ -> "else"
| End _ -> "end"
| False _ -> "false"
| Fun _ -> "fun"
| If _ -> "if"
| In _ -> "in"
| Let _ -> "let"
| Match _ -> "match"
| Mod _ -> "mod"
| Not _ -> "not"
| Of _ -> "of"
| Or _ -> "or"
| True _ -> "true"
| Type _ -> "type"
| Then _ -> "then"
| With _ -> "with"
| LetEntry _ -> "let%entry"
| MatchNat _ -> "match%nat"
| EOF _ -> ""
ARROW _ -> "->"
| CONS _ -> "::"
| CAT _ -> "^"
| MINUS _ -> "-"
| PLUS _ -> "+"
| SLASH _ -> "/"
| TIMES _ -> "*"
| LPAR _ -> "("
| RPAR _ -> ")"
| LBRACKET _ -> "["
| RBRACKET _ -> "]"
| LBRACE _ -> "{"
| RBRACE _ -> "}"
| COMMA _ -> ","
| SEMI _ -> ";"
| VBAR _ -> "|"
| COLON _ -> ":"
| DOT _ -> "."
| WILD _ -> "_"
| EQ _ -> "="
| NE _ -> "<>"
| LT _ -> "<"
| GT _ -> ">"
| LE _ -> "<="
| GE _ -> ">="
| BOOL_OR _ -> "||"
| BOOL_AND _ -> "&&"
| Ident id -> id.Region.value
| Constr id -> id.Region.value
| Int i
| Nat i
| Mutez i -> fst i.Region.value
| String s -> s.Region.value
| Bytes b -> fst b.Region.value
| Begin _ -> "begin"
| Else _ -> "else"
| End _ -> "end"
| False _ -> "false"
| Fun _ -> "fun"
| If _ -> "if"
| In _ -> "in"
| Let _ -> "let"
| Match _ -> "match"
| Mod _ -> "mod"
| Not _ -> "not"
| Of _ -> "of"
| Or _ -> "or"
| True _ -> "true"
| Type _ -> "type"
| Then _ -> "then"
| With _ -> "with"
| C_None _ -> "None"
| C_Some _ -> "Some"
| EOF _ -> ""
let to_string token ?(offsets=true) mode =
let region, val_str = proj_token token in
@ -257,9 +258,7 @@ let keywords = [
(fun reg -> Then reg);
(fun reg -> True reg);
(fun reg -> Type reg);
(fun reg -> With reg);
(fun reg -> LetEntry reg);
(fun reg -> MatchNat reg);
(fun reg -> With reg)
]
let reserved =
@ -302,8 +301,8 @@ let reserved =
|> add "while"
let constructors = [
(fun reg -> False reg);
(fun reg -> True reg);
(fun reg -> C_None reg);
(fun reg -> C_Some reg)
]
let add map (key, value) = SMap.add key value map
@ -336,7 +335,7 @@ let small = ['a'-'z']
let capital = ['A'-'Z']
let letter = small | capital
let digit = ['0'-'9']
let ident = small (letter | '_' | digit | '%')*
let ident = small (letter | '_' | digit)*
let constr = capital (letter | '_' | digit)*
(* Rules *)
@ -362,7 +361,8 @@ and scan_constr region lexicon = parse
(* Smart constructors (injections) *)
let mk_string lexeme region = Str Region.{region; value=lexeme}
let mk_string lexeme region =
String Region.{region; value=lexeme}
let mk_bytes lexeme region =
let norm = Str.(global_replace (regexp "_") "" lexeme) in
@ -370,27 +370,27 @@ let mk_bytes lexeme region =
in Bytes Region.{region; value}
let mk_int lexeme region =
let z = Str.(global_replace (regexp "_") "" lexeme)
|> Z.of_string in
if Z.equal z Z.zero && lexeme <> "0"
then Error Non_canonical_zero
else Ok (Int Region.{region; value = lexeme, z})
let z =
Str.(global_replace (regexp "_") "" lexeme) |> Z.of_string
in if Z.equal z Z.zero && lexeme <> "0"
then Error Non_canonical_zero
else Ok (Int Region.{region; value = lexeme,z})
type nat_err =
Invalid_natural
| Non_canonical_zero_nat
let mk_nat lexeme region =
match (String.index_opt lexeme 'p') with
match (String.index_opt lexeme 'n') with
| None -> Error Invalid_natural
| Some _ -> (
let z =
Str.(global_replace (regexp "_") "" lexeme) |>
Str.(global_replace (regexp "p") "") |>
Str.(global_replace (regexp "n") "") |>
Z.of_string in
if Z.equal z Z.zero && lexeme <> "0p"
if Z.equal z Z.zero && lexeme <> "0n"
then Error Non_canonical_zero_nat
else Ok (Nat Region.{region; value = lexeme, z})
else Ok (Nat Region.{region; value = lexeme,z})
)
let mk_mutez lexeme region =
@ -433,32 +433,30 @@ let mk_sym lexeme region =
| ">" -> Ok (GT region)
| ">=" -> Ok (GE region)
(* Lexemes specific to CameLIGO *)
| "<>" -> Ok (NE region)
| "::" -> Ok (CONS region)
| "||" -> Ok (BOOL_OR region)
| "&&" -> Ok (BOOL_AND region)
| a -> failwith ("Not understood token: " ^ a)
(* Invalid lexemes *)
| _ -> Error Invalid_symbol
(* Identifiers *)
let mk_ident' lexeme region lexicon =
let mk_ident lexeme region =
Lexing.from_string lexeme |> scan_ident region lexicon
let mk_ident lexeme region = mk_ident' lexeme region lexicon
(* Constructors *)
let mk_constr' lexeme region lexicon =
let mk_constr lexeme region =
Lexing.from_string lexeme |> scan_constr region lexicon
let mk_constr lexeme region = mk_constr' lexeme region lexicon
(* Predicates *)
let is_string = function
Str _ -> true
String _ -> true
| _ -> false
let is_bytes = function
@ -490,8 +488,6 @@ let is_kwd = function
| Then _
| True _
| Type _
| LetEntry _
| MatchNat _
| With _ -> true
| _ -> false

31
src/passes/1-parser/ligodity/ParToken.mly
View File

@ -1,6 +1,20 @@
%{
%}
(* Tokens (mirroring thise defined in module LexToken) *)
(* Literals *)
%token <string Region.reg> String
%token <(LexToken.lexeme * Hex.t) Region.reg> Bytes
%token <(string * Z.t) Region.reg> Int
%token <(string * Z.t) Region.reg> Nat
%token <(string * Z.t) Region.reg> Mutez
%token <string Region.reg> Ident
%token <string Region.reg> Constr
(* Symbols *)
%token <Region.t> MINUS
%token <Region.t> PLUS
%token <Region.t> SLASH
@ -36,13 +50,7 @@
%token <Region.t> BOOL_OR
%token <Region.t> BOOL_AND
%token <string Region.reg> Ident
%token <string Region.reg> Constr
%token <string Region.reg> Str
%token <(string * Z.t) Region.reg> Int
%token <(string * Z.t) Region.reg> Nat
%token <(string * Z.t) Region.reg> Mutez
(* Keywords *)
(*%token And*)
%token <Region.t> Begin
@ -62,8 +70,13 @@
%token <Region.t> True
%token <Region.t> Type
%token <Region.t> With
%token <Region.t> LetEntry
%token <Region.t> MatchNat
(* Data constructors *)
%token <Region.t> C_None (* "None" *)
%token <Region.t> C_Some (* "Some" *)
(* Virtual tokens *)
%token <Region.t> EOF

756
src/passes/1-parser/ligodity/Parser.mly
View File

File diff suppressed because it is too large Load Diff

809
src/passes/1-parser/ligodity/ParserLog.ml
View File

@ -24,7 +24,8 @@ let print_sepseq buffer sep print = function
None -> ()
| Some seq -> print_nsepseq buffer sep print seq
let print_csv buffer print = print_nsepseq buffer "," print
let print_csv buffer print {value; _} =
print_nsepseq buffer "," print value
let print_token buffer (reg: Region.t) conc =
let line = sprintf "%s: %s\n" (compact reg) conc
@ -34,6 +35,11 @@ let print_var buffer Region.{region; value} =
let line = sprintf "%s: Ident %s\n" (compact region) value
in Buffer.add_string buffer line
let print_constr buffer {region; value=lexeme} =
let line = sprintf "%s: Constr \"%s\"\n"
(compact region) lexeme
in Buffer.add_string buffer line
let print_pvar buffer Region.{region; value} =
let line = sprintf "%s: PVar %s\n" (compact region) value
in Buffer.add_string buffer line
@ -42,8 +48,8 @@ let print_uident buffer Region.{region; value} =
let line = sprintf "%s: Uident %s\n" (compact region) value
in Buffer.add_string buffer line
let print_str buffer Region.{region; value} =
let line = sprintf "%s: Str \"%s\"\n" (compact region) value
let print_string buffer Region.{region; value} =
let line = sprintf "%s: StrLit %s\n" (compact region) value
in Buffer.add_string buffer line
let print_bytes buffer Region.{region; value=lexeme, abstract} =
@ -52,9 +58,15 @@ let print_bytes buffer Region.{region; value=lexeme, abstract} =
in Buffer.add_string buffer line
let print_int buffer Region.{region; value=lex,z} =
let line = sprintf "PInt %s (%s)" lex (Z.to_string z)
let line = sprintf "Int %s (%s)" lex (Z.to_string z)
in print_token buffer region line
let print_nat buffer {region; value = lexeme, abstract} =
let line = sprintf "%s: Nat (\"%s\", %s)\n"
(compact region) lexeme
(Z.to_string abstract)
in Buffer.add_string buffer line
let rec print_tokens buffer {decl;eof} =
Utils.nseq_iter (print_statement buffer) decl;
print_token buffer eof "EOF"
@ -63,9 +75,6 @@ and print_statement buffer = function
Let {value=kwd_let, let_binding; _} ->
print_token buffer kwd_let "let";
print_let_binding buffer let_binding
| LetEntry {value=kwd_let_entry, let_binding; _} ->
print_token buffer kwd_let_entry "let%entry";
print_let_binding buffer let_binding
| TypeDecl {value={kwd_type; name; eq; type_expr}; _} ->
print_token buffer kwd_type "type";
print_var buffer name;
@ -73,13 +82,13 @@ and print_statement buffer = function
print_type_expr buffer type_expr
and print_type_expr buffer = function
TProd prod -> print_cartesian buffer prod
| TSum {value; _} -> print_nsepseq buffer "|" print_variant value
| TRecord t -> print_record_type buffer t
| TApp app -> print_type_app buffer app
| TPar par -> print_type_par buffer par
| TAlias var -> print_var buffer var
| TFun t -> print_fun_type buffer t
TProd prod -> print_cartesian buffer prod
| TSum {value; _} -> print_nsepseq buffer "|" print_variant value
| TRecord t -> print_rec_type_expr buffer t
| TApp app -> print_type_app buffer app
| TPar par -> print_type_par buffer par
| TVar var -> print_var buffer var
| TFun t -> print_fun_type buffer t
and print_fun_type buffer {value; _} =
let domain, arrow, range = value in
@ -103,36 +112,33 @@ and print_type_par buffer {value={lpar;inside=t;rpar}; _} =
print_type_expr buffer t;
print_token buffer rpar ")"
and print_projection buffer node =
let {struct_name; selector; field_path} = node in
and print_projection buffer {value; _} =
let {struct_name; selector; field_path} = value in
print_var buffer struct_name;
print_token buffer selector ".";
print_nsepseq buffer "." print_selection field_path
and print_selection buffer = function
FieldName id ->
print_var buffer id
| Component {value; _} ->
let {lpar; inside; rpar} = value in
let Region.{value=lexeme,z; region} = inside in
print_token buffer lpar "(";
print_token buffer region
(sprintf "Int %s (%s)" lexeme (Z.to_string z));
print_token buffer rpar ")"
FieldName id -> print_var buffer id
| Component c -> print_int buffer c
and print_cartesian buffer Region.{value;_} =
print_nsepseq buffer "*" print_type_expr value
and print_variant buffer {value = {constr; args}; _} =
and print_variant buffer {value = {constr; arg}; _} =
print_uident buffer constr;
match args with
match arg with
None -> ()
| Some (kwd_of, cartesian) ->
| Some (kwd_of, t_expr) ->
print_token buffer kwd_of "of";
print_cartesian buffer cartesian
print_type_expr buffer t_expr
and print_record_type buffer record_type =
print_injection buffer print_field_decl record_type
and print_rec_type_expr buffer {value; _} =
let {compound; ne_elements; terminator} = value in
print_open_compound buffer compound;
print_nsepseq buffer ";" print_field_decl ne_elements;
print_terminator buffer terminator;
print_close_compound buffer compound
and print_field_decl buffer {value; _} =
let {field_name; colon; field_type} = value
@ -143,29 +149,37 @@ and print_field_decl buffer {value; _} =
and print_injection :
'a.Buffer.t -> (Buffer.t -> 'a -> unit) -> 'a injection reg -> unit =
fun buffer print {value; _} ->
let {opening; elements; terminator; closing} = value in
print_opening buffer opening;
print_sepseq buffer ";" print elements;
print_terminator buffer terminator;
print_closing buffer closing
let {compound; elements; terminator} = value in
print_open_compound buffer compound;
print_sepseq buffer ";" print elements;
print_terminator buffer terminator;
print_close_compound buffer compound
and print_opening buffer = function
Begin region -> print_token buffer region "begin"
| With region -> print_token buffer region "with"
| LBrace region -> print_token buffer region "{"
| LBracket region -> print_token buffer region "["
and print_ne_injection :
'a.Buffer.t -> (Buffer.t -> 'a -> unit) -> 'a ne_injection reg -> unit =
fun buffer print {value; _} ->
let {compound; ne_elements; terminator} = value in
print_open_compound buffer compound;
print_nsepseq buffer ";" print ne_elements;
print_terminator buffer terminator;
print_close_compound buffer compound
and print_closing buffer = function
End region -> print_token buffer region "end"
| RBrace region -> print_token buffer region "}"
| RBracket region -> print_token buffer region "]"
and print_open_compound buffer = function
BeginEnd (kwd_begin,_) -> print_token buffer kwd_begin "begin"
| Braces (lbrace,_) -> print_token buffer lbrace "{"
| Brackets (lbracket,_) -> print_token buffer lbracket "["
and print_close_compound buffer = function
BeginEnd (_,kwd_end) -> print_token buffer kwd_end "end"
| Braces (_,rbrace) -> print_token buffer rbrace "}"
| Brackets (_,rbracket) -> print_token buffer rbracket "]"
and print_terminator buffer = function
Some semi -> print_token buffer semi ";"
| None -> ()
and print_let_binding buffer {bindings; lhs_type; eq; let_rhs} =
let () = List.iter (print_pattern buffer) bindings in
and print_let_binding buffer {binders; lhs_type; eq; let_rhs} =
let () = Utils.nseq_iter (print_pattern buffer) binders in
let () =
match lhs_type with
None -> ()
@ -176,25 +190,17 @@ and print_let_binding buffer {bindings; lhs_type; eq; let_rhs} =
in print_expr buffer let_rhs
and print_pattern buffer = function
PTuple {value=patterns;_} ->
print_csv buffer print_pattern patterns
PTuple ptuple ->
print_csv buffer print_pattern ptuple
| PList p ->
print_list_pattern buffer p
| PVar v ->
print_pvar buffer v
| PUnit {value=lpar,rpar; _} ->
print_token buffer lpar "(";
print_token buffer rpar ")"
| PInt i ->
print_int buffer i
| PTrue kwd_true ->
print_token buffer kwd_true "true"
| PFalse kwd_false ->
print_token buffer kwd_false "false"
| PString s ->
print_str buffer s
| PWild wild ->
print_token buffer wild "_"
| PInt i -> print_int buffer i
| PNat i -> print_nat buffer i
| PBytes b -> print_bytes buffer b
| PString s -> print_string buffer s
| PWild wild -> print_token buffer wild "_"
| PPar {value={lpar;inside=p;rpar}; _} ->
print_token buffer lpar "(";
print_pattern buffer p;
@ -205,10 +211,13 @@ and print_pattern buffer = function
print_record_pattern buffer r
| PTyped t ->
print_typed_pattern buffer t
| PUnit p -> print_unit buffer p
| PFalse kwd_false -> print_token buffer kwd_false "false"
| PTrue kwd_true -> print_token buffer kwd_true "true"
and print_list_pattern buffer = function
Sugar p -> print_injection buffer print_pattern p
| PCons p -> print_raw buffer p
PListComp p -> print_injection buffer print_pattern p
| PCons p -> print_raw buffer p
and print_raw buffer {value=p1,c,p2; _} =
print_pattern buffer p1;
@ -222,7 +231,7 @@ and print_typed_pattern buffer {value; _} =
print_type_expr buffer type_expr
and print_record_pattern buffer record_pattern =
print_injection buffer print_field_pattern record_pattern
print_ne_injection buffer print_field_pattern record_pattern
and print_field_pattern buffer {value; _} =
let {field_name; eq; pattern} = value in
@ -230,51 +239,79 @@ and print_field_pattern buffer {value; _} =
print_token buffer eq "=";
print_pattern buffer pattern
and print_constr_pattern buffer {value=constr, p_opt; _} =
and print_constr_pattern buffer = function
PNone p -> print_none_pattern buffer p
| PSomeApp p -> print_some_app_pattern buffer p
| PConstrApp p -> print_constr_app_pattern buffer p
and print_none_pattern buffer value =
print_token buffer value "None"
and print_some_app_pattern buffer {value; _} =
let c_Some, argument = value in
print_token buffer c_Some "Some";
print_pattern buffer argument
and print_constr_app_pattern buffer node =
let {value=constr, p_opt; _} = node in
print_uident buffer constr;
match p_opt with
None -> ()
| Some pattern -> print_pattern buffer pattern
and print_expr buffer = function
ELetIn {value;_} -> print_let_in buffer value
| ECond cond -> print_conditional buffer cond
| ETuple {value;_} -> print_csv buffer print_expr value
| ECase {value;_} -> print_match_expr buffer value
| EFun e -> print_fun_expr buffer e
ELetIn let_in -> print_let_in buffer let_in
| ECond cond -> print_conditional buffer cond
| ETuple tuple -> print_csv buffer print_expr tuple
| ECase case -> print_match_expr buffer case
| EFun e -> print_fun_expr buffer e
| EAnnot e -> print_annot_expr buffer e
| ELogic e -> print_logic_expr buffer e
| EArith e -> print_arith_expr buffer e
| EString e -> print_string_expr buffer e
| ECall e -> print_fun_call buffer e
| EVar v -> print_var buffer v
| EProj p -> print_projection buffer p
| EUnit e -> print_unit buffer e
| EBytes b -> print_bytes buffer b
| EPar e -> print_expr_par buffer e
| EList e -> print_list_expr buffer e
| ESeq seq -> print_sequence buffer seq
| ERecord e -> print_record_expr buffer e
| EConstr e -> print_constr_expr buffer e
| EAnnot e -> print_annot_expr buffer e
| ELogic e -> print_logic_expr buffer e
| EArith e -> print_arith_expr buffer e
| EString e -> print_string_expr buffer e
and print_constr_expr buffer = function
ENone e -> print_none_expr buffer e
| ESomeApp e -> print_some_app_expr buffer e
| EConstrApp e -> print_constr_app_expr buffer e
| ECall {value=f,l; _} ->
print_expr buffer f;
Utils.nseq_iter (print_expr buffer) l
| EVar v ->
print_var buffer v
| EProj p ->
print_projection buffer p.value
| EUnit {value=lpar,rpar; _} ->
print_token buffer lpar "(";
print_token buffer rpar ")"
| EBytes b ->
print_bytes buffer b
| EPar {value={lpar;inside=e;rpar}; _} ->
print_token buffer lpar "(";
print_expr buffer e;
print_token buffer rpar ")"
| EList e ->
print_list_expr buffer e
| ESeq seq ->
print_sequence buffer seq
| ERecord e ->
print_record_expr buffer e
| EConstr {value=constr,None; _} ->
print_uident buffer constr
| EConstr {value=(constr, Some arg); _} ->
print_uident buffer constr;
print_expr buffer arg
and print_none_expr buffer value = print_token buffer value "None"
and print_some_app_expr buffer {value; _} =
let c_Some, argument = value in
print_token buffer c_Some "Some";
print_expr buffer argument
and print_constr_app_expr buffer {value; _} =
let constr, argument = value in
print_constr buffer constr;
match argument with
None -> ()
| Some arg -> print_expr buffer arg
and print_expr_par buffer {value; _} =
let {lpar;inside=e;rpar} = value in
print_token buffer lpar "(";
print_expr buffer e;
print_token buffer rpar ")"
and print_unit buffer {value=lpar,rpar; _} =
print_token buffer lpar "(";
print_token buffer rpar ")"
and print_fun_call buffer {value=f,l; _} =
print_expr buffer f;
Utils.nseq_iter (print_expr buffer) l
and print_annot_expr buffer {value=e,t; _} =
print_expr buffer e;
@ -282,11 +319,14 @@ and print_annot_expr buffer {value=e,t; _} =
print_type_expr buffer t
and print_list_expr buffer = function
Cons {value={arg1;op;arg2}; _} ->
ECons {value={arg1;op;arg2}; _} ->
print_expr buffer arg1;
print_token buffer op "::";
print_expr buffer arg2
| List e -> print_injection buffer print_expr e
| EListComp e ->
if e.value.elements = None
then print_token buffer e.region "[]"
else print_injection buffer print_expr e
(*
| Append {value=e1,append,e2; _} ->
print_expr buffer e1;
@ -333,8 +373,8 @@ and print_string_expr buffer = function
print_expr buffer arg1;
print_token buffer op "^";
print_expr buffer arg2
| String s ->
print_str buffer s
| StrLit s ->
print_string buffer s
and print_logic_expr buffer = function
BoolExpr e -> print_bool_expr buffer e
@ -384,7 +424,7 @@ and print_comp_expr buffer = function
print_expr buffer arg2
and print_record_expr buffer e =
print_injection buffer print_field_assign e
print_ne_injection buffer print_field_assign e
and print_field_assign buffer {value; _} =
let {field_name; assignment; field_expr} = value in
@ -395,15 +435,13 @@ and print_field_assign buffer {value; _} =
and print_sequence buffer seq =
print_injection buffer print_expr seq
and print_match_expr buffer expr =
let {kwd_match; expr; opening;
lead_vbar; cases; closing} = expr in
and print_match_expr buffer {value; _} =
let {kwd_match; expr; kwd_with; lead_vbar; cases} = value in
print_token buffer kwd_match "match";
print_expr buffer expr;
print_opening buffer opening;
print_token buffer kwd_with "with";
print_token_opt buffer lead_vbar "|";
print_cases buffer cases;
print_closing buffer closing
print_cases buffer cases
and print_token_opt buffer = function
None -> fun _ -> ()
@ -418,19 +456,20 @@ and print_case_clause buffer {value; _} =
print_token buffer arrow "->";
print_expr buffer rhs
and print_let_in buffer (bind: let_in) =
let {kwd_let; binding; kwd_in; body} = bind in
and print_let_in buffer {value; _} =
let {kwd_let; binding; kwd_in; body} = value in
print_token buffer kwd_let "let";
print_let_binding buffer binding;
print_token buffer kwd_in "in";
print_expr buffer body
and print_fun_expr buffer {value; _} =
let {kwd_fun; params; p_annot; arrow; body} = value in
let {kwd_fun; binders; lhs_type; arrow; body} = value in
let () = print_token buffer kwd_fun "fun" in
let () = Utils.nseq_iter (print_pattern buffer) binders in
let () =
match p_annot with
None -> List.iter (print_pattern buffer) params
match lhs_type with
None -> ()
| Some (colon, type_expr) ->
print_token buffer colon ":";
print_type_expr buffer type_expr in
@ -442,21 +481,537 @@ and print_conditional buffer {value; _} =
let {kwd_if; test; kwd_then;
ifso; kwd_else; ifnot} = value in
print_token buffer ghost "(";
print_token buffer kwd_if "if";
print_expr buffer test;
print_token buffer kwd_then "then";
print_expr buffer ifso;
print_token buffer kwd_else "else";
print_expr buffer ifnot;
print_token buffer ghost ")"
print_token buffer kwd_if "if";
print_expr buffer test;
print_token buffer kwd_then "then";
print_expr buffer ifso;
print_token buffer kwd_else "else";
print_expr buffer ifnot;
print_token buffer ghost ")"
(* Conversion to string *)
let to_string printer node =
let buffer = Buffer.create 131 in
let () = printer buffer node
in Buffer.contents buffer
printer buffer node;
Buffer.contents buffer
let tokens_to_string = to_string print_tokens
let pattern_to_string = to_string print_pattern
let expr_to_string = to_string print_expr
(* Pretty-printing the AST *)
let mk_pad len rank pc =
pc ^ (if rank = len-1 then "`-- " else "|-- "),
pc ^ (if rank = len-1 then " " else "| ")
let pp_ident buffer ~pad:(pd,_) Region.{value=name; region} =
let node = sprintf "%s%s (%s)\n" pd name (region#compact `Byte)
in Buffer.add_string buffer node
let pp_node buffer ~pad:(pd,_) name =
let node = sprintf "%s%s\n" pd name
in Buffer.add_string buffer node
let pp_string buffer = pp_ident buffer
let pp_loc_node buffer ~pad name region =
pp_ident buffer ~pad Region.{value=name; region}
let rec pp_ast buffer ~pad:(_,pc as pad) {decl; _} =
let apply len rank =
let pad = mk_pad len rank pc in
pp_declaration buffer ~pad in
let decls = Utils.nseq_to_list decl in
pp_node buffer ~pad "<ast>";
List.iteri (List.length decls |> apply) decls
and pp_declaration buffer ~pad = function
Let {value; region} ->
pp_loc_node buffer ~pad "Let" region;
pp_let_binding buffer ~pad (snd value)
| TypeDecl {value; region} ->
pp_loc_node buffer ~pad "TypeDecl" region;
pp_type_decl buffer ~pad value
and pp_let_binding buffer ~pad:(_,pc) node =
let {binders; lhs_type; let_rhs; _} = node in
let fields = if lhs_type = None then 2 else 3 in
let () =
let pad = mk_pad fields 0 pc in
pp_node buffer ~pad "<binders>";
pp_binders buffer ~pad binders in
let () =
match lhs_type with
None -> ()
| Some (_, type_expr) ->
let _, pc as pad = mk_pad fields 1 pc in
pp_node buffer ~pad "<lhs type>";
pp_type_expr buffer ~pad:(mk_pad 1 0 pc) type_expr in
let () =
let _, pc as pad = mk_pad fields (fields - 1) pc in
pp_node buffer ~pad "<rhs>";
pp_expr buffer ~pad:(mk_pad 1 0 pc) let_rhs
in ()
and pp_type_decl buffer ~pad:(_,pc) decl =
pp_ident buffer ~pad:(mk_pad 2 0 pc) decl.name;
pp_type_expr buffer ~pad:(mk_pad 2 1 pc) decl.type_expr
and pp_binders buffer ~pad:(_,pc) patterns =
let patterns = Utils.nseq_to_list patterns in
let arity = List.length patterns in
let apply len rank =
pp_pattern buffer ~pad:(mk_pad len rank pc)
in List.iteri (apply arity) patterns
and pp_pattern buffer ~pad:(_,pc as pad) = function
PConstr p ->
pp_node buffer ~pad "PConstr";
pp_constr_pattern buffer ~pad:(mk_pad 1 0 pc) p
| PVar v ->
pp_node buffer ~pad "PVar";
pp_ident buffer ~pad:(mk_pad 1 0 pc) v
| PWild region ->
pp_loc_node buffer ~pad "PWild" region
| PInt i ->
pp_node buffer ~pad "PInt";
pp_int buffer ~pad i
| PNat n ->
pp_node buffer ~pad "PNat";
pp_int buffer ~pad n
| PBytes b ->
pp_node buffer ~pad "PBytes";
pp_bytes buffer ~pad b
| PString s ->
pp_node buffer ~pad "PString";
pp_string buffer ~pad:(mk_pad 1 0 pc) s
| PUnit {region; _} ->
pp_loc_node buffer ~pad "PUnit" region
| PFalse region ->
pp_loc_node buffer ~pad "PFalse" region
| PTrue region ->
pp_loc_node buffer ~pad "PTrue" region
| PList plist ->
pp_node buffer ~pad "PList";
pp_list_pattern buffer ~pad:(mk_pad 1 0 pc) plist
| PTuple t ->
pp_loc_node buffer ~pad "PTuple" t.region;
pp_tuple_pattern buffer ~pad:(mk_pad 1 0 pc) t.value
| PPar {value; _} ->
pp_node buffer ~pad "PPar";
pp_pattern buffer ~pad:(mk_pad 1 0 pc) value.inside
| PRecord {value; _} ->
pp_node buffer ~pad "PRecord";
pp_ne_injection pp_field_pattern buffer ~pad value
| PTyped {value; _} ->
pp_node buffer ~pad "PTyped";
pp_typed_pattern buffer ~pad value
and pp_field_pattern buffer ~pad:(_,pc as pad) {value; _} =
pp_node buffer ~pad value.field_name.value;
pp_pattern buffer ~pad:(mk_pad 1 0 pc) value.pattern
and pp_typed_pattern buffer ~pad:(_,pc) node =
pp_pattern buffer ~pad:(mk_pad 2 0 pc) node.pattern;
pp_type_expr buffer ~pad:(mk_pad 2 1 pc) node.type_expr
and pp_tuple_pattern buffer ~pad:(_,pc) tuple =
let patterns = Utils.nsepseq_to_list tuple in
let length = List.length patterns in
let apply len rank =
pp_pattern buffer ~pad:(mk_pad len rank pc)
in List.iteri (apply length) patterns
and pp_list_pattern buffer ~pad:(_,pc as pad) = function
PCons {value; region} ->
let pat1, _, pat2 = value in
pp_loc_node buffer ~pad "PCons" region;
pp_pattern buffer ~pad:(mk_pad 2 0 pc) pat1;
pp_pattern buffer ~pad:(mk_pad 2 1 pc) pat2
| PListComp {value; region} ->
pp_loc_node buffer ~pad "PListComp" region;
if value.elements = None
then pp_node buffer ~pad:(mk_pad 1 0 pc) "<nil>"
else pp_injection pp_pattern buffer ~pad value
and pp_injection :
'a.(Buffer.t -> pad:(string*string) -> 'a -> unit)
-> Buffer.t -> pad:(string*string) -> 'a injection -> unit =
fun printer buffer ~pad:(_,pc) inj ->
let elements = Utils.sepseq_to_list inj.elements in
let length = List.length elements in
let apply len rank = printer buffer ~pad:(mk_pad len rank pc)
in List.iteri (apply length) elements
and pp_ne_injection :
'a.(Buffer.t -> pad:(string*string) -> 'a -> unit)
-> Buffer.t -> pad:(string*string) -> 'a ne_injection -> unit =
fun printer buffer ~pad:(_,pc) inj ->
let ne_elements = Utils.nsepseq_to_list inj.ne_elements in
let length = List.length ne_elements in
let apply len rank = printer buffer ~pad:(mk_pad len rank pc)
in List.iteri (apply length) ne_elements
and pp_bytes buffer ~pad:(_,pc) {value=lexeme,hex; region} =
pp_loc_node buffer ~pad:(mk_pad 2 0 pc) lexeme region;
pp_node buffer ~pad:(mk_pad 2 1 pc) (Hex.to_string hex)
and pp_int buffer ~pad:(_,pc) {value=lexeme,z; region} =
pp_loc_node buffer ~pad:(mk_pad 2 0 pc) lexeme region;
pp_node buffer ~pad:(mk_pad 2 1 pc) (Z.to_string z)
and pp_constr_pattern buffer ~pad:(_,pc as pad) = function
PNone region ->
pp_loc_node buffer ~pad "PNone" region
| PSomeApp {value=_,param; region} ->
pp_loc_node buffer ~pad "PSomeApp" region;
pp_pattern buffer ~pad:(mk_pad 1 0 pc) param
| PConstrApp {value; region} ->
pp_loc_node buffer ~pad "PConstrApp" region;
pp_constr_app_pattern buffer ~pad:(mk_pad 1 0 pc) value
and pp_constr_app_pattern buffer ~pad (constr, pat_opt) =
pp_ident buffer ~pad constr;
match pat_opt with
None -> ()
| Some pat -> pp_pattern buffer ~pad pat
and pp_expr buffer ~pad:(_,pc as pad) = function
ECase {value; region} ->
pp_loc_node buffer ~pad "ECase" region;
pp_case pp_expr buffer ~pad value
| ECond {value; region} ->
pp_loc_node buffer ~pad "ECond" region;
pp_cond_expr buffer ~pad value
| EAnnot {value; region} ->
pp_loc_node buffer ~pad "EAnnot" region;
pp_annotated buffer ~pad value
| ELogic e_logic ->
pp_node buffer ~pad "ELogic";
pp_e_logic buffer ~pad:(mk_pad 1 0 pc) e_logic
| EArith e_arith ->
pp_node buffer ~pad "EArith";
pp_arith_expr buffer ~pad:(mk_pad 1 0 pc) e_arith
| EString e_string ->
pp_node buffer ~pad "EString";
pp_string_expr buffer ~pad:(mk_pad 1 0 pc) e_string
| EList e_list ->
pp_node buffer ~pad "EList";
pp_list_expr buffer ~pad:(mk_pad 1 0 pc) e_list
| EConstr e_constr ->
pp_node buffer ~pad "EConstr";
pp_constr_expr buffer ~pad:(mk_pad 1 0 pc) e_constr
| ERecord {value; region} ->
pp_loc_node buffer ~pad "ERecord" region;
pp_ne_injection pp_field_assign buffer ~pad value
| EProj {value; region} ->
pp_loc_node buffer ~pad "EProj" region;
pp_projection buffer ~pad value
| EVar v ->
pp_node buffer ~pad "EVar";
pp_ident buffer ~pad:(mk_pad 1 0 pc) v
| ECall {value; region} ->
pp_loc_node buffer ~pad "ECall" region;
pp_fun_call buffer ~pad value
| EBytes b ->
pp_node buffer ~pad "EBytes";
pp_bytes buffer ~pad b
| EUnit u ->
pp_loc_node buffer ~pad "EUnit" u.region
| ETuple e_tuple ->
pp_node buffer ~pad "ETuple";
pp_tuple_expr buffer ~pad e_tuple
| EPar {value; region} ->
pp_loc_node buffer ~pad "EPar" region;
pp_expr buffer ~pad:(mk_pad 1 0 pc) value.inside
| ELetIn {value; region} ->
pp_loc_node buffer ~pad "ELetIn" region;
pp_let_in buffer ~pad value
| EFun {value; region} ->
pp_loc_node buffer ~pad "EFun" region;
pp_fun_expr buffer ~pad value
| ESeq {value; region} ->
pp_loc_node buffer ~pad "ESeq" region;
pp_injection pp_expr buffer ~pad value
and pp_fun_expr buffer ~pad:(_,pc) node =
let {binders; lhs_type; body; _} = node in
let fields = if lhs_type = None then 2 else 3 in
let () =
let pad = mk_pad fields 0 pc in
pp_node buffer ~pad "<parameters>";
pp_binders buffer ~pad binders in
let () =
match lhs_type with
None -> ()
| Some (_, type_expr) ->
let _, pc as pad = mk_pad fields 1 pc in
pp_node buffer ~pad "<lhs type>";
pp_type_expr buffer ~pad:(mk_pad 1 0 pc) type_expr in
let () =
let pad = mk_pad fields (fields - 1) pc in
pp_node buffer ~pad "<body>";
pp_expr buffer ~pad:(mk_pad 1 0 pc) body
in ()
and pp_let_in buffer ~pad:(_,pc) node =
let {binding; body; _} = node in
let {binders; lhs_type; let_rhs; _} = binding in
let fields = if lhs_type = None then 3 else 4 in
let () =
let pad = mk_pad fields 0 pc in
pp_node buffer ~pad "<binders>";
pp_binders buffer ~pad binders in
let () =
match lhs_type with
None -> ()
| Some (_, type_expr) ->
let _, pc as pad = mk_pad fields 1 pc in
pp_node buffer ~pad "<lhs type>";
pp_type_expr buffer ~pad:(mk_pad 1 0 pc) type_expr in
let () =
let _, pc as pad = mk_pad fields (fields - 2) pc in
pp_node buffer ~pad "<rhs>";
pp_expr buffer ~pad:(mk_pad 1 0 pc) let_rhs in
let () =
let _, pc as pad = mk_pad fields (fields - 1) pc in
pp_node buffer ~pad "<body>";
pp_expr buffer ~pad:(mk_pad 1 0 pc) body
in ()
and pp_tuple_expr buffer ~pad:(_,pc) {value; _} =
let exprs = Utils.nsepseq_to_list value in
let length = List.length exprs in
let apply len rank =
pp_expr buffer ~pad:(mk_pad len rank pc)
in List.iteri (apply length) exprs
and pp_fun_call buffer ~pad:(_,pc) (fun_expr, args) =
let args = Utils.nseq_to_list args in
let arity = List.length args in
let apply len rank =
pp_expr buffer ~pad:(mk_pad len rank pc)
in pp_expr buffer ~pad:(mk_pad (1+arity) 0 pc) fun_expr;
List.iteri (apply arity) args
and pp_projection buffer ~pad:(_,pc) proj =
let selections = Utils.nsepseq_to_list proj.field_path in
let len = List.length selections in
let apply len rank =
pp_selection buffer ~pad:(mk_pad len rank pc) in
pp_ident buffer ~pad:(mk_pad (1+len) 0 pc) proj.struct_name;
List.iteri (apply len) selections
and pp_selection buffer ~pad:(_,pc as pad) = function
FieldName fn ->
pp_node buffer ~pad "FieldName";
pp_ident buffer ~pad:(mk_pad 1 0 pc) fn
| Component c ->
pp_node buffer ~pad "Component";
pp_int buffer ~pad c
and pp_field_assign buffer ~pad:(_,pc as pad) {value; _} =
pp_node buffer ~pad "<field assignment>";
pp_ident buffer ~pad:(mk_pad 2 0 pc) value.field_name;
pp_expr buffer ~pad:(mk_pad 2 1 pc) value.field_expr
and pp_constr_expr buffer ~pad:(_,pc as pad) = function
ENone region ->
pp_loc_node buffer ~pad "ENone" region
| ESomeApp {value=_,arg; region} ->
pp_loc_node buffer ~pad "ESomeApp" region;
pp_expr buffer ~pad:(mk_pad 1 0 pc) arg
| EConstrApp {value; region} ->
pp_loc_node buffer ~pad "EConstrApp" region;
pp_constr_app_expr buffer ~pad value
and pp_constr_app_expr buffer ~pad:(_,pc) (constr, expr_opt) =
match expr_opt with
None -> pp_ident buffer ~pad:(mk_pad 1 0 pc) constr
| Some expr ->
pp_ident buffer ~pad:(mk_pad 2 0 pc) constr;
pp_expr buffer ~pad:(mk_pad 2 1 pc) expr
and pp_list_expr buffer ~pad:(_,pc as pad) = function
ECons {value; region} ->
pp_loc_node buffer ~pad "Cons" region;
pp_expr buffer ~pad:(mk_pad 2 0 pc) value.arg1;
pp_expr buffer ~pad:(mk_pad 2 1 pc) value.arg2
| EListComp {value; region} ->
pp_loc_node buffer ~pad "List" region;
if value.elements = None
then pp_node buffer ~pad:(mk_pad 1 0 pc) "<nil>"
else pp_injection pp_expr buffer ~pad value
and pp_string_expr buffer ~pad:(_,pc as pad) = function
Cat {value; region} ->
pp_loc_node buffer ~pad "Cat" region;
pp_expr buffer ~pad:(mk_pad 2 0 pc) value.arg1;
pp_expr buffer ~pad:(mk_pad 2 1 pc) value.arg2;
| StrLit s ->
pp_node buffer ~pad "StrLit";
pp_string buffer ~pad:(mk_pad 1 0 pc) s
and pp_arith_expr buffer ~pad:(_,pc as pad) = function
Add {value; region} ->
pp_bin_op "Add" region buffer ~pad value
| Sub {value; region} ->
pp_bin_op "Sub" region buffer ~pad value
| Mult {value; region} ->
pp_bin_op "Mult" region buffer ~pad value
| Div {value; region} ->
pp_bin_op "Div" region buffer ~pad value
| Mod {value; region} ->
pp_bin_op "Mod" region buffer ~pad value
| Neg {value; region} ->
pp_loc_node buffer ~pad "Neg" region;
pp_expr buffer ~pad:(mk_pad 1 0 pc) value.arg;
| Int i ->
pp_node buffer ~pad "Int";
pp_int buffer ~pad i
| Nat n ->
pp_node buffer ~pad "Nat";
pp_int buffer ~pad n
| Mutez m ->
pp_node buffer ~pad "Mutez";
pp_int buffer ~pad m
and pp_e_logic buffer ~pad = function
BoolExpr e ->
pp_node buffer ~pad "BoolExpr";
pp_bool_expr buffer ~pad e
| CompExpr e ->
pp_node buffer ~pad "CompExpr";
pp_comp_expr buffer ~pad e
and pp_bool_expr buffer ~pad:(_,pc as pad) = function
Or {value; region} ->
pp_bin_op "Or" region buffer ~pad value
| And {value; region} ->
pp_bin_op "And" region buffer ~pad value
| Not {value; _} ->
let _, pc as pad = mk_pad 1 0 pc in
pp_node buffer ~pad "Not";
pp_expr buffer ~pad:(mk_pad 1 0 pc) value.arg
| False region ->
pp_loc_node buffer ~pad:(mk_pad 1 0 pc) "False" region
| True region ->
pp_loc_node buffer ~pad:(mk_pad 1 0 pc) "True" region
and pp_comp_expr buffer ~pad = function
Lt {value; region} ->
pp_bin_op "Lt" region buffer ~pad value
| Leq {value; region} ->
pp_bin_op "Leq" region buffer ~pad value
| Gt {value; region} ->
pp_bin_op "Gt" region buffer ~pad value
| Geq {value; region} ->
pp_bin_op "Geq" region buffer ~pad value
| Equal {value; region} ->
pp_bin_op "Equal" region buffer ~pad value
| Neq {value; region} ->
pp_bin_op "Neq" region buffer ~pad value
and pp_bin_op node region buffer ~pad:(_,pc as pad) op =
pp_loc_node buffer ~pad node region;
pp_expr buffer ~pad:(mk_pad 2 0 pc) op.arg1;
pp_expr buffer ~pad:(mk_pad 2 1 pc) op.arg2
and pp_annotated buffer ~pad:(_,pc) (expr, t_expr) =
pp_expr buffer ~pad:(mk_pad 2 0 pc) expr;
pp_type_expr buffer ~pad:(mk_pad 2 1 pc) t_expr
and pp_cond_expr buffer ~pad:(_,pc) (cond: cond_expr) =
let () =
let _, pc as pad = mk_pad 3 0 pc in
pp_node buffer ~pad "<condition>";
pp_expr buffer ~pad:(mk_pad 1 0 pc) cond.test in
let () =
let _, pc as pad = mk_pad 3 1 pc in
pp_node buffer ~pad "<true>";
pp_expr buffer ~pad:(mk_pad 1 0 pc) cond.ifso in
let () =
let _, pc as pad = mk_pad 3 2 pc in
pp_node buffer ~pad "<false>";
pp_expr buffer ~pad:(mk_pad 1 0 pc) cond.ifnot
in ()
and pp_case :
'a.(Buffer.t -> pad:(string*string) -> 'a -> unit)
-> Buffer.t -> pad:(string*string) -> 'a case -> unit =
fun printer buffer ~pad:(_,pc) case ->
let clauses = Utils.nsepseq_to_list case.cases.value in
let clauses = List.map (fun {value; _} -> value) clauses in
let length = List.length clauses + 1 in
let apply len rank =
pp_case_clause printer buffer ~pad:(mk_pad len (rank+1) pc)
in pp_expr buffer ~pad:(mk_pad length 0 pc) case.expr;
List.iteri (apply length) clauses
and pp_case_clause :
'a.(Buffer.t -> pad:(string*string) -> 'a -> unit)
-> Buffer.t -> pad:(string*string) -> 'a case_clause -> unit =
fun printer buffer ~pad:(_,pc as pad) clause ->
pp_node buffer ~pad "<clause>";
pp_pattern buffer ~pad:(mk_pad 2 0 pc) clause.pattern;
printer buffer ~pad:(mk_pad 2 1 pc) clause.rhs
and pp_type_expr buffer ~pad:(_,pc as pad) = function
TProd {value; region} ->
pp_loc_node buffer ~pad "TProd" region;
pp_cartesian buffer ~pad value
| TSum {value; region} ->
pp_loc_node buffer ~pad "TSum" region;
let apply len rank variant =
let pad = mk_pad len rank pc in
pp_variant buffer ~pad variant.value in
let variants = Utils.nsepseq_to_list value in
List.iteri (List.length variants |> apply) variants
| TRecord {value; region} ->
pp_loc_node buffer ~pad "TRecord" region;
pp_ne_injection pp_field_decl buffer ~pad value
| TApp {value=name,tuple; region} ->
pp_loc_node buffer ~pad "TApp" region;
pp_ident buffer ~pad:(mk_pad 1 0 pc) name;
pp_type_tuple buffer ~pad:(mk_pad 2 1 pc) tuple
| TFun {value; region} ->
pp_loc_node buffer ~pad "TFun" region;
let apply len rank =
let pad = mk_pad len rank pc in
pp_type_expr buffer ~pad in
let domain, _, range = value in
List.iteri (apply 2) [domain; range]
| TPar {value={inside;_}; region} ->
pp_loc_node buffer ~pad "TPar" region;
pp_type_expr buffer ~pad:(mk_pad 1 0 pc) inside
| TVar v ->
pp_node buffer ~pad "TVar";
pp_ident buffer ~pad:(mk_pad 1 0 pc) v
and pp_type_tuple buffer ~pad:(_,pc) {value; _} =
let components = Utils.nsepseq_to_list value.inside in
let apply len rank =
pp_type_expr buffer ~pad:(mk_pad len rank pc)
in List.iteri (List.length components |> apply) components
and pp_field_decl buffer ~pad:(_,pc as pad) {value; _} =
pp_ident buffer ~pad value.field_name;
pp_type_expr buffer ~pad:(mk_pad 1 0 pc) value.field_type
and pp_cartesian buffer ~pad:(_,pc) t_exprs =
let t_exprs = Utils.nsepseq_to_list t_exprs in
let arity = List.length t_exprs in
let apply len rank =
pp_type_expr buffer ~pad:(mk_pad len rank pc)
in List.iteri (apply arity) t_exprs
and pp_variant buffer ~pad:(_,pc as pad) {constr; arg} =
pp_ident buffer ~pad constr;
match arg with
None -> ()
| Some (_,c) ->
pp_type_expr buffer ~pad:(mk_pad 1 0 pc) c
let pp_ast buffer = pp_ast buffer ~pad:("","")

4
src/passes/1-parser/ligodity/ParserLog.mli
View File

@ -17,3 +17,7 @@ val print_expr : Buffer.t -> AST.expr -> unit
val tokens_to_string : AST.t -> string
val pattern_to_string : AST.pattern -> string
val expr_to_string : AST.expr -> string
(* Pretty-printing of the AST *)
val pp_ast : Buffer.t -> AST.t -> unit

8
src/passes/1-parser/ligodity/ParserMain.ml
View File

@ -103,6 +103,14 @@ let () =
try
let ast = Parser.contract tokeniser buffer in
if Utils.String.Set.mem "ast" options.verbose
then let buffer = Buffer.create 131 in
begin
ParserLog.offsets := options.offsets;
ParserLog.mode := options.mode;
ParserLog.pp_ast buffer ast;
Buffer.output_buffer stdout buffer
end
else if Utils.String.Set.mem "ast-tokens" options.verbose
then let buffer = Buffer.create 131 in
begin
ParserLog.offsets := options.offsets;

31
src/passes/1-parser/shared/Lexer.mll
View File

@ -380,7 +380,7 @@ module Make (Token: TOKEN) : (S with module Token = Token) =
Hint: Remove the leading minus sign.\n"
| Broken_string ->
"The string starting here is interrupted by a line break.\n\
Hint: Remove the break or close the string before.\n"
Hint: Remove the break, close the string before or insert a backslash.\n"
| Invalid_character_in_string ->
"Invalid character in string.\n\
Hint: Remove or replace the character.\n"
@ -516,7 +516,7 @@ let decimal = digit+ '.' digit+
let small = ['a'-'z']
let capital = ['A'-'Z']
let letter = small | capital
let ident = small (letter | '_' | digit | '%')*
let ident = small (letter | '_' | digit)*
let constr = capital (letter | '_' | digit)*
let hexa_digit = digit | ['A'-'F']
let byte = hexa_digit hexa_digit
@ -551,20 +551,19 @@ rule init state = parse
| _ { rollback lexbuf; scan state lexbuf }
and scan state = parse
nl { scan (push_newline state lexbuf) lexbuf }
| ' '+ { scan (push_space state lexbuf) lexbuf }
| '\t'+ { scan (push_tabs state lexbuf) lexbuf }
| ident { mk_ident state lexbuf |> enqueue }
| constr { mk_constr state lexbuf |> enqueue }
| bytes { (mk_bytes seq) state lexbuf |> enqueue }
| natural 'n' { mk_nat state lexbuf |> enqueue }
| natural 'p' { mk_nat state lexbuf |> enqueue }
| natural "mutez" { mk_mutez state lexbuf |> enqueue }
| natural "tz" { mk_tz state lexbuf |> enqueue }
| decimal "tz" { mk_tz_decimal state lexbuf |> enqueue }
| natural { mk_int state lexbuf |> enqueue }
| symbol { mk_sym state lexbuf |> enqueue }
| eof { mk_eof state lexbuf |> enqueue }
nl { scan (push_newline state lexbuf) lexbuf }
| ' '+ { scan (push_space state lexbuf) lexbuf }
| '\t'+ { scan (push_tabs state lexbuf) lexbuf }
| ident { mk_ident state lexbuf |> enqueue }
| constr { mk_constr state lexbuf |> enqueue }
| bytes { (mk_bytes seq) state lexbuf |> enqueue }
| natural 'n' { mk_nat state lexbuf |> enqueue }
| natural "mutez" { mk_mutez state lexbuf |> enqueue }
| natural "tz" { mk_tz state lexbuf |> enqueue }
| decimal "tz" { mk_tz_decimal state lexbuf |> enqueue }
| natural { mk_int state lexbuf |> enqueue }
| symbol { mk_sym state lexbuf |> enqueue }
| eof { mk_eof state lexbuf |> enqueue }
| '"' { let opening, _, state = sync state lexbuf in
let thread = {opening; len=1; acc=['"']} in

312
src/passes/2-simplify/ligodity.ml
View File

@ -6,9 +6,11 @@ open Ast_simplified
module Raw = Parser.Ligodity.AST
module SMap = Map.String
module Option = Simple_utils.Option
(* TODO: move 1-parser/shared/Utils.ml{i} to Simple_utils/ *)
open Combinators
type 'a nseq = 'a * 'a list
let nseq_to_list (hd, tl) = hd :: tl
let npseq_to_list (hd, tl) = hd :: (List.map snd tl)
let npseq_to_nelist (hd, tl) = hd, (List.map snd tl)
@ -124,34 +126,6 @@ module Errors = struct
fun () -> Format.asprintf "%a" Location.pp_lift @@ region)
] in
error ~data title message
let bad_set_definition =
let title () = "bad set definition" in
let message () = "a set definition is a list" in
info title message
let bad_list_definition =
let title () = "bad list definition" in
let message () = "a list definition is a list" in
info title message
let bad_map_definition =
let title () = "bad map definition" in
let message () = "a map definition is a list of pairs" in
info 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
@ -185,18 +159,18 @@ let rec expr_to_typed_expr : Raw.expr -> _ = fun e ->
| EAnnot a -> ok (fst a.value , Some (snd a.value))
| _ -> ok (e , None)
let patterns_to_var : Raw.pattern list -> _ = fun ps ->
let patterns_to_var : Raw.pattern nseq -> _ = fun ps ->
match ps with
| [ pattern ] -> pattern_to_var pattern
| _ -> fail @@ multiple_patterns "let" ps
| pattern, [] -> pattern_to_var pattern
| _ -> fail @@ multiple_patterns "let" (nseq_to_list ps)
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 -> (
TPar x -> simpl_type_expression x.value.inside
| TVar v -> (
match List.assoc_opt v.value type_constants with
| Some s -> ok @@ T_constant (s , [])
Some s -> ok @@ T_constant (s , [])
| None -> ok @@ T_variable v.value
)
| TFun x -> (
@ -230,20 +204,18 @@ let rec simpl_type_expression : Raw.type_expr -> type_expression result = fun te
bind_list
@@ List.map aux
@@ List.map apply
@@ pseq_to_list r.value.elements in
@@ npseq_to_list r.value.ne_elements in
let m = List.fold_left (fun m (x, y) -> SMap.add x y m) SMap.empty lst in
ok @@ T_record m
| TSum s ->
let aux (v:Raw.variant Raw.reg) =
let args =
match v.value.args with
match v.value.arg with
None -> []
| Some (_, cartesian) ->
npseq_to_list cartesian.value in
let%bind te = simpl_list_type_expression
@@ args in
ok (v.value.constr.value, te)
in
| Some (_, TProd product) -> npseq_to_list product.value
| Some (_, t_expr) -> [t_expr] in
let%bind te = simpl_list_type_expression @@ args in
ok (v.value.constr.value, te) in
let%bind lst = bind_list
@@ List.map aux
@@ npseq_to_list s.value in
@ -270,10 +242,8 @@ let rec simpl_expression :
let path' =
let aux (s:Raw.selection) =
match s with
| FieldName property -> Access_record property.value
| Component index ->
let index = index.value.inside in
Access_tuple (Z.to_int (snd index.value))
FieldName property -> Access_record property.value
| Component index -> Access_tuple (Z.to_int (snd index.value))
in
List.map aux @@ npseq_to_list path in
return @@ e_accessor ~loc var path'
@ -281,35 +251,29 @@ let rec simpl_expression :
trace (simplifying_expr t) @@
match t with
| Raw.ELetIn e -> (
let Raw.{binding ; body ; _} = e.value in
let Raw.{bindings ; lhs_type ; let_rhs ; _} = binding in
let%bind variable = patterns_to_var bindings in
Raw.ELetIn e ->
let Raw.{binding; body; _} = e.value in
let Raw.{binders; lhs_type; let_rhs; _} = binding in
let%bind variable = patterns_to_var binders in
let%bind ty_opt =
bind_map_option
(fun (_ , type_expr) -> simpl_type_expression type_expr)
lhs_type in
bind_map_option (fun (_,te) -> simpl_type_expression te) lhs_type in
let%bind rhs = simpl_expression let_rhs in
let rhs' =
match ty_opt with
| None -> rhs
None -> rhs
| Some ty -> e_annotation rhs ty in
let%bind body = simpl_expression body in
return @@ e_let_in (variable.value , None) rhs' body
)
| Raw.EAnnot a -> (
let (a , loc) = r_split a in
let (expr , type_expr) = a in
| Raw.EAnnot a ->
let (expr , type_expr), loc = r_split a in
let%bind expr' = simpl_expression expr in
let%bind type_expr' = simpl_type_expression type_expr in
return @@ e_annotation ~loc expr' type_expr'
)
| EVar c -> (
| EVar c ->
let c' = c.value in
match List.assoc_opt c' constants with
| None -> return @@ e_variable c.value
| Some s -> return @@ e_constant s []
)
(match List.assoc_opt c' constants with
None -> return @@ e_variable c.value
| Some s -> return @@ e_constant s [])
| ECall x -> (
let ((e1 , e2) , loc) = r_split x in
let%bind args = bind_map_list simpl_expression (nseq_to_list e2) in
@ -323,72 +287,44 @@ let rec simpl_expression :
)
| Some s -> return @@ e_constant ~loc s args
)
| e1 -> (
| e1 ->
let%bind e1' = simpl_expression e1 in
let%bind arg = simpl_tuple_expression (nseq_to_list e2) in
return @@ e_application ~loc e1' arg
)
)
| EPar x -> simpl_expression x.value.inside
| EUnit reg -> (
| EUnit reg ->
let (_ , loc) = r_split reg in
return @@ e_literal ~loc Literal_unit
)
| EBytes x -> (
| EBytes x ->
let (x , loc) = r_split x in
return @@ e_literal ~loc (Literal_bytes (Bytes.of_string @@ fst x))
)
| ETuple tpl -> simpl_tuple_expression @@ (npseq_to_list tpl.value)
| ERecord r -> (
| ERecord r ->
let (r , loc) = r_split r in
let%bind fields = bind_list
@@ List.map (fun ((k : _ Raw.reg), v) -> let%bind v = simpl_expression v in ok (k.value, v))
@@ List.map (fun (x:Raw.field_assign Raw.reg) -> (x.value.field_name, x.value.field_expr))
@@ pseq_to_list r.elements in
@@ npseq_to_list r.ne_elements in
let map = SMap.of_list fields in
return @@ e_record ~loc map
)
| EProj p -> simpl_projection p
| EConstr c -> (
let ((c_name , args) , loc) = r_split c in
let (c_name , _c_loc) = r_split c_name in
| EConstr (ESomeApp a) ->
let (_, args), loc = r_split a in
let%bind arg = simpl_expression args in
return @@ e_constant ~loc "SOME" [arg]
| EConstr (ENone reg) ->
let loc = Location.lift reg in
return @@ e_none ~loc ()
| EConstr (EConstrApp c) ->
let (c_name, args), loc = r_split c in
let c_name, _c_loc = r_split c_name in
let args =
match args with
| None -> []
None -> []
| Some arg -> [arg] in
let%bind arg = simpl_tuple_expression @@ args in
match c_name with
| "Set" -> (
let%bind args' =
trace bad_set_definition @@
extract_list arg in
return @@ e_set ~loc args'
)
| "List" -> (
let%bind args' =
trace bad_list_definition @@
extract_list arg in
return @@ e_list ~loc args'
)
| "Map" -> (
let%bind args' =
trace bad_map_definition @@
extract_list arg in
let%bind pairs =
trace bad_map_definition @@
bind_map_list extract_pair args' in
return @@ e_map ~loc pairs
)
| "Some" -> (
return @@ e_some ~loc arg
)
| "None" -> (
return @@ e_none ~loc ()
)
| _ -> (
return @@ e_constructor ~loc c_name arg
)
)
let%bind arg = simpl_tuple_expression @@ args
in return @@ e_constructor ~loc c_name arg
| EArith (Add c) ->
simpl_binop "ADD" c
| EArith (Sub c) ->
@ -415,7 +351,7 @@ let rec simpl_expression :
return @@ e_literal ~loc (Literal_mutez n)
)
| EArith (Neg e) -> simpl_unop "NEG" e
| EString (String s) -> (
| EString (StrLit s) -> (
let (s , loc) = r_split s in
let s' =
let s = s in
@ -444,7 +380,7 @@ let rec simpl_expression :
let default_action () =
let%bind cases = simpl_cases lst in
return @@ e_matching ~loc e cases in
(* Hack to take care of patterns introduced by `parser/ligodity/Parser.mly` in "norm_fun_expr" *)
(* Hack to take care of patterns introduced by `parser/ligodity/Parser.mly` in "norm_fun_expr". TODO: Still needed? *)
match lst with
| [ (pattern , rhs) ] -> (
match pattern with
@ -492,7 +428,7 @@ and simpl_fun lamb' : expr result =
let return x = ok x in
let (lamb , loc) = r_split lamb' in
let%bind args' =
let args = lamb.params in
let args = nseq_to_list lamb.binders in
let%bind p_args = bind_map_list pattern_to_typed_var args in
let aux ((var : Raw.variable) , ty_opt) =
match var.value , ty_opt with
@ -571,8 +507,8 @@ and simpl_logic_expression ?te_annot (t:Raw.logic_expr) : expr result =
and simpl_list_expression (t:Raw.list_expr) : expression result =
let return x = ok @@ x in
match t with
| Cons c -> simpl_binop "CONS" c
| List lst -> (
ECons c -> simpl_binop "CONS" c
| EListComp lst -> (
let (lst , loc) = r_split lst in
let%bind lst' =
bind_map_list simpl_expression @@
@ -612,38 +548,31 @@ 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
| 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
| [] -> fail @@ corner_case ~loc:__LOC__ "let without bindings"
| hd :: tl -> ok (hd , tl)
in
let {binders; lhs_type; let_rhs} = binding in
let%bind (var, args) =
let%bind (hd, tl) =
let hd, tl = binders in ok (hd, tl) in
let%bind var = pattern_to_var hd in
ok (var , tl)
in
match args with
| [] -> (
let%bind lhs_type' = bind_map_option
(fun (_ , te) -> simpl_type_expression te) lhs_type in
[] ->
let%bind lhs_type' =
bind_map_option (fun (_,te) -> simpl_type_expression te) lhs_type in
let%bind rhs' = simpl_expression let_rhs in
ok @@ loc x @@ (Declaration_constant (var.value , lhs_type' , rhs'))
)
| _ -> (
| param1::others ->
let fun_ = {
kwd_fun = Region.ghost ;
params = args ;
p_annot = lhs_type ;
arrow = Region.ghost ;
body = let_rhs ;
} in
kwd_fun = Region.ghost;
binders = param1, others;
lhs_type;
arrow = Region.ghost;
body = let_rhs} in
let rhs = Raw.EFun {region=Region.ghost ; value=fun_} in
let%bind rhs' = simpl_expression rhs in
ok @@ loc x @@ (Declaration_constant (var.value , None , rhs'))
)
)
and simpl_cases : type a . (Raw.pattern * a) list -> a matching result =
@ -653,53 +582,55 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result =
match t with
| PVar v -> ok v.value
| PPar p -> get_var p.value.inside
| _ -> fail @@ unsupported_non_var_pattern t
in
| _ -> fail @@ unsupported_non_var_pattern t in
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
| x -> [ x ] in
let get_single (t:Raw.pattern) =
let t' = get_tuple t in
let%bind () =
trace_strong (unsupported_tuple_pattern t) @@
Assert.assert_list_size t' 1 in
ok (List.hd t')
in
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
PPar p -> get_constr p.value.inside
| PConstr v ->
let const, pat_opt =
match v with
PConstrApp {value; _} -> value
| PSomeApp {value=region,pat; _} ->
{value="Some"; region}, Some pat
| PNone region ->
{value="None"; region}, None in
let%bind pat =
trace_option (unsupported_cst_constr t) @@
pat_opt in
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)
)
| _ -> fail @@ only_constructors t
in
ok (const.value, var)
| _ -> fail @@ only_constructors t in
let rec get_constr_opt (t:Raw.pattern) =
match t with
| PPar p -> get_constr_opt p.value.inside
| PConstr v -> (
let (const , pat_opt) = v.value in
PPar p -> get_constr_opt p.value.inside
| PConstr v ->
let const, pat_opt =
match v with
PConstrApp {value; _} -> value
| PSomeApp {value=region,pat; _} ->
{value="Some"; region}, Some pat
| PNone region ->
{value="None"; region}, None in
let%bind var_opt =
match pat_opt with
| None -> ok None
| Some pat -> (
| Some pat ->
let%bind single_pat = get_single pat in
let%bind var = get_var single_pat in
ok (Some var)
)
in
ok (const.value , var_opt)
)
| _ -> fail @@ only_constructors t
in
in ok (const.value , var_opt)
| _ -> fail @@ only_constructors t in
let%bind patterns =
let aux (x , y) =
let xs = get_tuple x in
@ -709,25 +640,23 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result =
in
bind_map_list aux t in
match patterns with
| [(PFalse _ , f) ; (PTrue _ , t)]
| [(PTrue _ , t) ; (PFalse _ , f)] ->
| [(PFalse _, f) ; (PTrue _, t)]
| [(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)] -> (
| [(PList (PCons c), cons); (PList (PListComp sugar_nil), nil)]
| [(PList (PListComp sugar_nil), nil); (PList (PCons c), cons)] ->
let%bind () =
trace_strong (unsupported_sugared_lists sugar_nil.region)
@@ Assert.assert_list_empty
@@ pseq_to_list
@@ sugar_nil.value.elements in
let%bind (a, b) =
let (a , _ , b) = c.value in
let a, _, b = c.value in
let%bind a = get_var a in
let%bind b = get_var b in
ok (a, b)
in
ok @@ Match_list {match_cons = (a, b, cons) ; match_nil = nil}
)
| lst -> (
ok (a, b) in
ok @@ Match_list {match_cons=(a, b, cons); match_nil=nil}
| lst ->
let error x =
let title () = "Pattern" in
let content () =
@ -739,35 +668,26 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result =
trace (simple_info "currently, only booleans, lists, options, and constructors \
are supported in patterns") @@
let%bind constrs =
let aux (x , y) =
let%bind x' =
trace (error x) @@
get_constr x
in
ok (x' , y)
in
bind_map_list aux lst
in
ok @@ Match_variant constrs
in
let aux (x, y) =
let%bind x' = trace (error x) @@ get_constr x
in ok (x', y)
in bind_map_list aux lst
in ok @@ Match_variant constrs in
let as_option () =
let aux (x , y) =
let%bind x' =
trace (error x) @@
get_constr_opt x
in
ok (x' , y)
in
let aux (x, y) =
let%bind x' = trace (error x) @@ get_constr_opt x
in ok (x', y) in
let%bind constrs = bind_map_list aux lst in
match constrs with
| [ (("Some" , Some some_var) , some_expr) ; (("None" , None) , none_expr) ]
| [ (("None" , None) , none_expr) ; (("Some" , Some some_var) , some_expr) ] -> (
ok @@ Match_option { match_some = (some_var , some_expr) ; match_none = none_expr }
)
| [ (("Some", Some some_var), some_expr);
(("None" , None) , none_expr) ]
| [ (("None", None), none_expr);
(("Some", Some some_var), some_expr) ] ->
ok @@ Match_option {
match_some = (some_var, some_expr);
match_none = none_expr }
| _ -> simple_fail "bad option pattern"
in
bind_or (as_option () , as_variant ())
)
in bind_or (as_option () , as_variant ())
let simpl_program : Raw.ast -> program result = fun t ->
bind_list @@ List.map simpl_declaration @@ List.rev @@ nseq_to_list t.decl
bind_list @@ List.map simpl_declaration @@ nseq_to_list t.decl

6
src/test/contracts/assert.mligo
View File

@ -1,3 +1,3 @@
let%entry main (p : bool) (s : unit) =
let u : unit = assert(p) in
(([] : operation list), s)
let main (p: bool) (s: unit) =
let u : unit = assert p
in ([] : operation list), s

11
src/test/contracts/bitwise_arithmetic.mligo
View File

@ -1,10 +1,5 @@
(* Test CameLIGO bitwise operators *)
let or_op (n : nat) : nat =
Bitwise.lor n 4p
let and_op (n : nat) : nat =
Bitwise.land n 7p
let xor_op (n : nat) : nat =
Bitwise.lxor n 7p
let or_op (n: nat) : nat = Bitwise.lor n 4n
let and_op (n: nat) : nat = Bitwise.land n 7n
let xor_op (n: nat) : nat = Bitwise.lxor n 7n

7
src/test/contracts/condition-annot.mligo
View File

@ -1,5 +1,2 @@
let%entry main (i : int) =
if (i = 2 : bool) then
(42 : int)
else
(0 : int)
let main (i: int) =
if (i=2 : bool) then (42: int) else (0: int)

9
src/test/contracts/condition-shadowing.mligo
View File

@ -1,9 +1,8 @@
(* TODO : make a test using mutation, not shadowing *)
let%entry main (i : int) =
let main (i: int) =
let result = 0 in
if i = 2 then
let result = 42 in
result
let result = 42 in result
else
let result = 0 in
result
let result = 0 in result

8
src/test/contracts/condition.mligo
View File

@ -1,7 +1,3 @@
// Test if conditional in CameLIGO
// Test conditional in CameLIGO
let%entry main (i : int) =
if i = 2 then
42
else
0
let main (i: int) = if i = 2 then 42 else 0

2
src/test/contracts/counter.mligo
View File

@ -1,4 +1,4 @@
type storage = int
let%entry main (p:int) storage =
let main (p:int) storage =
(([] : operation list) , p + storage)

6
src/test/contracts/failwith.mligo
View File

@ -1,8 +1,4 @@
type storage = unit
(* let%entry main (p:unit) storage = *)
(* (failwith "This contract always fails" : unit) *)
let%entry main (p:unit) storage =
let main (p: unit) storage =
if true then failwith "This contract always fails" else ()

11
src/test/contracts/fibo.mligo
View File

@ -1,8 +1,7 @@
type storage = unit
let%entry main (p:unit) storage =
(fun (f : (int * int) -> int) (x : int) (y : int) -> f (y, x))
(fun (x : int) (y : int) -> x + y)
0
1
let main (p: unit) storage =
(fun (f: (int * int) -> int) (x: int) (y: int) -> f (y,x))
(fun (x: int) (y: int) -> x + y)
0
1

10
src/test/contracts/fibo2.mligo
View File

@ -1,7 +1,7 @@
type storage = unit
let%entry main (p:unit) storage =
(fun (f : int -> int) (x : int) (y : int) -> (f y))
(fun (x : int) -> x)
0
1
let main (p: unit) storage =
(fun (f: int -> int) (_: int) (y: int) -> f y)
(fun (x: int) -> x)
0
1

10
src/test/contracts/fibo3.mligo
View File

@ -1,7 +1,7 @@
type storage = unit
let%entry main (p:unit) storage =
(fun (f : int -> int -> int) (x : int) (y : int) -> (f y) (x + y))
(fun (x : int) (y : int) -> x + y)
0
1
let main (p: unit) storage =
(fun (f: int -> int -> int) (x: int) (y: int) -> f y (x+y))
(fun (x: int) (y: int) -> x + y)
0
1

8
src/test/contracts/fibo4.mligo
View File

@ -1,6 +1,6 @@
type storage = unit
let%entry main (p:unit) storage =
(fun (f : int -> int) (x : int) -> (f x))
(fun (x : int) -> x)
1
let main (p: unit) storage =
(fun (f: int -> int) (x: int) -> f x)
(fun (x: int) -> x)
1

2
src/test/contracts/function-shared.mligo
View File

@ -4,4 +4,4 @@ let foo (i: int) : int = i + 20
let bar (i: int) : int = i + 50
let foobar (i: int) : int = (foo i) + (bar i)
let foobar (i: int) : int = (foo i) + (bar i)

24
src/test/contracts/guess_string.mligo
View File

@ -1,24 +1,20 @@
(** Type of storage for this contract *)
type storage = {
challenge : string ;
}
(** Initial storage *)
let%init storage = {
challenge = "" ;
challenge : string;
}
type param = {
new_challenge : string ;
attempt : string ;
new_challenge : string;
attempt : string;
}
let%entry attempt (p:param) storage =
let attempt (p: param) storage =
(* if p.attempt <> storage.challenge then failwith "Failed challenge" else *)
let contract : unit contract = Operation.get_contract sender in
let transfer : operation = Operation.transaction (unit , contract , 10.00tz) in
let contract : unit contract =
Operation.get_contract sender in
let transfer : operation =
Operation.transaction (unit , contract , 10.00tz) in
(* TODO: no syntax for functional updates yet *)
(* let storage : storage = { storage with challenge = p.new_challenge } in *)
(* for now, rebuild the record by hand. *)
let storage : storage = { challenge = p.new_challenge } in
((list [] : operation list), storage)
let storage : storage = { challenge = p.new_challenge }
in ([] : operation list), storage

13
src/test/contracts/incr_decr.mligo
View File

@ -3,18 +3,17 @@ type storage = int
(* variant defining pseudo multi-entrypoint actions *)
type action =
| Increment of int
Increment of int
| Decrement of int
let add (a : int) (b : int) : int = a + b
let subtract (a : int) (b : int) : int = a - b
let add (a: int) (b: int) : int = a + b
let sub (a: int) (b: int) : int = a - b
(* real entrypoint that re-routes the flow based on the action provided *)
let%entry main (p : action) storage =
let main (p: action) storage =
let storage =
match p with
| Increment n -> add s n
| Decrement n -> subtract s n
Increment n -> add s n
| Decrement n -> sub s n
in ([] : operation list), storage

5
src/test/contracts/lambda.mligo
View File

@ -1,9 +1,8 @@
type storage = unit
(* not supported yet
let%entry main (p:unit) storage =
let main (p:unit) storage =
(fun x -> ()) ()
*)
let%entry main (p:unit) storage =
(fun (x : unit) -> ()) ()
let main (p: unit) storage = (fun (_: unit) -> ()) ()

10
src/test/contracts/lambda2.mligo
View File

@ -1,10 +1,8 @@
type storage = unit
(* not supported yet
let%entry main (p:unit) storage =
(fun x -> ()) ()
(* Not supported yet:
let main (p:unit) storage = (fun x -> ()) ()
*)
let%entry main (p:unit) storage =
(fun (f : unit -> unit) -> f ())
(fun (x : unit) -> unit)
let main (_: unit) storage =
(fun (f: unit -> unit) -> f ()) (fun (_: unit) -> unit)

6
src/test/contracts/letin.mligo
View File

@ -1,7 +1,7 @@
type storage = int * int
let%entry main (n: int) storage =
let main (n: int) storage =
let x : int * int =
let x : int = 7
in x + n, storage.(0) + storage.(1)
in (([] : operation list), x)
in x + n, storage.0 + storage.1
in ([] : operation list), x

27
src/test/contracts/list.mligo
View File

@ -3,24 +3,23 @@ type storage = int * int list
type param = int list
let x : int list = []
let y : int list = [ 3 ; 4 ; 5 ]
let z : int list = 2 :: y
let y : int list = [3; 4; 5]
let z : int list = 2::y
let%entry main (p : param) storage =
let main (p: param) storage =
let storage =
match p with
[] -> storage
| hd::tl -> storage.(0) + hd, tl
in (([] : operation list), storage)
[] -> storage
| hd::tl -> storage.0 + hd, tl
in ([] : operation list), storage
let fold_op (s : int list) : int =
let aggregate = fun (prec : int) (cur : int) -> prec + cur in
List.fold s 10 aggregate
let fold_op (s: int list) : int =
let aggregate = fun (prec: int) (cur: int) -> prec + cur
in List.fold s 10 aggregate
let map_op (s : int list) : int list =
let aggregate = fun (cur : int) -> cur + 1 in
List.map s aggregate
let map_op (s: int list) : int list =
List.map s (fun (cur: int) -> cur + 1)
let iter_op (s : int list) : unit =
let do_nothing = fun (cur : int) -> unit in
List.iter s do_nothing
let do_nothing = fun (_: int) -> unit
in List.iter s do_nothing

51
src/test/contracts/map.mligo
View File

@ -1,46 +1,47 @@
type foobar = (int , int) map
type foobar = (int, int) map
let empty_map : foobar = Map.empty
let map1 : foobar = Map.literal
[ (144 , 23) ; (51 , 23) ; (42 , 23) ; (120 , 23) ; (421 , 23) ]
let map2 : foobar = Map [ (23 , 0) ; (42 , 0) ]
let map1 : foobar =
Map.literal [(144,23); (51,23); (42,23); (120,23); (421,23)]
let set_ (n : int) (m : foobar) : foobar =
Map.update 23 (Some n) m
let map2 : foobar = Map.literal [(23,0); (42,0)]
let rm (m : foobar) : foobar = Map.remove 42 m
let set_ (n: int) (m: foobar) : foobar = Map.update 23 (Some n) m
let rm (m: foobar) : foobar = Map.remove 42 m
(* Dummy test so that we can add the same test for PascaLIGO *)
let patch_ (m : foobar) : foobar = Map.literal [ (0, 5) ; (1, 6) ; (2, 7) ]
let patch_ (m: foobar) : foobar = Map.literal [(0,5); (1,6); (2,7)]
(* Second dummy test, see above *)
let patch_empty (m : foobar) : foobar = Map.literal [ (0, 0) ; (1, 1) ; (2, 2) ]
let patch_empty (m: foobar) : foobar = Map.literal [(0,0); (1,1); (2,2)]
(* Third dummy test, see above *)
let patch_deep (m: foobar * nat) : foobar * nat = (Map.literal [ (0, 0) ; (1, 9) ; (2, 2) ], 10p)
let patch_deep (m: foobar * nat) : foobar * nat =
Map.literal [(0,0); (1,9); (2,2)], 10n
let size_ (m : foobar) : nat = Map.size m
let size_ (m: foobar) : nat = Map.size m
let gf (m : foobar) : int = Map.find 23 m
let gf (m: foobar) : int = Map.find 23 m
let get (m : foobar) : int option = Map.find_opt 42 m
let get_ (m : foobar) : int option = Map.find_opt 42 m
let get (m: foobar) : int option = Map.find_opt 42 m
let get_ (m: foobar) : int option = Map.find_opt 42 m
let iter_op (m : foobar) : unit =
let assert_eq = fun (i : int) (j : int) -> assert(i=j) in
Map.iter m assert_eq
let assert_eq = fun (i: int) (j: int) -> assert (i=j)
in Map.iter m assert_eq
let map_op (m : foobar) : foobar =
let increment = fun (i : int) (j : int) -> j+1 in
Map.map m increment
let increment = fun (_: int) (j: int) -> j+1
in Map.map m increment
let fold_op (m : foobar) : foobar =
let aggregate = fun (i : int) (j : (int * int)) -> i + j.(0) + j.(1) in
Map.fold m 10 aggregate
let aggregate = fun (i: int) (j: int * int) -> i + j.0 + j.1
in Map.fold m 10 aggregate
let deep_op (m : foobar) : foobar =
let coco = (0,m) in
let coco = (0 , Map.remove 42 coco.(1)) in
let coco = (0 , Map.update 32 (Some 16) coco.(1)) in
coco.(1)
let deep_op (m: foobar) : foobar =
let coco = 0,m in
let coco = 0, Map.remove 42 coco.1 in
let coco = 0, Map.update 32 (Some 16) coco.1
in coco.1

6
src/test/contracts/match.mligo
View File

@ -4,13 +4,13 @@ type param =
Add of int
| Sub of int
let%entry main (p : param) storage =
let main (p: param) storage =
let storage =
storage +
(match p with
Add n -> n
| Sub n -> 0-n)
in (([] : operation list), storage)
in ([] : operation list), storage
let match_bool (b: bool) : int =
match b with
@ -22,7 +22,7 @@ let match_list (l: int list) : int =
hd :: tl -> hd
| [] -> 10
let match_option (i : int option) : int =
let match_option (i: int option) : int =
match i with
Some n -> n
| None -> 0

15
src/test/contracts/match_bis.mligo
View File

@ -3,18 +3,17 @@ type storage = int
(* variant defining pseudo multi-entrypoint actions *)
type action =
| Increment of int
Increment of int
| Decrement of int
let add (a: int) (b: int) : int = a + b
let subtract (a: int) (b: int) : int = a - b
let sub (a: int) (b: int) : int = a - b
(* real entrypoint that re-routes the flow based on the action provided *)
let%entry main (p : action) storage =
let main (p: action) storage =
let storage =
match p with
| Increment n -> add storage n
| Decrement n -> subtract storage n
in (([] : operation list), storage)
match p with
Increment n -> add storage n
| Decrement n -> sub storage n
in ([] : operation list), storage

18
src/test/contracts/new-syntax.mligo
View File

@ -1,25 +1,19 @@
(** Type of storage for this contract *)
type storage = {
challenge : string ;
}
(** Initial storage *)
let%init storage = {
challenge = "" ;
challenge : string;
}
type param = {
new_challenge : string ;
attempt : bytes ;
new_challenge : string;
attempt : bytes;
}
let%entry attempt (p:param) storage =
let attempt (p: param) storage =
if Crypto.hash (Bytes.pack p.attempt) <> Bytes.pack storage.challenge
then failwith "Failed challenge"
else
let contract : unit contract =
Operation.get_contract sender in
let transfer : operation =
Operation.transaction (unit , contract , 10tz) in
Operation.transaction (unit, contract, 10tz) in
let storage : storage = {challenge = p.new_challenge}
in (([] : operation list), storage)
in ([] : operation list), storage

2
src/test/contracts/set_arithmetic.mligo
View File

@ -7,7 +7,7 @@ let remove_op (s : string set) : string set =
Set.remove "foobar" s
let remove_deep (s : string set * nat) : string set * nat =
Set.remove "foobar" s.(0)
Set.remove "foobar" s.0
(*
let patch_op (s: string set) : string set =

9
src/test/contracts/string_arithmetic.mligo
View File

@ -1,10 +1,7 @@
(* Test that the string concatenation syntax in CameLIGO works *)
let size_op (s : string) : nat =
String.size s
let size_op (s: string) : nat = String.size s
let slice_op (s : string) : string =
String.slice 1p 2p s
let slice_op (s: string) : string = String.slice 1n 2n s
let concat_syntax (s: string) =
s ^ "test_literal"
let concat_syntax (s: string) = s ^ "test_literal"

6
src/test/contracts/tuple.mligo
View File

@ -1,14 +1,12 @@
type abc = int * int * int
let projection_abc (tpl : abc) : int =
tpl.(1)
let projection_abc (tpl : abc) : int = tpl.1
type foobar = int * int
let fb : foobar = (0, 0)
let projection (tpl : foobar) : int =
tpl.(0) + tpl.(1)
let projection (tpl : foobar) : int = tpl.0 + tpl.1
type big_tuple = int * int * int * int * int

2
src/test/contracts/variant.mligo
View File

@ -7,4 +7,4 @@ let foo : foobar = Foo 42
let bar : foobar = Bar true
let kee : foobar = Kee 23p
let kee : foobar = Kee 23n

4
src/test/contracts/vote.mligo
View File

@ -17,7 +17,7 @@ type action =
| Init of init_action
let init (init_params : init_action) (_ : storage) =
let candidates = Map [
let candidates = Map.literal [
("Yes" , 0) ;
("No" , 0)
] in
@ -26,7 +26,7 @@ let init (init_params : init_action) (_ : storage) =
{
title = init_params.title ;
candidates = candidates ;
voters = (Set [] : address set) ;
voters = (Set.empty : address set) ;
beginning_time = init_params.beginning_time ;
finish_time = init_params.finish_time ;
}

9
src/test/contracts/website2.mligo
View File

@ -7,14 +7,13 @@ type action =
| Decrement of int
let add (a: int) (b: int) : int = a + b
let subtract (a: int) (b: int) : int = a - b
let sub (a: int) (b: int) : int = a - b
(* real entrypoint that re-routes the flow based on the action provided *)
let%entry main (p : action) storage =
let main (p: action) storage =
let storage =
match p with
| Increment n -> add storage n
| Decrement n -> subtract storage n
in (([] : operation list), storage)
| Decrement n -> sub storage n
in ([] : operation list), storage

16
vendors/ligo-utils/simple-utils/region.ml vendored
View File

@ -90,11 +90,23 @@ let make ~(start: Pos.t) ~(stop: Pos.t) =
info start_offset stop#line horizontal stop_offset
method compact ?(file=true) ?(offsets=true) mode =
let start_line = start#line
and stop_line = stop#line in
let start_str = start#anonymous ~offsets mode
and stop_str = stop#anonymous ~offsets mode in
if start#file = stop#file then
if file then sprintf "%s:%s-%s" start#file start_str stop_str
else sprintf "%s-%s" start_str stop_str
if file then
sprintf "%s:%s-%s" start#file
start_str
(if start_line = stop_line
then stop#column mode |> string_of_int
else stop_str)
else
sprintf "%s-%s"
start_str
(if start_line = stop_line
then stop#column mode |> string_of_int
else stop_str)
else sprintf "%s:%s-%s:%s" start#file start_str stop#file stop_str
end