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

Merge branch 'rinderknecht-dev' into 'dev'

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

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

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

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

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

@ -43,6 +43,11 @@ type kwd_true = Region.t
type kwd_type = Region.t type kwd_type = Region.t
type kwd_with = Region.t type kwd_with = Region.t
(* Data constructors *)
type c_None = Region.t
type c_Some = Region.t
(* Symbols *) (* Symbols *)
type arrow = Region.t (* "->" *) type arrow = Region.t (* "->" *)
@ -114,7 +119,7 @@ type the_unit = lpar * rpar
(* The Abstract Syntax Tree (finally) *) (* The Abstract Syntax Tree (finally) *)
type t = { type t = {
decl : declaration Utils.nseq; decl : declaration nseq;
eof : eof eof : eof
} }
@ -123,14 +128,13 @@ and ast = t
and eof = Region.t and eof = Region.t
and declaration = and declaration =
Let of (kwd_let * let_binding) reg (* let x = e *) 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 ... *)
| TypeDecl of type_decl reg (* type ... *)
(* Non-recursive values *) (* Non-recursive values *)
and let_binding = { (* p = e p : t = e *) and let_binding = { (* p = e p : t = e *)
bindings : pattern list; binders : pattern nseq;
lhs_type : (colon * type_expr) option; lhs_type : (colon * type_expr) option;
eq : equal; eq : equal;
let_rhs : expr let_rhs : expr
@ -147,48 +151,53 @@ and type_decl = {
and type_expr = and type_expr =
TProd of cartesian TProd of cartesian
| TSum of (variant reg, vbar) Utils.nsepseq reg | TSum of (variant reg, vbar) nsepseq reg
| TRecord of record_type | TRecord of field_decl reg ne_injection reg
| TApp of (type_constr * type_tuple) reg | TApp of (type_constr * type_tuple) reg
| TFun of (type_expr * arrow * type_expr) reg | TFun of (type_expr * arrow * type_expr) reg
| TPar of type_expr par 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 = { and variant = {
constr : constr; constr : constr;
args : (kwd_of * cartesian) option arg : (kwd_of * type_expr) option
} }
and record_type = field_decl reg injection reg
and field_decl = { and field_decl = {
field_name : field_name; field_name : field_name;
colon : colon; colon : colon;
field_type : type_expr 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 = and pattern =
PTuple of (pattern, comma) Utils.nsepseq reg (* p1, p2, ... *) PConstr of constr_pattern (* True () None A B(3,"") *)
| PList of list_pattern
| PVar of variable (* x *)
| PUnit of the_unit reg (* () *) | PUnit of the_unit reg (* () *)
| PInt of (string * Z.t) reg (* 7 *)
| PTrue of kwd_true (* true *)
| PFalse of kwd_false (* false *) | 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" *) | PString of string reg (* "foo" *)
| PWild of wild (* _ *) | PWild of wild (* _ *)
| PList of list_pattern
| PTuple of (pattern, comma) nsepseq reg (* p1, p2, ... *)
| PPar of pattern par reg (* (p) *) | PPar of pattern par reg (* (p) *)
| PConstr of (constr * pattern option) reg (* A B(3,"") *) | PRecord of field_pattern reg ne_injection reg (* {a=...; ...} *)
| PRecord of record_pattern (* {a=...; ...} *)
| PTyped of typed_pattern reg (* (x : int) *) | 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 = 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 *) | PCons of (pattern * cons * pattern) reg (* p1 :: p2 *)
and typed_pattern = { and typed_pattern = {
pattern : pattern; pattern : pattern;
@ -196,8 +205,6 @@ and typed_pattern = {
type_expr : type_expr type_expr : type_expr
} }
and record_pattern = field_pattern reg injection reg
and field_pattern = { and field_pattern = {
field_name : field_name; field_name : field_name;
eq : equal; eq : equal;
@ -205,78 +212,78 @@ and field_pattern = {
} }
and expr = and expr =
ECase of expr case reg (* p1 -> e1 | p2 -> e2 | ... *) 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 | ELogic of logic_expr
| EArith of arith_expr | EArith of arith_expr
| EString of string_expr | EString of string_expr
| EList of list_expr | EList of list_expr (* x::y::l [1;2;3] *)
| EConstr of constr_expr reg | EConstr of constr_expr (* A B(1,A) (C A) *)
| ERecord of record_expr (* {f1=e1; ... } *) | ERecord of field_assign reg ne_injection reg (* {f1=e1; ... } *)
| EProj of projection reg (* x.y.z M.x.y *) | EProj of projection reg (* x.y.z M.x.y *)
| EVar of variable (* x *) | 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 *) | EBytes of (string * Hex.t) reg (* 0xAEFF *)
| EUnit of the_unit reg (* () *) | 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) *) | EPar of expr par reg (* (e) *)
| ELetIn of let_in reg (* let p1 = e1 and p2 = e2 and ... in e *) | ELetIn of let_in reg (* let p1 = e1 and p2 = e2 and ... in e *)
| EFun of fun_expr reg (* fun x -> e *) | EFun of fun_expr reg (* fun x -> e *)
| ECond of conditional reg (* if e1 then e2 else e3 *) | ESeq of expr injection reg (* begin e1; e2; ... ; en end *)
| ESeq of sequence (* begin e1; e2; ... ; en end *)
and constr_expr = constr * expr option
and annot_expr = expr * type_expr
and 'a injection = { and 'a injection = {
opening : opening; compound : compound;
elements : ('a, semi) Utils.sepseq; elements : ('a, semi) sepseq;
terminator : semi option; terminator : semi option
closing : closing
} }
and opening = and 'a ne_injection = {
Begin of kwd_begin compound : compound;
| With of kwd_with ne_elements : ('a, semi) nsepseq;
| LBrace of lbrace terminator : semi option
| LBracket of lbracket }
and closing = and compound =
End of kwd_end BeginEnd of kwd_begin * kwd_end
| RBrace of rbrace | Braces of lbrace * rbrace
| RBracket of rbracket | Brackets of lbracket * rbracket
and list_expr = and list_expr =
Cons of cat bin_op reg (* e1 :: e3 *) ECons of cat bin_op reg (* e1 :: e3 *)
| List of expr injection reg (* [e1; e2; ...] *) | EListComp of expr injection reg (* [e1; e2; ...] *)
(*| Append of (expr * append * expr) reg *) (* e1 @ e2 *) (*| Append of (expr * append * expr) reg *) (* e1 @ e2 *)
and string_expr = and string_expr =
Cat of cat bin_op reg (* e1 ^ e2 *) 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 = and arith_expr =
Add of plus bin_op reg (* e1 + e2 *) Add of plus bin_op reg (* e1 + e2 *)
| Sub of minus bin_op reg (* e1 - e2 *) | Sub of minus bin_op reg (* e1 - e2 *)
| Mult of times bin_op reg (* e1 * e2 *) | Mult of times bin_op reg (* e1 * e2 *)
| Div of slash bin_op reg (* e1 / e2 *) | Div of slash bin_op reg (* e1 / e2 *)
| Mod of kwd_mod bin_op reg (* e1 mod e2 *) | Mod of kwd_mod bin_op reg (* e1 mod e2 *)
| Neg of minus un_op reg (* -e *) | Neg of minus un_op reg (* -e *)
| Int of (string * Z.t) reg (* 12345 *) | Int of (string * Z.t) reg (* 12345 *)
| Nat of (string * Z.t) reg (* 3p *) | Nat of (string * Z.t) reg (* 3n *)
| Mutez of (string * Z.t) reg (* 1.00tz 3tz *) | Mutez of (string * Z.t) reg (* 1.00tz 3tz 233mutez *)
and logic_expr = and logic_expr =
BoolExpr of bool_expr BoolExpr of bool_expr
| CompExpr of comp_expr | CompExpr of comp_expr
and bool_expr = and bool_expr =
Or of kwd_or bin_op reg Or of kwd_or bin_op reg
| And of kwd_and bin_op reg | And of kwd_and bin_op reg
| Not of kwd_not un_op reg | Not of kwd_not un_op reg
| True of kwd_true | True of kwd_true
| False of kwd_false | False of kwd_false
and 'a bin_op = { and 'a bin_op = {
op : 'a; op : 'a;
@ -300,14 +307,12 @@ and comp_expr =
and projection = { and projection = {
struct_name : variable; struct_name : variable;
selector : dot; selector : dot;
field_path : (selection, dot) Utils.nsepseq field_path : (selection, dot) nsepseq
} }
and selection = and selection =
FieldName of variable FieldName of variable
| Component of (string * Z.t) reg par reg | Component of (string * Z.t) reg
and record_expr = field_assign reg injection reg
and field_assign = { and field_assign = {
field_name : field_name; field_name : field_name;
@ -315,15 +320,12 @@ and field_assign = {
field_expr : expr field_expr : expr
} }
and sequence = expr injection reg
and 'a case = { and 'a case = {
kwd_match : kwd_match; kwd_match : kwd_match;
expr : expr; expr : expr;
opening : opening; kwd_with : kwd_with;
lead_vbar : vbar option; lead_vbar : vbar option;
cases : ('a case_clause reg, vbar) Utils.nsepseq reg; cases : ('a case_clause reg, vbar) nsepseq reg
closing : closing
} }
and 'a case_clause = { and 'a case_clause = {
@ -340,139 +342,26 @@ and let_in = {
} }
and fun_expr = { and fun_expr = {
kwd_fun : kwd_fun; kwd_fun : kwd_fun;
params : pattern list; binders : pattern nseq;
p_annot : (colon * type_expr) option; lhs_type : (colon * type_expr) option;
arrow : arrow; arrow : arrow;
body : expr body : expr
} }
and conditional = { and cond_expr = {
kwd_if : kwd_if; kwd_if : kwd_if;
test : expr; test : expr;
kwd_then : kwd_then; kwd_then : kwd_then;
ifso : expr; ifso : expr;
kwd_else : kwd_else; kwd_else : kwd_else;
ifnot : expr 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 (* Projecting regions from sundry nodes of the AST. See the first
comment at the beginning of this file. *) comment at the beginning of this file. *)
val pattern_to_region : pattern -> Region.t val pattern_to_region : pattern -> Region.t
val expr_to_region : expr -> Region.t val expr_to_region : expr -> Region.t
val type_expr_to_region : type_expr -> Region.t val type_expr_to_region : type_expr -> Region.t
val selection_to_region : selection -> 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

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

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

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

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

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

File diff suppressed because it is too large Load Diff

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

@ -24,7 +24,8 @@ let print_sepseq buffer sep print = function
None -> () None -> ()
| Some seq -> print_nsepseq buffer sep print seq | 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 print_token buffer (reg: Region.t) conc =
let line = sprintf "%s: %s\n" (compact reg) 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 let line = sprintf "%s: Ident %s\n" (compact region) value
in Buffer.add_string buffer line 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 print_pvar buffer Region.{region; value} =
let line = sprintf "%s: PVar %s\n" (compact region) value let line = sprintf "%s: PVar %s\n" (compact region) value
in Buffer.add_string buffer line 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 let line = sprintf "%s: Uident %s\n" (compact region) value
in Buffer.add_string buffer line in Buffer.add_string buffer line
let print_str buffer Region.{region; value} = let print_string buffer Region.{region; value} =
let line = sprintf "%s: Str \"%s\"\n" (compact region) value let line = sprintf "%s: StrLit %s\n" (compact region) value
in Buffer.add_string buffer line in Buffer.add_string buffer line
let print_bytes buffer Region.{region; value=lexeme, abstract} = 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 in Buffer.add_string buffer line
let print_int buffer Region.{region; value=lex,z} = 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 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} = let rec print_tokens buffer {decl;eof} =
Utils.nseq_iter (print_statement buffer) decl; Utils.nseq_iter (print_statement buffer) decl;
print_token buffer eof "EOF" print_token buffer eof "EOF"
@ -63,9 +75,6 @@ and print_statement buffer = function
Let {value=kwd_let, let_binding; _} -> Let {value=kwd_let, let_binding; _} ->
print_token buffer kwd_let "let"; print_token buffer kwd_let "let";
print_let_binding buffer let_binding 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}; _} -> | TypeDecl {value={kwd_type; name; eq; type_expr}; _} ->
print_token buffer kwd_type "type"; print_token buffer kwd_type "type";
print_var buffer name; print_var buffer name;
@ -73,13 +82,13 @@ and print_statement buffer = function
print_type_expr buffer type_expr print_type_expr buffer type_expr
and print_type_expr buffer = function and print_type_expr buffer = function
TProd prod -> print_cartesian buffer prod TProd prod -> print_cartesian buffer prod
| TSum {value; _} -> print_nsepseq buffer "|" print_variant value | 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 | TApp app -> print_type_app buffer app
| TPar par -> print_type_par buffer par | 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 | TFun t -> print_fun_type buffer t
and print_fun_type buffer {value; _} = and print_fun_type buffer {value; _} =
let domain, arrow, range = value in let domain, arrow, range = value in
@ -103,36 +112,33 @@ and print_type_par buffer {value={lpar;inside=t;rpar}; _} =
print_type_expr buffer t; print_type_expr buffer t;
print_token buffer rpar ")" print_token buffer rpar ")"
and print_projection buffer node = and print_projection buffer {value; _} =
let {struct_name; selector; field_path} = node in let {struct_name; selector; field_path} = value in
print_var buffer struct_name; print_var buffer struct_name;
print_token buffer selector "."; print_token buffer selector ".";
print_nsepseq buffer "." print_selection field_path print_nsepseq buffer "." print_selection field_path
and print_selection buffer = function and print_selection buffer = function
FieldName id -> FieldName id -> print_var buffer id
print_var buffer id | Component c -> print_int buffer c
| 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 ")"
and print_cartesian buffer Region.{value;_} = and print_cartesian buffer Region.{value;_} =
print_nsepseq buffer "*" print_type_expr 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; print_uident buffer constr;
match args with match arg with
None -> () None -> ()
| Some (kwd_of, cartesian) -> | Some (kwd_of, t_expr) ->
print_token buffer kwd_of "of"; print_token buffer kwd_of "of";
print_cartesian buffer cartesian print_type_expr buffer t_expr
and print_record_type buffer record_type = and print_rec_type_expr buffer {value; _} =
print_injection buffer print_field_decl record_type 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; _} = and print_field_decl buffer {value; _} =
let {field_name; colon; field_type} = value let {field_name; colon; field_type} = value
@ -143,29 +149,37 @@ and print_field_decl buffer {value; _} =
and print_injection : and print_injection :
'a.Buffer.t -> (Buffer.t -> 'a -> unit) -> 'a injection reg -> unit = 'a.Buffer.t -> (Buffer.t -> 'a -> unit) -> 'a injection reg -> unit =
fun buffer print {value; _} -> fun buffer print {value; _} ->
let {opening; elements; terminator; closing} = value in let {compound; elements; terminator} = value in
print_opening buffer opening; print_open_compound buffer compound;
print_sepseq buffer ";" print elements; print_sepseq buffer ";" print elements;
print_terminator buffer terminator; print_terminator buffer terminator;
print_closing buffer closing print_close_compound buffer compound
and print_opening buffer = function and print_ne_injection :
Begin region -> print_token buffer region "begin" 'a.Buffer.t -> (Buffer.t -> 'a -> unit) -> 'a ne_injection reg -> unit =
| With region -> print_token buffer region "with" fun buffer print {value; _} ->
| LBrace region -> print_token buffer region "{" let {compound; ne_elements; terminator} = value in
| LBracket region -> print_token buffer region "[" 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 and print_open_compound buffer = function
End region -> print_token buffer region "end" BeginEnd (kwd_begin,_) -> print_token buffer kwd_begin "begin"
| RBrace region -> print_token buffer region "}" | Braces (lbrace,_) -> print_token buffer lbrace "{"
| RBracket region -> print_token buffer region "]" | 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 and print_terminator buffer = function
Some semi -> print_token buffer semi ";" Some semi -> print_token buffer semi ";"
| None -> () | None -> ()
and print_let_binding buffer {bindings; lhs_type; eq; let_rhs} = and print_let_binding buffer {binders; lhs_type; eq; let_rhs} =
let () = List.iter (print_pattern buffer) bindings in let () = Utils.nseq_iter (print_pattern buffer) binders in
let () = let () =
match lhs_type with match lhs_type with
None -> () None -> ()
@ -176,25 +190,17 @@ and print_let_binding buffer {bindings; lhs_type; eq; let_rhs} =
in print_expr buffer let_rhs in print_expr buffer let_rhs
and print_pattern buffer = function and print_pattern buffer = function
PTuple {value=patterns;_} -> PTuple ptuple ->
print_csv buffer print_pattern patterns print_csv buffer print_pattern ptuple
| PList p -> | PList p ->
print_list_pattern buffer p print_list_pattern buffer p
| PVar v -> | PVar v ->
print_pvar buffer v print_pvar buffer v
| PUnit {value=lpar,rpar; _} -> | PInt i -> print_int buffer i
print_token buffer lpar "("; | PNat i -> print_nat buffer i
print_token buffer rpar ")" | PBytes b -> print_bytes buffer b
| PInt i -> | PString s -> print_string buffer s
print_int buffer i | PWild wild -> print_token buffer wild "_"
| 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 "_"
| PPar {value={lpar;inside=p;rpar}; _} -> | PPar {value={lpar;inside=p;rpar}; _} ->
print_token buffer lpar "("; print_token buffer lpar "(";
print_pattern buffer p; print_pattern buffer p;
@ -205,10 +211,13 @@ and print_pattern buffer = function
print_record_pattern buffer r print_record_pattern buffer r
| PTyped t -> | PTyped t ->
print_typed_pattern buffer 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 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 | PCons p -> print_raw buffer p
and print_raw buffer {value=p1,c,p2; _} = and print_raw buffer {value=p1,c,p2; _} =
print_pattern buffer p1; print_pattern buffer p1;
@ -222,7 +231,7 @@ and print_typed_pattern buffer {value; _} =
print_type_expr buffer type_expr print_type_expr buffer type_expr
and print_record_pattern buffer record_pattern = 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; _} = and print_field_pattern buffer {value; _} =
let {field_name; eq; pattern} = value in let {field_name; eq; pattern} = value in
@ -230,51 +239,79 @@ and print_field_pattern buffer {value; _} =
print_token buffer eq "="; print_token buffer eq "=";
print_pattern buffer pattern 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; print_uident buffer constr;
match p_opt with match p_opt with
None -> () None -> ()
| Some pattern -> print_pattern buffer pattern | Some pattern -> print_pattern buffer pattern
and print_expr buffer = function 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 | ECond cond -> print_conditional buffer cond
| ETuple {value;_} -> print_csv buffer print_expr value | ETuple tuple -> print_csv buffer print_expr tuple
| ECase {value;_} -> print_match_expr buffer value | ECase case -> print_match_expr buffer case
| EFun e -> print_fun_expr buffer e | EFun e -> print_fun_expr buffer e
| EAnnot e -> print_annot_expr buffer e
| ELogic e -> print_logic_expr buffer e
| EArith e -> print_arith_expr buffer e
| EString e -> print_string_expr buffer e
| ECall e -> print_fun_call buffer e
| EVar v -> print_var buffer v
| EProj p -> print_projection buffer p
| EUnit e -> print_unit buffer e
| EBytes b -> print_bytes buffer b
| EPar e -> print_expr_par buffer e
| EList e -> print_list_expr buffer e
| ESeq seq -> print_sequence buffer seq
| ERecord e -> print_record_expr buffer e
| EConstr e -> print_constr_expr buffer e
| EAnnot e -> print_annot_expr buffer e and print_constr_expr buffer = function
| ELogic e -> print_logic_expr buffer e ENone e -> print_none_expr buffer e
| EArith e -> print_arith_expr buffer e | ESomeApp e -> print_some_app_expr buffer e
| EString e -> print_string_expr buffer e | EConstrApp e -> print_constr_app_expr buffer e
| ECall {value=f,l; _} -> and print_none_expr buffer value = print_token buffer value "None"
print_expr buffer f;
Utils.nseq_iter (print_expr buffer) l and print_some_app_expr buffer {value; _} =
| EVar v -> let c_Some, argument = value in
print_var buffer v print_token buffer c_Some "Some";
| EProj p -> print_expr buffer argument
print_projection buffer p.value
| EUnit {value=lpar,rpar; _} -> and print_constr_app_expr buffer {value; _} =
print_token buffer lpar "("; let constr, argument = value in
print_token buffer rpar ")" print_constr buffer constr;
| EBytes b -> match argument with
print_bytes buffer b None -> ()
| EPar {value={lpar;inside=e;rpar}; _} -> | Some arg -> print_expr buffer arg
print_token buffer lpar "(";
print_expr buffer e; and print_expr_par buffer {value; _} =
print_token buffer rpar ")" let {lpar;inside=e;rpar} = value in
| EList e -> print_token buffer lpar "(";
print_list_expr buffer e print_expr buffer e;
| ESeq seq -> print_token buffer rpar ")"
print_sequence buffer seq
| ERecord e -> and print_unit buffer {value=lpar,rpar; _} =
print_record_expr buffer e print_token buffer lpar "(";
| EConstr {value=constr,None; _} -> print_token buffer rpar ")"
print_uident buffer constr
| EConstr {value=(constr, Some arg); _} -> and print_fun_call buffer {value=f,l; _} =
print_uident buffer constr; print_expr buffer f;
print_expr buffer arg Utils.nseq_iter (print_expr buffer) l
and print_annot_expr buffer {value=e,t; _} = and print_annot_expr buffer {value=e,t; _} =
print_expr buffer e; print_expr buffer e;
@ -282,11 +319,14 @@ and print_annot_expr buffer {value=e,t; _} =
print_type_expr buffer t print_type_expr buffer t
and print_list_expr buffer = function and print_list_expr buffer = function
Cons {value={arg1;op;arg2}; _} -> ECons {value={arg1;op;arg2}; _} ->
print_expr buffer arg1; print_expr buffer arg1;
print_token buffer op "::"; print_token buffer op "::";
print_expr buffer arg2 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; _} -> | Append {value=e1,append,e2; _} ->
print_expr buffer e1; print_expr buffer e1;
@ -333,8 +373,8 @@ and print_string_expr buffer = function
print_expr buffer arg1; print_expr buffer arg1;
print_token buffer op "^"; print_token buffer op "^";
print_expr buffer arg2 print_expr buffer arg2
| String s -> | StrLit s ->
print_str buffer s print_string buffer s
and print_logic_expr buffer = function and print_logic_expr buffer = function
BoolExpr e -> print_bool_expr buffer e BoolExpr e -> print_bool_expr buffer e
@ -384,7 +424,7 @@ and print_comp_expr buffer = function
print_expr buffer arg2 print_expr buffer arg2
and print_record_expr buffer e = 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; _} = and print_field_assign buffer {value; _} =
let {field_name; assignment; field_expr} = value in let {field_name; assignment; field_expr} = value in
@ -395,15 +435,13 @@ and print_field_assign buffer {value; _} =
and print_sequence buffer seq = and print_sequence buffer seq =
print_injection buffer print_expr seq print_injection buffer print_expr seq
and print_match_expr buffer expr = and print_match_expr buffer {value; _} =
let {kwd_match; expr; opening; let {kwd_match; expr; kwd_with; lead_vbar; cases} = value in
lead_vbar; cases; closing} = expr in
print_token buffer kwd_match "match"; print_token buffer kwd_match "match";
print_expr buffer expr; print_expr buffer expr;
print_opening buffer opening; print_token buffer kwd_with "with";
print_token_opt buffer lead_vbar "|"; print_token_opt buffer lead_vbar "|";
print_cases buffer cases; print_cases buffer cases
print_closing buffer closing
and print_token_opt buffer = function and print_token_opt buffer = function
None -> fun _ -> () None -> fun _ -> ()
@ -418,19 +456,20 @@ and print_case_clause buffer {value; _} =
print_token buffer arrow "->"; print_token buffer arrow "->";
print_expr buffer rhs print_expr buffer rhs
and print_let_in buffer (bind: let_in) = and print_let_in buffer {value; _} =
let {kwd_let; binding; kwd_in; body} = bind in let {kwd_let; binding; kwd_in; body} = value in
print_token buffer kwd_let "let"; print_token buffer kwd_let "let";
print_let_binding buffer binding; print_let_binding buffer binding;
print_token buffer kwd_in "in"; print_token buffer kwd_in "in";
print_expr buffer body print_expr buffer body
and print_fun_expr buffer {value; _} = 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 () = print_token buffer kwd_fun "fun" in
let () = Utils.nseq_iter (print_pattern buffer) binders in
let () = let () =
match p_annot with match lhs_type with
None -> List.iter (print_pattern buffer) params None -> ()
| Some (colon, type_expr) -> | Some (colon, type_expr) ->
print_token buffer colon ":"; print_token buffer colon ":";
print_type_expr buffer type_expr in print_type_expr buffer type_expr in
@ -442,21 +481,537 @@ and print_conditional buffer {value; _} =
let {kwd_if; test; kwd_then; let {kwd_if; test; kwd_then;
ifso; kwd_else; ifnot} = value in ifso; kwd_else; ifnot} = value in
print_token buffer ghost "("; print_token buffer ghost "(";
print_token buffer kwd_if "if"; print_token buffer kwd_if "if";
print_expr buffer test; print_expr buffer test;
print_token buffer kwd_then "then"; print_token buffer kwd_then "then";
print_expr buffer ifso; print_expr buffer ifso;
print_token buffer kwd_else "else"; print_token buffer kwd_else "else";
print_expr buffer ifnot; print_expr buffer ifnot;
print_token buffer ghost ")" print_token buffer ghost ")"
(* Conversion to string *) (* Conversion to string *)
let to_string printer node = let to_string printer node =
let buffer = Buffer.create 131 in let buffer = Buffer.create 131 in
let () = printer buffer node printer buffer node;
in Buffer.contents buffer Buffer.contents buffer
let tokens_to_string = to_string print_tokens let tokens_to_string = to_string print_tokens
let pattern_to_string = to_string print_pattern let pattern_to_string = to_string print_pattern
let expr_to_string = to_string print_expr 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 tokens_to_string : AST.t -> string
val pattern_to_string : AST.pattern -> string val pattern_to_string : AST.pattern -> string
val expr_to_string : AST.expr -> 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 try
let ast = Parser.contract tokeniser buffer in let ast = Parser.contract tokeniser buffer in
if Utils.String.Set.mem "ast" options.verbose 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 then let buffer = Buffer.create 131 in
begin begin
ParserLog.offsets := options.offsets; ParserLog.offsets := options.offsets;

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

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

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

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

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

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

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

