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

182
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,47 +163,52 @@ 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
PListComp of pattern injection reg
| PCons of (pattern * cons * pattern) reg
and typed_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,55 +225,55 @@ 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
@ -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 = {
@ -336,13 +355,13 @@ and let_in = {
and fun_expr = {
kwd_fun : kwd_fun;
params : pattern list;
p_annot : (colon * type_expr) option;
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

243
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
}
@ -124,13 +129,12 @@ 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 ... *)
(* 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,47 +151,52 @@ 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; ...] *)
PListComp of pattern injection reg (* [p1; p2; ...] *)
| PCons of (pattern * cons * pattern) reg (* p1 :: p2 *)
and typed_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;
@ -206,55 +213,55 @@ and field_pattern = {
and expr =
ECase of expr case reg (* p1 -> e1 | p2 -> e2 | ... *)
| EAnnot of annot_expr reg (* e : t *)
| 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; ... } *)
| 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 Utils.nseq) reg (* e e1 ... en *)
| 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) Utils.nsepseq reg (* e1, e2, ... *)
| 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 *)
| 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
| 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; ...] *)
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" *)
| 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 *)
@ -264,8 +271,8 @@ and arith_expr =
| 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 *)
| Nat of (string * Z.t) reg (* 3n *)
| Mutez of (string * Z.t) reg (* 1.00tz 3tz 233mutez *)
and logic_expr =
BoolExpr of bool_expr
@ -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 = {
@ -341,13 +343,13 @@ and let_in = {
and fun_expr = {
kwd_fun : kwd_fun;
params : pattern list;
p_annot : (colon * type_expr) option;
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;
@ -356,123 +358,10 @@ and conditional = {
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 *)

82
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,7 +101,7 @@ type t =
type token = t
let proj_token = function
| ARROW region -> region, "ARROW"
ARROW region -> region, "ARROW"
| CONS region -> region, "CONS"
| CAT region -> region, "CAT"
| MINUS region -> region, "MINUS"
@ -143,7 +138,7 @@ let proj_token = function
region, sprintf "Nat (\"%s\", %s)" s (Z.to_string 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} ->
region,
@ -166,12 +161,14 @@ let proj_token = function
| True region -> region, "True"
| Type region -> region, "Type"
| With region -> region, "With"
| LetEntry region -> region, "LetEntry"
| MatchNat region -> region, "MatchNat"
| C_None region -> region, "C_None"
| C_Some region -> region, "C_Some"
| EOF region -> region, "EOF"
let to_lexeme = function
| ARROW _ -> "->"
ARROW _ -> "->"
| CONS _ -> "::"
| CAT _ -> "^"
| MINUS _ -> "-"
@ -194,17 +191,19 @@ let to_lexeme = function
| NE _ -> "<>"
| LT _ -> "<"
| GT _ -> ">"
| LE _ -> "=<"
| 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
| String s -> s.Region.value
| Bytes b -> fst b.Region.value
| Begin _ -> "begin"
| Else _ -> "else"
| End _ -> "end"
@ -222,8 +221,10 @@ let to_lexeme = function
| Type _ -> "type"
| Then _ -> "then"
| With _ -> "with"
| LetEntry _ -> "let%entry"
| MatchNat _ -> "match%nat"
| C_None _ -> "None"
| C_Some _ -> "Some"
| EOF _ -> ""
let to_string token ?(offsets=true) mode =
@ -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,9 +370,9 @@ 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"
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})
@ -381,14 +381,14 @@ type nat_err =
| 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})
)
@ -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

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