@ -1,5 +1,2 @@
let%entry main (i : int) = let main (i: int) =
if (i = 2 : bool) then if (i=2 : bool) then (42: int) else (0: int)
(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 *) (* TODO : make a test using mutation, not shadowing *)
let%entry main (i : int) =
let main (i: int) =
let result = 0 in let result = 0 in
if i = 2 then if i = 2 then
let result = 42 in let result = 42 in result
result
else else
let result = 0 in let result = 0 in result
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) = let main (i: int) = if i = 2 then 42 else 0
if i = 2 then
42
else
0

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

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

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

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

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

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

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

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

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

@ -1,7 +1,7 @@
type storage = unit 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 + y)) (fun (f: int -> int -> int) (x: int) (y: int) -> f y (x+y))
(fun (x : int) (y : int) -> x + y) (fun (x: int) (y: int) -> x + y)
0 0
1 1

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -1,25 +1,19 @@
(** Type of storage for this contract *)
type storage = { type storage = {
challenge : string ; challenge : string;
}
(** Initial storage *)
let%init storage = {
challenge = "" ;
} }
type param = { type param = {
new_challenge : string ; new_challenge : string;
attempt : bytes ; attempt : bytes;
} }
let%entry attempt (p:param) storage = let attempt (p: param) storage =
if Crypto.hash (Bytes.pack p.attempt) <> Bytes.pack storage.challenge if Crypto.hash (Bytes.pack p.attempt) <> Bytes.pack storage.challenge
then failwith "Failed challenge" then failwith "Failed challenge"
else else
let contract : unit contract = let contract : unit contract =
Operation.get_contract sender in Operation.get_contract sender in
let transfer : operation = let transfer : operation =
Operation.transaction (unit , contract , 10tz) in Operation.transaction (unit, contract, 10tz) in
let storage : storage = {challenge = p.new_challenge} 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 Set.remove "foobar" s
let remove_deep (s : string set * nat) : string set * nat = 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 = 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 *) (* Test that the string concatenation syntax in CameLIGO works *)
let size_op (s : string) : nat = let size_op (s: string) : nat = String.size s
String.size s
let slice_op (s : string) : string = let slice_op (s: string) : string = String.slice 1n 2n s
String.slice 1p 2p s
let concat_syntax (s: string) = let concat_syntax (s: string) = s ^ "test_literal"
s ^ "test_literal"

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