@ -118,46 +118,34 @@ tuple(item):
list(item):
LBRACKET sep_or_term_list(item,SEMI) RBRACKET {
let elements, terminator = $2 in
{ value =
{
opening = LBracket $1;
let value = {
compound = Brackets ($1,$3);
elements = Some elements;
terminator;
closing = RBracket $3
};
region = cover $1 $3
}
terminator} in
let region = cover $1 $3
in {value; region}
}
| LBRACKET RBRACKET {
{ value =
{
opening = LBracket $1;
let value = {
compound = Brackets ($1,$2);
elements = None;
terminator = None;
closing = RBracket $2
};
region = cover $1 $2
}
}
terminator = None} in
let region = cover $1 $2
in {value; region}}
(* Main *)
contract:
declarations EOF { {decl = Utils.nseq_rev $1; eof=$2} }
declarations EOF {
{decl=$1; eof=$2} }
declarations:
declaration { $1 }
| declaration declarations { Utils.(nseq_foldl (swap nseq_cons) $2 $1)}
declaration { $1,[] : AST.declaration Utils.nseq }
| declaration declarations { Utils.nseq_cons $1 $2 }
declaration:
LetEntry entry_binding {
let start = $1 in
let stop = expr_to_region $2.let_rhs in
let region = cover start stop in
LetEntry { value = ($1, $2); region}, []
}
| type_decl { TypeDecl $1, [] }
| let_declaration { Let $1, [] }
type_decl { TypeDecl $1 }
| let_declaration { Let $1 }
(* Type declarations *)
@ -168,63 +156,58 @@ type_decl:
kwd_type = $1;
name = $2;
eq = $3;
type_expr = $4;
}
in {region; value}
}
type_expr = $4}
in {region; value} }
type_expr:
cartesian { TProd $1 }
cartesian { $1 }
| sum_type { TSum $1 }
| record_type { TRecord $1 }
cartesian:
nsepseq(fun_type, TIMES) {
let region = nsepseq_to_region type_expr_to_region $1
in {region; value=$1}
fun_type TIMES nsepseq(fun_type,TIMES) {
let value = Utils.nsepseq_cons $1 $2 $3 in
let region = nsepseq_to_region type_expr_to_region value
in TProd {region; value}
}
| fun_type { ($1 : type_expr) }
fun_type:
core_type {
$1
}
| core_type ARROW fun_type {
let region = cover (type_expr_to_region $1)
(type_expr_to_region $3)
in
TFun {region; value = ($1, $2, $3)}
}
let start = type_expr_to_region $1
and stop = type_expr_to_region $3 in
let region = cover start stop in
TFun {region; value=$1,$2,$3} }
core_type:
type_name {
TAlias $1
TVar $1
}
| module_name DOT type_name {
let module_name = $1.value in
let type_name = $3.value in
let value = module_name ^ "." ^ type_name in
let region = cover $1.region $3.region
in
TAlias {region; value}
in TVar {region; value}
}
| core_type type_constr {
let arg_val = $1 in
let constr = $2 in
let start = type_expr_to_region $1 in
let stop = $2.region in
| arg=core_type constr=type_constr {
let start = type_expr_to_region arg in
let stop = constr.region in
let region = cover start stop in
let lpar, rpar = ghost, ghost in
let value = {lpar; inside=arg_val,[]; rpar} in
let value = {lpar; inside=arg,[]; rpar} in
let arg = {value; region = start} in
TApp Region.{value = constr, arg; region}
TApp Region.{value = (constr,arg); region}
}
| type_tuple type_constr {
let total = cover $1.region $2.region in
TApp {region=total; value = $2, $1 }
let region = cover $1.region $2.region
in TApp {region; value = $2,$1}
}
| par(cartesian) {
let Region.{value={inside=prod; _}; _} = $1 in
TPar {$1 with value={$1.value with inside = TProd prod}} }
| par(type_expr) {
TPar $1 }
type_constr:
type_name { $1 }
@ -235,77 +218,53 @@ type_tuple:
sum_type:
ioption(VBAR) nsepseq(variant,VBAR) {
let region = nsepseq_to_region (fun x -> x.region) $2
in {region; value = $2}
}
in {region; value=$2} }
variant:
Constr Of cartesian {
let region = cover $1.region $3.region
and value = {constr = $1; args = Some ($2, $3)}
let region = cover $1.region (type_expr_to_region $3)
and value = {constr=$1; arg = Some ($2, $3)}
in {region; value}
}
| Constr {
{region=$1.region; value= {constr=$1; args=None}} }
{region=$1.region; value={constr=$1; arg=None}} }
record_type:
LBRACE sep_or_term_list(field_decl,SEMI) RBRACE {
let elements, terminator = $2 in
let ne_elements, terminator = $2 in
let region = cover $1 $3
and value = {
opening = LBrace $1;
elements = Some elements;
terminator;
closing = RBrace $3}
in {region; value}
}
compound = Braces ($1,$3);
ne_elements;
terminator}
in {region; value} }
field_decl:
field_name COLON type_expr {
let stop = type_expr_to_region $3 in
let region = cover $1.region stop
and value = {field_name = $1; colon = $2; field_type = $3}
in {region; value}
}
(* Entry points *)
entry_binding:
Ident nseq(sub_irrefutable) type_annotation? EQ expr {
let let_rhs = $5 in
let pattern = PVar $1 in
let (hd , tl) = $2 in
{bindings = pattern :: hd :: tl; lhs_type=$3; eq=$4; let_rhs}
}
| Ident type_annotation? EQ fun_expr(expr) {
let pattern = PVar $1 in
{bindings = [pattern]; lhs_type=$2; eq=$3; let_rhs=$4} }
in {region; value} }
(* Top-level non-recursive definitions *)
let_declaration:
Let let_binding {
let kwd_let = $1 in
let binding, region = $2 in
{value = kwd_let, binding; region}
}
let binding = $2 in
let value = kwd_let, binding in
let stop = expr_to_region binding.let_rhs in
let region = cover $1 stop
in {value; region} }
let_binding:
Ident nseq(sub_irrefutable) type_annotation? EQ expr {
let let_rhs = $5 in
let ident_pattern = PVar $1 in
let (hd , tl) = $2 in
let start = $1.region in
let stop = expr_to_region $5 in
let region = cover start stop in
({bindings= (ident_pattern :: hd :: tl); lhs_type=$3; eq=$4; let_rhs}, region)
let binders = Utils.nseq_cons (PVar $1) $2 in
{binders; lhs_type=$3; eq=$4; let_rhs=$5}
}
| irrefutable type_annotation? EQ expr {
let pattern = $1 in
let start = pattern_to_region $1 in
let stop = expr_to_region $4 in
let region = cover start stop in
({bindings = [pattern]; lhs_type=$2; eq=$3; let_rhs=$4}, region)
}
let binders = $1,[] in
{binders; lhs_type=$2; eq=$3; let_rhs=$4} }
type_annotation:
COLON type_expr { $1,$2 }
@ -314,11 +273,11 @@ type_annotation:
irrefutable:
tuple(sub_irrefutable) {
let h, t = $1 in
let start = pattern_to_region h in
let stop = last (fun (region, _) -> region) t in
let region = cover start stop in
PTuple { value = $1; region }
let hd, tl = $1 in
let start = pattern_to_region hd in
let stop = last fst tl in
let region = cover start stop
in PTuple {value=$1; region}
}
| sub_irrefutable { $1 }
@ -328,41 +287,45 @@ sub_irrefutable:
| unit { PUnit $1 }
| record_pattern { PRecord $1 }
| par(closed_irrefutable) { PPar $1 }
| Constr {
let value = $1, None
and region = $1.region in PConstr (PConstrApp {value; region}) }
closed_irrefutable:
irrefutable { $1 }
| constr_pattern { PConstr $1 }
| typed_pattern { PTyped $1 }
irrefutable {
$1 }
| Constr sub_pattern {
let stop = pattern_to_region $2 in
let region = cover $1.region stop
and value = $1, Some $2
in PConstr (PConstrApp {value; region}) }
| typed_pattern {
PTyped $1 }
typed_pattern:
irrefutable COLON type_expr {
let start = pattern_to_region $1 in
let stop = type_expr_to_region $3 in
let region = cover start stop in
{
value = {
let value = {
pattern = $1;
colon = $2;
type_expr = $3
};
region
}
}
type_expr = $3}
in {value; region} }
pattern:
sub_pattern CONS tail {
let start = pattern_to_region $1 in
let stop = pattern_to_region $3 in
let region = cover start stop in
let val_ = {value = $1, $2, $3; region} in
PList (PCons val_)
let region = cover start stop
and value = $1, $2, $3 in
PList (PCons {region; value})
}
| tuple(sub_pattern) {
let h, t = $1 in
let start = pattern_to_region h in
let stop = last (fun (region, _) -> region) t in
let region = cover start stop in
PTuple { value = $1; region }
let start = pattern_to_region (fst $1) in
let stop = last fst (snd $1) in
let region = cover start stop
in PTuple {value=$1; region}
}
| core_pattern { $1 }
@ -373,67 +336,77 @@ sub_pattern:
core_pattern:
Ident { PVar $1 }
| WILD { PWild $1 }
| unit { PUnit $1 }
| Int { PInt $1 }
| True { PTrue $1 }
| Nat { PNat $1 }
| Bytes { PBytes $1 }
| String { PString $1 }
| unit { PUnit $1 }
| False { PFalse $1 }
| Str { PString $1 }
| True { PTrue $1 }
| par(ptuple) { PPar $1 }
| list(tail) { PList (Sugar $1) }
| list(tail) { PList (PListComp $1) }
| constr_pattern { PConstr $1 }
| record_pattern { PRecord $1 }
record_pattern:
LBRACE sep_or_term_list(field_pattern,SEMI) RBRACE {
let elements, terminator = $2 in
let ne_elements, terminator = $2 in
let region = cover $1 $3 in
let value = {
opening = LBrace $1;
elements = Some elements;
terminator;
closing = RBrace $3}
in
{region; value}
}
compound = Braces ($1,$3);
ne_elements;
terminator}
in {region; value} }
field_pattern:
field_name EQ sub_pattern {
let start = $1.region in
let stop = pattern_to_region $3 in
let region = cover start stop in
{ value = {field_name=$1; eq=$2; pattern=$3}; region }
}
let start = $1.region
and stop = pattern_to_region $3 in
let region = cover start stop
and value = {field_name=$1; eq=$2; pattern=$3}
in {value; region} }
constr_pattern:
Constr sub_pattern {
let region = cover $1.region (pattern_to_region $2) in
{ value = $1, Some $2; region } }
| Constr { { value = $1, None; region = $1.region } }
C_None { PNone $1 }
| C_Some sub_pattern {
let stop = pattern_to_region $2 in
let region = cover $1 stop
and value = $1, $2
in PSomeApp {value; region}
}
| Constr sub_pattern? {
let start = $1.region in
let stop =
match $2 with
Some p -> pattern_to_region p
| None -> start in
let region = cover start stop
and value = $1,$2
in PConstrApp {value; region} }
ptuple:
tuple(tail) {
let h, t = $1 in
let start = pattern_to_region h in
let stop = last (fun (region, _) -> region) t in
let stop = last fst t in
let region = cover start stop in
PTuple { value = $1; region }
}
PTuple {value = $1; region} }
unit:
LPAR RPAR {
let the_unit = ghost, ghost in
let region = cover $1 $2 in
{ value = the_unit; region }
}
let value = ghost, ghost in
let region = cover $1 $2
in {value; region} }
tail:
sub_pattern CONS tail {
let start = pattern_to_region $1 in
let end_ = pattern_to_region $3 in
let region = cover start end_ in
let stop = pattern_to_region $3 in
let region = cover start stop in
PList (PCons {value = ($1, $2, $3); region} )
}
| sub_pattern { $1 }
| sub_pattern {
$1 }
(* Expressions *)
@ -452,16 +425,16 @@ base_cond:
base_cond__open(base_cond) { $1 }
base_expr(right_expr):
let_expr(right_expr)
| fun_expr(right_expr)
| disj_expr_level { $1 }
| tuple(disj_expr_level) {
let h, t = $1 in
let start = expr_to_region h in
let stop = last (fun (region, _) -> region) t in
let region = cover start stop in
ETuple { value = $1; region }
tuple(disj_expr_level) {
let start = expr_to_region (fst $1) in
let stop = last fst (snd $1) in
let region = cover start stop
in ETuple {value=$1; region}
}
| let_expr(right_expr)
| fun_expr(right_expr)
| disj_expr_level {
$1 }
conditional(right_expr):
if_then_else(right_expr)
@ -470,38 +443,29 @@ conditional(right_expr):
if_then(right_expr):
If expr Then right_expr {
let the_unit = ghost, ghost in
let start = $1 in
let stop = expr_to_region $4 in
let region = cover start stop in
let ifnot = EUnit {region=ghost; value=the_unit} in
{
value = {
let stop = expr_to_region $4 in
let region = cover $1 stop in
let value = {
kwd_if = $1;
test = $2;
kwd_then = $3;
ifso = $4;
kwd_else = ghost;
ifnot
};
region
}
}
ifnot}
in {value; region} }
if_then_else(right_expr):
If expr Then closed_if Else right_expr {
let region = cover $1 (expr_to_region $6) in
{
value = {
let region = cover $1 (expr_to_region $6)
and value = {
kwd_if = $1;
test = $2;
kwd_then = $3;
ifso = $4;
kwd_else = $5;
ifnot = $6
};
region
}
}
ifnot = $6}
in {value; region} }
base_if_then_else__open(x):
base_expr(x) { $1 }
@ -516,83 +480,48 @@ closed_if:
match_expr(right_expr):
Match expr With VBAR? cases(right_expr) {
let cases = Utils.nsepseq_rev $5 in
let start = $1 in
let stop = match $5 with (* TODO: move to separate function *)
| {region; _}, [] -> region
| _, tl -> last (fun (region,_) -> region) tl
in
let region = cover start stop in
{ value = {
let cases = {
value = Utils.nsepseq_rev $5;
region = nsepseq_to_region (fun x -> x.region) $5}
and stop =
match $5 with
{region; _}, [] -> region
| _, tl -> last fst tl in
let region = cover $1 stop
and value = {
kwd_match = $1;
expr = $2;
opening = With $3;
kwd_with = $3;
lead_vbar = $4;
cases = {
value = cases;
region = nsepseq_to_region (fun {region; _} -> region) $5
};
closing = End ghost
};
region
}
}
| MatchNat expr With VBAR? cases(right_expr) {
let cases = Utils.nsepseq_rev $5 in
let cast = EVar {region=ghost; value="assert_pos"} in
let cast = ECall {region=ghost; value=cast,($2,[])} in
let start = $1 in
let stop = match $5 with (* TODO: move to separate function *)
| {region; _}, [] -> region
| _, tl -> last (fun (region,_) -> region) tl
in
let region = cover start stop in
{
value = {
kwd_match = $1;
expr = cast;
opening = With $3;
lead_vbar = $4;
cases = {
value = cases;
region = nsepseq_to_region (fun {region; _} -> region) $5
};
closing = End ghost
};
region
}
}
cases}
in {value; region} }
cases(right_expr):
case_clause(right_expr) {
let start = pattern_to_region $1.pattern in
let stop = expr_to_region $1.rhs in
let region = cover start stop in
{ value = $1; region }, []
let start = pattern_to_region $1.pattern
and stop = expr_to_region $1.rhs in
let region = cover start stop
in {value=$1; region}, []
}
| cases(base_cond) VBAR case_clause(right_expr) {
let start = match $1 with
| {region; _}, [] -> region
| _, tl -> last (fun (region,_) -> region) tl
in
let stop = expr_to_region $3.rhs in
let start =
match $1 with
only_case, [] -> only_case.region
| _, other_cases -> last fst other_cases
and stop = expr_to_region $3.rhs in
let region = cover start stop in
let h,t = $1 in { value = $3; region}, ($2, h)::t
}
let fst_case = {value=$3; region}
and snd_case, others = $1
in fst_case, ($2,snd_case)::others }
case_clause(right_expr):
pattern ARROW right_expr {
{
pattern = $1;
arrow = $2;
rhs=$3
}
}
{pattern=$1; arrow=$2; rhs=$3} }
let_expr(right_expr):
Let let_binding In right_expr {
let kwd_let = $1 in
let (binding, _) = $2 in
let binding = $2 in
let kwd_in = $3 in
let body = $4 in
let stop = expr_to_region $4 in
@ -602,22 +531,15 @@ let_expr(right_expr):
fun_expr(right_expr):
Fun nseq(irrefutable) ARROW right_expr {
let kwd_fun = $1 in
let bindings = $2 in
let arrow = $3 in
let body = $4 in
let stop = expr_to_region $4 in
let region = cover $1 stop in
let (hd , tl) = bindings in
let f = {
kwd_fun ;
params = hd :: tl ;
p_annot = None ;
arrow ;
body ;
} in
EFun { region; value=f }
}
kwd_fun = $1;
binders = $2;
lhs_type = None;
arrow = $3;
body = $4}
in EFun {region; value=f} }
disj_expr_level:
disj_expr { ELogic (BoolExpr (Or $1)) }
@ -683,7 +605,7 @@ append_expr:
*)
cons_expr_level:
cons_expr { EList (Cons $1) }
cons_expr { EList (ECons $1) }
| add_expr_level { $1 }
cons_expr:
@ -718,19 +640,18 @@ mod_expr:
unary_expr_level:
MINUS call_expr_level {
let start = $1 in
let end_ = expr_to_region $2 in
let region = cover start end_
let stop = expr_to_region $2 in
let region = cover start stop
and value = {op = $1; arg = $2}
in EArith (Neg {region; value})
}
in EArith (Neg {region; value}) }
| Not call_expr_level {
let start = $1 in
let end_ = expr_to_region $2 in
let region = cover start end_
let stop = expr_to_region $2 in
let region = cover start stop
and value = {op = $1; arg = $2} in
ELogic (BoolExpr (Not ({region; value})))
}
| call_expr_level { $1 }
ELogic (BoolExpr (Not ({region; value}))) }
| call_expr_level {
$1 }
call_expr_level:
call_expr { ECall $1 }
@ -738,26 +659,30 @@ call_expr_level:
| core_expr { $1 }
constr_expr:
Constr core_expr? {
let start = $1.region in
let stop = match $2 with
| Some c -> expr_to_region c
| None -> start
in
let region = cover start stop in
{ value = $1,$2; region}
C_None {
ENone $1
}
| C_Some core_expr {
let region = cover $1 (expr_to_region $2)
in ESomeApp {value = $1,$2; region}
}
| Constr core_expr? {
let start = $1.region in
let stop =
match $2 with
Some c -> expr_to_region c
| None -> start in
let region = cover start stop
in EConstrApp {value=$1,$2; region} }
call_expr:
core_expr nseq(core_expr) {
let start = expr_to_region $1 in
let stop = match $2 with
| e, [] -> expr_to_region e
| _, l -> last expr_to_region l
in
e, [] -> expr_to_region e
| _, l -> last expr_to_region l in
let region = cover start stop in
{ value = $1,$2; region }
}
{value = $1,$2; region} }
core_expr:
Int { EArith (Int $1) }
@ -765,11 +690,11 @@ core_expr:
| Nat { EArith (Nat $1) }
| Ident | module_field { EVar $1 }
| projection { EProj $1 }
| Str { EString (String $1) }
| String { EString (StrLit $1) }
| unit { EUnit $1 }
| False { ELogic (BoolExpr (False $1)) }
| True { ELogic (BoolExpr (True $1)) }
| list(expr) { EList (List $1) }
| list(expr) { EList (EListComp $1) }
| par(expr) { EPar $1 }
| sequence { ESeq $1 }
| record_expr { ERecord $1 }
@ -779,93 +704,70 @@ core_expr:
module_field:
module_name DOT field_name {
let region = cover $1.region $3.region in
{ value = $1.value ^ "." ^ $3.value; region }
}
{value = $1.value ^ "." ^ $3.value; region} }
projection:
struct_name DOT nsepseq(selection,DOT) {
let start = $1.region in
let stop = nsepseq_to_region (function
| FieldName f -> f.region
| Component c -> c.region) $3
in
let stop = nsepseq_to_region selection_to_region $3 in
let region = cover start stop in
{ value =
{
let value = {
struct_name = $1;
selector = $2;
field_path = $3
};
region
}
field_path = $3}
in {value; region}
}
| module_name DOT field_name DOT nsepseq(selection,DOT) {
let module_name = $1 in
let field_name = $3 in
let value = module_name.value ^ "." ^ field_name.value in
let value = $1.value ^ "." ^ $3.value in
let struct_name = {$1 with value} in
let start = $1.region in
let stop = nsepseq_to_region (function
| FieldName f -> f.region
| Component c -> c.region) $5
in
let stop = nsepseq_to_region selection_to_region $5 in
let region = cover start stop in
{
value = {
let value = {
struct_name;
selector = $4;
field_path = $5
};
region
}
}
field_path = $5}
in {value; region} }
selection:
field_name { FieldName $1 }
| par(Int) { Component $1 }
| Int { Component $1 }
record_expr:
LBRACE sep_or_term_list(field_assignment,SEMI) RBRACE {
let elements, terminator = $2 in
let ne_elements, terminator = $2 in
let region = cover $1 $3 in
{value =
{
opening = LBrace $1;
elements = Some elements;
terminator;
closing = RBrace $3
};
region}
}
let value = {
compound = Braces ($1,$3);
ne_elements;
terminator}
in {value; region} }
field_assignment:
field_name EQ expr {
let start = $1.region in
let stop = expr_to_region $3 in
let region = cover start stop in
{ value =
{
let value = {
field_name = $1;
assignment = $2;
field_expr = $3
};
region
}
}
field_expr = $3}
in {value; region} }
sequence:
Begin sep_or_term_list(expr,SEMI) End {
let elements, terminator = $2 in
let start = $1 in
let stop = $3 in
let region = cover start stop in
{
value = {
opening = Begin $1;
elements = Some elements;
terminator;
closing = End $3
};
region
}
let ne_elements, terminator = $2 in
let value = {
compound = BeginEnd ($1,$3);
elements = Some ne_elements;
terminator} in
let region = cover $1 $3
in {value; region}
}
| Begin End {
let value = {
compound = BeginEnd ($1,$2);
elements = None;
terminator = None} in
let region = cover $1 $2
in {value; region} }

763
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;
@ -75,10 +84,10 @@ and print_statement buffer = function
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
| TRecord t -> print_rec_type_expr buffer t
| TApp app -> print_type_app buffer app
| TPar par -> print_type_par buffer par
| TAlias var -> print_var buffer var
| TVar var -> print_var buffer var
| TFun t -> print_fun_type buffer t
and print_fun_type buffer {value; _} =
@ -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;
let {compound; elements; terminator} = value in
print_open_compound buffer compound;
print_sepseq buffer ";" print elements;
print_terminator buffer terminator;
print_closing buffer closing
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,9 +211,12 @@ 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
PListComp p -> print_injection buffer print_pattern p
| PCons p -> print_raw buffer p
and print_raw buffer {value=p1,c,p2; _} =
@ -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
ELetIn let_in -> print_let_in buffer let_in
| ECond cond -> print_conditional buffer cond
| ETuple {value;_} -> print_csv buffer print_expr value
| ECase {value;_} -> print_match_expr buffer value
| 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
| 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}; _} ->
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
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 ")"
| 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_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
@ -454,9 +493,525 @@ and print_conditional buffer {value; _} =
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;

5
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
@ -558,7 +558,6 @@ and scan state = parse
| 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 }

290
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 -> (
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
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,39 +548,32 @@ 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 {binders; 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 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 ;
binders = param1, others;
lhs_type;
arrow = Region.ghost;
body = let_rhs ;
} in
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 =
fun t ->
@ -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
| _ -> 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
@ -712,22 +643,20 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result =
| [(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 (a, b) in
ok @@ Match_list {match_cons=(a, b, cons); match_nil=nil}
)
| lst -> (
| lst ->
let error x =
let title () = "Pattern" in
let content () =
@ -740,34 +669,25 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result =
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%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%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 ()

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

@ -1,7 +1,6 @@
type storage = unit
let%entry main (p:unit) storage =
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

4
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))
let main (p: unit) storage =
(fun (f: int -> int) (_: int) (y: int) -> f y)
(fun (x: int) -> x)
0
1

4
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))
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

4
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))
let main (p: unit) storage =
(fun (f: int -> int) (x: int) -> f x)
(fun (x: int) -> x)
1

18
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 = "" ;
}
type param = {
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

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

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

@ -6,21 +6,20 @@ let x : int list = []
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)
| 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 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
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

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

@ -2,12 +2,12 @@ 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 set_ (n: int) (m: foobar) : foobar = Map.update 23 (Some n) m
let rm (m: foobar) : foobar = Map.remove 42 m
@ -18,7 +18,8 @@ let patch_ (m : foobar) : foobar = Map.literal [ (0, 5) ; (1, 6) ; (2, 7) ]
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
@ -28,19 +29,19 @@ 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 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

4
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

13
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)
Increment n -> add storage n
| Decrement n -> sub storage n
in ([] : operation list), storage

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

@ -1,19 +1,13 @@
(** Type of storage for this contract *)
type storage = {
challenge : string;
}
(** Initial storage *)
let%init storage = {
challenge = "" ;
}
type param = {
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
@ -22,4 +16,4 @@ let%entry attempt (p:param) storage =
let transfer : operation =
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