@ -1,14 +1,12 @@
type abc = int * int * int type abc = int * int * int
let projection_abc (tpl : abc) : int = let projection_abc (tpl : abc) : int = tpl.1
tpl.(1)
type foobar = int * int type foobar = int * int
let fb : foobar = (0, 0) let fb : foobar = (0, 0)
let projection (tpl : foobar) : int = let projection (tpl : foobar) : int = tpl.0 + tpl.1
tpl.(0) + tpl.(1)
type big_tuple = int * int * int * int * int 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 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 | Init of init_action
let init (init_params : init_action) (_ : storage) = let init (init_params : init_action) (_ : storage) =
let candidates = Map [ let candidates = Map.literal [
("Yes" , 0) ; ("Yes" , 0) ;
("No" , 0) ("No" , 0)
] in ] in
@ -26,7 +26,7 @@ let init (init_params : init_action) (_ : storage) =
{ {
title = init_params.title ; title = init_params.title ;
candidates = candidates ; candidates = candidates ;
voters = (Set [] : address set) ; voters = (Set.empty : address set) ;
beginning_time = init_params.beginning_time ; beginning_time = init_params.beginning_time ;
finish_time = init_params.finish_time ; finish_time = init_params.finish_time ;
} }

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

@ -7,14 +7,13 @@ type action =
| Decrement of int | Decrement of int
let add (a: int) (b: int) : int = a + b let add (a: int) (b: int) : int = a + b
let sub (a: int) (b: int) : int = a - b
let subtract (a: int) (b: int) : int = a - b
(* real entrypoint that re-routes the flow based on the action provided *) (* 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 = let storage =
match p with match p with
| Increment n -> add storage n | Increment n -> add storage n
| Decrement n -> subtract storage n | Decrement n -> sub storage n
in (([] : operation list), storage) 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 info start_offset stop#line horizontal stop_offset
method compact ?(file=true) ?(offsets=true) mode = 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 let start_str = start#anonymous ~offsets mode
and stop_str = stop#anonymous ~offsets mode in and stop_str = stop#anonymous ~offsets mode in
if start#file = stop#file then if start#file = stop#file then
if file then sprintf "%s:%s-%s" start#file start_str stop_str if file then
else sprintf "%s-%s" start_str stop_str 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 else sprintf "%s:%s-%s:%s" start#file start_str stop#file stop_str
end end