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

Merge branch 'rinderknecht-dev' into 'dev'

Browse Source 
Refactorings on the front-ends.

See merge request ligolang/ligo!134
This commit is contained in:
Christian Rinderknecht 2019-10-17 11:02:14 +00:00
commit 9a0847cb9b
17 changed files with 1133 additions and 493 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -107,7 +107,7 @@ type t =
| Type of Region.t | Type of Region.t
| With of Region.t | With of Region.t
(* Liquidity specific *) (* Liquidity-specific *)
| LetEntry of Region.t | LetEntry of Region.t
| MatchNat of Region.t | MatchNat of Region.t
@ -137,23 +137,20 @@ val to_region : token -> Region.t
(* Injections *) (* Injections *)
type int_err = type int_err = Non_canonical_zero
Non_canonical_zero
type ident_err = Reserved_name type ident_err = Reserved_name
type nat_err = Invalid_natural
type invalid_natural =
| Invalid_natural
| Non_canonical_zero_nat | Non_canonical_zero_nat
type sym_err = Invalid_symbol
val mk_string : lexeme -> Region.t -> token
val mk_bytes : lexeme -> Region.t -> token
val mk_int : lexeme -> Region.t -> (token, int_err) result val mk_int : lexeme -> Region.t -> (token, int_err) result
val mk_nat : lexeme -> Region.t -> (token, invalid_natural) result val mk_nat : lexeme -> Region.t -> (token, nat_err) result
val mk_mtz : lexeme -> Region.t -> (token, int_err) result val mk_mtz : lexeme -> Region.t -> (token, int_err) result
val mk_ident : lexeme -> Region.t -> (token, ident_err) result val mk_ident : lexeme -> Region.t -> (token, ident_err) result
val mk_sym : lexeme -> Region.t -> (token, sym_err) result
val mk_string : lexeme -> Region.t -> token
val mk_bytes : lexeme -> Region.t -> token
val mk_constr : lexeme -> Region.t -> token val mk_constr : lexeme -> Region.t -> token
val mk_sym : lexeme -> Region.t -> token
val eof : Region.t -> token val eof : Region.t -> token
(* Predicates *) (* Predicates *)

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

@ -89,7 +89,7 @@ type t =
| Type of Region.t | Type of Region.t
| With of Region.t | With of Region.t
(* Liquidity specific *) (* Liquidity-specific *)
| LetEntry of Region.t | LetEntry of Region.t
| MatchNat of Region.t | MatchNat of Region.t
@ -379,11 +379,10 @@ let mk_int lexeme region =
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 invalid_natural = 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 'p') with
| None -> Error Invalid_natural | None -> Error Invalid_natural
@ -408,35 +407,41 @@ let mk_mtz lexeme region =
let eof region = EOF region let eof region = EOF region
type sym_err = Invalid_symbol
let mk_sym lexeme region = let mk_sym lexeme region =
match lexeme with match lexeme with
"->" -> ARROW region (* Lexemes in common with all concrete syntaxes *)
| "::" -> CONS region ";" -> Ok (SEMI region)
| "^" -> CAT region | "," -> Ok (COMMA region)
| "-" -> MINUS region | "(" -> Ok (LPAR region)
| "+" -> PLUS region | ")" -> Ok (RPAR region)
| "/" -> SLASH region | "[" -> Ok (LBRACKET region)
| "*" -> TIMES region | "]" -> Ok (RBRACKET region)
| "[" -> LBRACKET region | "{" -> Ok (LBRACE region)
| "]" -> RBRACKET region | "}" -> Ok (RBRACE region)
| "{" -> LBRACE region | "=" -> Ok (EQ region)
| "}" -> RBRACE region | ":" -> Ok (COLON region)
| "," -> COMMA region | "|" -> Ok (VBAR region)
| ";" -> SEMI region | "->" -> Ok (ARROW region)
| "|" -> VBAR region | "." -> Ok (DOT region)
| ":" -> COLON region | "_" -> Ok (WILD region)
| "." -> DOT region | "^" -> Ok (CAT region)
| "_" -> WILD region | "+" -> Ok (PLUS region)
| "=" -> EQ region | "-" -> Ok (MINUS region)
| "<>" -> NE region | "*" -> Ok (TIMES region)
| "<" -> LT region | "/" -> Ok (SLASH region)
| ">" -> GT region | "<" -> Ok (LT region)
| "=<" -> LE region | "<=" -> Ok (LE region)
| ">=" -> GE region | ">" -> Ok (GT region)
| "||" -> BOOL_OR region | ">=" -> Ok (GE region)
| "&&" -> BOOL_AND region
| "(" -> LPAR region
| ")" -> RPAR region | "<>" -> Ok (NE region)
| "::" -> Ok (CONS region)
| "||" -> Ok (BOOL_OR region)
| "&&" -> Ok (BOOL_AND region)
| a -> failwith ("Not understood token: " ^ a) | a -> failwith ("Not understood token: " ^ a)
(* Identifiers *) (* Identifiers *)

47
src/passes/1-parser/pascaligo/AST.ml
View File

@ -63,7 +63,6 @@ type kwd_not = Region.t
type kwd_of = Region.t type kwd_of = Region.t
type kwd_or = Region.t type kwd_or = Region.t
type kwd_patch = Region.t type kwd_patch = Region.t
type kwd_procedure = Region.t
type kwd_record = Region.t type kwd_record = Region.t
type kwd_remove = Region.t type kwd_remove = Region.t
type kwd_set = Region.t type kwd_set = Region.t
@ -163,7 +162,7 @@ and ast = t
and declaration = and declaration =
TypeDecl of type_decl reg TypeDecl of type_decl reg
| ConstDecl of const_decl reg | ConstDecl of const_decl reg
| LambdaDecl of lambda_decl | FunDecl of fun_decl reg
and const_decl = { and const_decl = {
kwd_const : kwd_const; kwd_const : kwd_const;
@ -188,7 +187,7 @@ and type_decl = {
and type_expr = and type_expr =
TProd of cartesian TProd of cartesian
| TSum of (variant reg, vbar) nsepseq reg | TSum of (variant reg, vbar) nsepseq reg
| TRecord of record_type | TRecord of field_decl reg injection reg
| TApp of (type_name * type_tuple) reg | TApp of (type_name * 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
@ -198,11 +197,9 @@ and cartesian = (type_expr, times) nsepseq reg
and variant = { and variant = {
constr : constr; constr : constr;
args : (kwd_of * cartesian) option args : (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;
@ -213,10 +210,6 @@ and type_tuple = (type_expr, comma) nsepseq par reg
(* Function and procedure declarations *) (* Function and procedure declarations *)
and lambda_decl =
FunDecl of fun_decl reg
| ProcDecl of proc_decl reg
and fun_decl = { and fun_decl = {
kwd_function : kwd_function; kwd_function : kwd_function;
name : variable; name : variable;
@ -231,16 +224,6 @@ and fun_decl = {
terminator : semi option terminator : semi option
} }
and proc_decl = {
kwd_procedure : kwd_procedure;
name : variable;
param : parameters;
kwd_is : kwd_is;
local_decls : local_decl list;
block : block reg;
terminator : semi option
}
and parameters = (param_decl, semi) nsepseq par reg and parameters = (param_decl, semi) nsepseq par reg
and param_decl = and param_decl =
@ -284,7 +267,6 @@ and statement =
and local_decl = and local_decl =
LocalFun of fun_decl reg LocalFun of fun_decl reg
| LocalProc of proc_decl reg
| LocalData of data_decl | LocalData of data_decl
and data_decl = and data_decl =
@ -425,10 +407,8 @@ and for_loop =
and for_int = { and for_int = {
kwd_for : kwd_for; kwd_for : kwd_for;
assign : var_assign reg; assign : var_assign reg;
down : kwd_down option;
kwd_to : kwd_to; kwd_to : kwd_to;
bound : expr; bound : expr;
step : (kwd_step * expr) option;
block : block reg block : block reg
} }
@ -442,11 +422,19 @@ and for_collect = {
kwd_for : kwd_for; kwd_for : kwd_for;
var : variable; var : variable;
bind_to : (arrow * variable) option; bind_to : (arrow * variable) option;
colon : colon;
elt_type : type_expr;
kwd_in : kwd_in; kwd_in : kwd_in;
collection : collection;
expr : expr; expr : expr;
block : block reg block : block reg
} }
and collection =
Map of kwd_map
| Set of kwd_set
| List of kwd_list
(* Expressions *) (* Expressions *)
and expr = and expr =
@ -577,16 +565,13 @@ and selection =
FieldName of field_name FieldName of field_name
| Component of (Lexer.lexeme * Z.t) reg | Component of (Lexer.lexeme * Z.t) reg
and tuple_expr = and tuple_expr = (expr, comma) nsepseq par reg
TupleInj of tuple_injection
and tuple_injection = (expr, comma) nsepseq par reg
and none_expr = c_None and none_expr = c_None
and fun_call = (fun_name * arguments) reg and fun_call = (fun_name * arguments) reg
and arguments = tuple_injection and arguments = tuple_expr
(* Patterns *) (* Patterns *)
@ -596,6 +581,7 @@ and pattern =
| PVar of Lexer.lexeme reg | PVar of Lexer.lexeme reg
| PWild of wild | PWild of wild
| PInt of (Lexer.lexeme * Z.t) reg | PInt of (Lexer.lexeme * Z.t) reg
| PNat of (Lexer.lexeme * Z.t) reg
| PBytes of (Lexer.lexeme * Hex.t) reg | PBytes of (Lexer.lexeme * Hex.t) reg
| PString of Lexer.lexeme reg | PString of Lexer.lexeme reg
| PUnit of c_Unit | PUnit of c_Unit
@ -645,8 +631,7 @@ let rec expr_to_region = function
| ECase {region;_} | ECase {region;_}
| EPar {region; _} -> region | EPar {region; _} -> region
and tuple_expr_to_region = function and tuple_expr_to_region {region; _} = region
TupleInj {region; _} -> region
and map_expr_to_region = function and map_expr_to_region = function
MapLookUp {region; _} MapLookUp {region; _}
@ -733,6 +718,7 @@ let pattern_to_region = function
| PVar {region; _} | PVar {region; _}
| PWild region | PWild region
| PInt {region; _} | PInt {region; _}
| PNat {region; _}
| PBytes {region; _} | PBytes {region; _}
| PString {region; _} | PString {region; _}
| PUnit region | PUnit region
@ -748,7 +734,6 @@ let pattern_to_region = function
let local_decl_to_region = function let local_decl_to_region = function
LocalFun {region; _} LocalFun {region; _}
| LocalProc {region; _}
| LocalData LocalConst {region; _} | LocalData LocalConst {region; _}
| LocalData LocalVar {region; _} -> region | LocalData LocalVar {region; _} -> region

46
src/passes/1-parser/pascaligo/AST.mli
View File

@ -47,7 +47,6 @@ type kwd_not = Region.t
type kwd_of = Region.t type kwd_of = Region.t
type kwd_or = Region.t type kwd_or = Region.t
type kwd_patch = Region.t type kwd_patch = Region.t
type kwd_procedure = Region.t
type kwd_record = Region.t type kwd_record = Region.t
type kwd_remove = Region.t type kwd_remove = Region.t
type kwd_set = Region.t type kwd_set = Region.t
@ -154,7 +153,7 @@ and ast = t
and declaration = and declaration =
TypeDecl of type_decl reg TypeDecl of type_decl reg
| ConstDecl of const_decl reg | ConstDecl of const_decl reg
| LambdaDecl of lambda_decl | FunDecl of fun_decl reg
and const_decl = { and const_decl = {
kwd_const : kwd_const; kwd_const : kwd_const;
@ -179,7 +178,7 @@ and type_decl = {
and type_expr = and type_expr =
TProd of cartesian TProd of cartesian
| TSum of (variant reg, vbar) nsepseq reg | TSum of (variant reg, vbar) nsepseq reg
| TRecord of record_type | TRecord of field_decl reg injection reg
| TApp of (type_name * type_tuple) reg | TApp of (type_name * 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
@ -189,11 +188,9 @@ and cartesian = (type_expr, times) nsepseq reg
and variant = { and variant = {
constr : constr; constr : constr;
args : (kwd_of * cartesian) option args : (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;
@ -202,11 +199,7 @@ and field_decl = {
and type_tuple = (type_expr, comma) nsepseq par reg and type_tuple = (type_expr, comma) nsepseq par reg
(* Function and procedure declarations *) (* Function declarations *)
and lambda_decl =
FunDecl of fun_decl reg
| ProcDecl of proc_decl reg
and fun_decl = { and fun_decl = {
kwd_function : kwd_function; kwd_function : kwd_function;
@ -222,16 +215,6 @@ and fun_decl = {
terminator : semi option terminator : semi option
} }
and proc_decl = {
kwd_procedure : kwd_procedure;
name : variable;
param : parameters;
kwd_is : kwd_is;
local_decls : local_decl list;
block : block reg;
terminator : semi option
}
and parameters = (param_decl, semi) nsepseq par reg and parameters = (param_decl, semi) nsepseq par reg
and param_decl = and param_decl =
@ -275,7 +258,6 @@ and statement =
and local_decl = and local_decl =
LocalFun of fun_decl reg LocalFun of fun_decl reg
| LocalProc of proc_decl reg
| LocalData of data_decl | LocalData of data_decl
and data_decl = and data_decl =
@ -416,10 +398,8 @@ and for_loop =
and for_int = { and for_int = {
kwd_for : kwd_for; kwd_for : kwd_for;
assign : var_assign reg; assign : var_assign reg;
down : kwd_down option;
kwd_to : kwd_to; kwd_to : kwd_to;
bound : expr; bound : expr;
step : (kwd_step * expr) option;
block : block reg block : block reg
} }
@ -433,15 +413,23 @@ and for_collect = {
kwd_for : kwd_for; kwd_for : kwd_for;
var : variable; var : variable;
bind_to : (arrow * variable) option; bind_to : (arrow * variable) option;
colon : colon;
elt_type : type_expr;
kwd_in : kwd_in; kwd_in : kwd_in;
collection : collection;
expr : expr; expr : expr;
block : block reg block : block reg
} }
and collection =
Map of kwd_map
| Set of kwd_set
| List of kwd_list
(* Expressions *) (* Expressions *)
and expr = and expr =
| ECase of expr case reg ECase of expr case reg
| EAnnot of annot_expr reg | EAnnot of annot_expr reg
| ELogic of logic_expr | ELogic of logic_expr
| EArith of arith_expr | EArith of arith_expr
@ -568,16 +556,13 @@ and selection =
FieldName of field_name FieldName of field_name
| Component of (Lexer.lexeme * Z.t) reg | Component of (Lexer.lexeme * Z.t) reg
and tuple_expr = and tuple_expr = (expr, comma) nsepseq par reg
TupleInj of tuple_injection
and tuple_injection = (expr, comma) nsepseq par reg
and none_expr = c_None and none_expr = c_None
and fun_call = (fun_name * arguments) reg and fun_call = (fun_name * arguments) reg
and arguments = tuple_injection and arguments = tuple_expr
(* Patterns *) (* Patterns *)
@ -587,6 +572,7 @@ and pattern =
| PVar of Lexer.lexeme reg | PVar of Lexer.lexeme reg
| PWild of wild | PWild of wild
| PInt of (Lexer.lexeme * Z.t) reg | PInt of (Lexer.lexeme * Z.t) reg
| PNat of (Lexer.lexeme * Z.t) reg
| PBytes of (Lexer.lexeme * Hex.t) reg | PBytes of (Lexer.lexeme * Hex.t) reg
| PString of Lexer.lexeme reg | PString of Lexer.lexeme reg
| PUnit of c_Unit | PUnit of c_Unit

23
src/passes/1-parser/pascaligo/Doc/pascaligo.md
View File

@ -332,15 +332,15 @@ There are three kinds of native numerical types in PascaLIGO: `int`,
other, for example `00` is invalid. Also, for the sake of convenience, other, for example `00` is invalid. Also, for the sake of convenience,
underscores are allowed in the literals, like `1_000_000`. underscores are allowed in the literals, like `1_000_000`.
* The second numerical type is the type of the natural numbers, * The second numerical type is the type of the natural numbers, e.g.,
e.g., `0n` or `13n`. Note that the `nat` literals must be annotated `0n` or `13n`. Note that the `nat` literals must be annotated with the
with the suffix `n`, which distinguishes them from `int` literals. The suffix `n`, which distinguishes them from `int` literals. The same
same convenient use of underscores as with integer literals is allowed convenient use of underscores as with integer literals is allowed too
too and the canonical form of zero is `0n`. and the canonical form of zero is `0n`.
* The last kind of native numerical type is `tez`, which is a unit * The last kind of native numerical type is `tez`, which is a unit of
of measure of the amounts (fees, accounts). Beware: the literals of measure of the amounts (fees, accounts). Beware: the literals of the
the type `tez` are annotated with the suffix `mtz`, which stands for type `tez` are annotated with the suffix `mtz`, which stands for
millionth of Tez, for instance, `0mtz` or `1200000mtz`. The same handy millionth of Tez, for instance, `0mtz` or `1200000mtz`. The same handy
use of underscores as in natural literals help in the writing, like use of underscores as in natural literals help in the writing, like
`1_200_000mtz`. `1_200_000mtz`.
@ -533,14 +533,13 @@ in terse style (see section "Predefined types and values/Lists").
Given a tuple `t` with _n_ components, the `i`th component is Given a tuple `t` with _n_ components, the `i`th component is
t.(i) t.i
where `t.(0)` is the first component. For example, given the where `t.0` is the first component. For example, given the declaration
declaration
const t : int * string = (4, "four") const t : int * string = (4, "four")
the expression `t.(1)` has the value `"four"`. the expression `t.1` has the value `"four"`.
#### Records #### Records

25
src/passes/1-parser/pascaligo/LexToken.mli
View File

@ -53,13 +53,13 @@ type t =
| VBAR of Region.t (* "|" *) | VBAR of Region.t (* "|" *)
| ARROW of Region.t (* "->" *) | ARROW of Region.t (* "->" *)
| ASS of Region.t (* ":=" *) | ASS of Region.t (* ":=" *)
| EQUAL of Region.t (* "=" *) | EQ of Region.t (* "=" *)
| COLON of Region.t (* ":" *) | COLON of Region.t (* ":" *)
| LT of Region.t (* "<" *) | LT of Region.t (* "<" *)
| LEQ of Region.t (* "<=" *) | LE of Region.t (* "<=" *)
| GT of Region.t (* ">" *) | GT of Region.t (* ">" *)
| GEQ of Region.t (* ">=" *) | GE of Region.t (* ">=" *)
| NEQ of Region.t (* "=/=" *) | NE of Region.t (* "=/=" *)
| PLUS of Region.t (* "+" *) | PLUS of Region.t (* "+" *)
| MINUS of Region.t (* "-" *) | MINUS of Region.t (* "-" *)
| SLASH of Region.t (* "/" *) | SLASH of Region.t (* "/" *)
@ -137,23 +137,20 @@ val to_region : token -> Region.t
(* Injections *) (* Injections *)
type int_err = type int_err = Non_canonical_zero
Non_canonical_zero
type ident_err = Reserved_name type ident_err = Reserved_name
type nat_err = Invalid_natural
type invalid_natural =
| Invalid_natural
| Non_canonical_zero_nat | Non_canonical_zero_nat
type sym_err = Invalid_symbol
val mk_string : lexeme -> Region.t -> token
val mk_bytes : lexeme -> Region.t -> token
val mk_int : lexeme -> Region.t -> (token, int_err) result val mk_int : lexeme -> Region.t -> (token, int_err) result
val mk_nat : lexeme -> Region.t -> (token, invalid_natural) result val mk_nat : lexeme -> Region.t -> (token, nat_err) result
val mk_mtz : lexeme -> Region.t -> (token, int_err) result val mk_mtz : lexeme -> Region.t -> (token, int_err) result
val mk_ident : lexeme -> Region.t -> (token, ident_err) result val mk_ident : lexeme -> Region.t -> (token, ident_err) result
val mk_sym : lexeme -> Region.t -> (token, sym_err) result
val mk_string : lexeme -> Region.t -> token
val mk_bytes : lexeme -> Region.t -> token
val mk_constr : lexeme -> Region.t -> token val mk_constr : lexeme -> Region.t -> token
val mk_sym : lexeme -> Region.t -> token
val eof : Region.t -> token val eof : Region.t -> token
(* Predicates *) (* Predicates *)

97
src/passes/1-parser/pascaligo/LexToken.mll
View File

@ -51,13 +51,13 @@ type t =
| VBAR of Region.t | VBAR of Region.t
| ARROW of Region.t | ARROW of Region.t
| ASS of Region.t | ASS of Region.t
| EQUAL of Region.t | EQ of Region.t
| COLON of Region.t | COLON of Region.t
| LT of Region.t | LT of Region.t
| LEQ of Region.t | LE of Region.t
| GT of Region.t | GT of Region.t
| GEQ of Region.t | GE of Region.t
| NEQ of Region.t | NE of Region.t
| PLUS of Region.t | PLUS of Region.t
| MINUS of Region.t | MINUS of Region.t
| SLASH of Region.t | SLASH of Region.t
@ -183,13 +183,13 @@ let proj_token = function
| VBAR region -> region, "VBAR" | VBAR region -> region, "VBAR"
| ARROW region -> region, "ARROW" | ARROW region -> region, "ARROW"
| ASS region -> region, "ASS" | ASS region -> region, "ASS"
| EQUAL region -> region, "EQUAL" | EQ region -> region, "EQ"
| COLON region -> region, "COLON" | COLON region -> region, "COLON"
| LT region -> region, "LT" | LT region -> region, "LT"
| LEQ region -> region, "LEQ" | LE region -> region, "LE"
| GT region -> region, "GT" | GT region -> region, "GT"
| GEQ region -> region, "GEQ" | GE region -> region, "GE"
| NEQ region -> region, "NEQ" | NE region -> region, "NE"
| PLUS region -> region, "PLUS" | PLUS region -> region, "PLUS"
| MINUS region -> region, "MINUS" | MINUS region -> region, "MINUS"
| SLASH region -> region, "SLASH" | SLASH region -> region, "SLASH"
@ -276,13 +276,13 @@ let to_lexeme = function
| VBAR _ -> "|" | VBAR _ -> "|"
| ARROW _ -> "->" | ARROW _ -> "->"
| ASS _ -> ":=" | ASS _ -> ":="
| EQUAL _ -> "=" | EQ _ -> "="
| COLON _ -> ":" | COLON _ -> ":"
| LT _ -> "<" | LT _ -> "<"
| LEQ _ -> "<=" | LE _ -> "<="
| GT _ -> ">" | GT _ -> ">"
| GEQ _ -> ">=" | GE _ -> ">="
| NEQ _ -> "=/=" | NE _ -> "=/="
| PLUS _ -> "+" | PLUS _ -> "+"
| MINUS _ -> "-" | MINUS _ -> "-"
| SLASH _ -> "/" | SLASH _ -> "/"
@ -480,8 +480,8 @@ let mk_int lexeme region =
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 invalid_natural = 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 =
@ -508,35 +508,42 @@ let mk_mtz lexeme region =
let eof region = EOF region let eof region = EOF region
type sym_err = Invalid_symbol
let mk_sym lexeme region = let mk_sym lexeme region =
match lexeme with match lexeme with
";" -> SEMI region (* Lexemes in common with all concrete syntaxes *)
| "," -> COMMA region ";" -> Ok (SEMI region)
| "(" -> LPAR region | "," -> Ok (COMMA region)
| ")" -> RPAR region | "(" -> Ok (LPAR region)
| "{" -> LBRACE region | ")" -> Ok (RPAR region)
| "}" -> RBRACE region | "[" -> Ok (LBRACKET region)
| "[" -> LBRACKET region | "]" -> Ok (RBRACKET region)
| "]" -> RBRACKET region | "{" -> Ok (LBRACE region)
| "#" -> CONS region | "}" -> Ok (RBRACE region)
| "|" -> VBAR region | "=" -> Ok (EQ region)
| "->" -> ARROW region | ":" -> Ok (COLON region)
| ":=" -> ASS region | "|" -> Ok (VBAR region)
| "=" -> EQUAL region | "->" -> Ok (ARROW region)
| ":" -> COLON region | "." -> Ok (DOT region)
| "<" -> LT region | "_" -> Ok (WILD region)
| "<=" -> LEQ region | "^" -> Ok (CAT region)
| ">" -> GT region | "+" -> Ok (PLUS region)
| ">=" -> GEQ region | "-" -> Ok (MINUS region)
| "=/=" -> NEQ region | "*" -> Ok (TIMES region)
| "+" -> PLUS region | "/" -> Ok (SLASH region)
| "-" -> MINUS region | "<" -> Ok (LT region)
| "/" -> SLASH region | "<=" -> Ok (LE region)
| "*" -> TIMES region | ">" -> Ok (GT region)
| "." -> DOT region | ">=" -> Ok (GE region)
| "_" -> WILD region
| "^" -> CAT region (* Lexemes specific to PascaLIGO *)
| _ -> assert false | "=/=" -> Ok (NE region)
| "#" -> Ok (CONS region)
| ":=" -> Ok (ASS region)
(* Invalid lexemes *)
| _ -> Error Invalid_symbol
(* Identifiers *) (* Identifiers *)
@ -632,13 +639,13 @@ let is_sym = function
| VBAR _ | VBAR _
| ARROW _ | ARROW _
| ASS _ | ASS _
| EQUAL _ | EQ _
| COLON _ | COLON _
| LT _ | LT _
| LEQ _ | LE _
| GT _ | GT _
| GEQ _ | GE _
| NEQ _ | NE _
| PLUS _ | PLUS _
| MINUS _ | MINUS _
| SLASH _ | SLASH _

11
src/passes/1-parser/pascaligo/ParToken.mly
View File

@ -27,13 +27,13 @@
%token <Region.t> VBAR (* "|" *) %token <Region.t> VBAR (* "|" *)
%token <Region.t> ARROW (* "->" *) %token <Region.t> ARROW (* "->" *)
%token <Region.t> ASS (* ":=" *) %token <Region.t> ASS (* ":=" *)
%token <Region.t> EQUAL (* "=" *) %token <Region.t> EQ (* "=" *)
%token <Region.t> COLON (* ":" *) %token <Region.t> COLON (* ":" *)
%token <Region.t> LT (* "<" *) %token <Region.t> LT (* "<" *)
%token <Region.t> LEQ (* "<=" *) %token <Region.t> LE (* "<=" *)
%token <Region.t> GT (* ">" *) %token <Region.t> GT (* ">" *)
%token <Region.t> GEQ (* ">=" *) %token <Region.t> GE (* ">=" *)
%token <Region.t> NEQ (* "=/=" *) %token <Region.t> NE (* "=/=" *)
%token <Region.t> PLUS (* "+" *) %token <Region.t> PLUS (* "+" *)
%token <Region.t> MINUS (* "-" *) %token <Region.t> MINUS (* "-" *)
%token <Region.t> SLASH (* "/" *) %token <Region.t> SLASH (* "/" *)
@ -51,7 +51,6 @@
%token <Region.t> Case (* "case" *) %token <Region.t> Case (* "case" *)
%token <Region.t> Const (* "const" *) %token <Region.t> Const (* "const" *)
%token <Region.t> Contains (* "contains" *) %token <Region.t> Contains (* "contains" *)
%token <Region.t> Down (* "down" *)
%token <Region.t> Else (* "else" *) %token <Region.t> Else (* "else" *)
%token <Region.t> End (* "end" *) %token <Region.t> End (* "end" *)
%token <Region.t> For (* "for" *) %token <Region.t> For (* "for" *)
@ -68,12 +67,10 @@
%token <Region.t> Of (* "of" *) %token <Region.t> Of (* "of" *)
%token <Region.t> Or (* "or" *) %token <Region.t> Or (* "or" *)
%token <Region.t> Patch (* "patch" *) %token <Region.t> Patch (* "patch" *)
%token <Region.t> Procedure (* "procedure" *)
%token <Region.t> Record (* "record" *) %token <Region.t> Record (* "record" *)
%token <Region.t> Remove (* "remove" *) %token <Region.t> Remove (* "remove" *)
%token <Region.t> Set (* "set" *) %token <Region.t> Set (* "set" *)
%token <Region.t> Skip (* "skip" *) %token <Region.t> Skip (* "skip" *)
%token <Region.t> Step (* "step" *)
%token <Region.t> Then (* "then" *) %token <Region.t> Then (* "then" *)
%token <Region.t> To (* "to" *) %token <Region.t> To (* "to" *)
%token <Region.t> Type (* "type" *) %token <Region.t> Type (* "type" *)

119
src/passes/1-parser/pascaligo/Parser.mly
View File

@ -116,7 +116,7 @@ contract:
declaration: declaration:
type_decl { TypeDecl $1 } type_decl { TypeDecl $1 }
| const_decl { ConstDecl $1 } | const_decl { ConstDecl $1 }
| lambda_decl { LambdaDecl $1 } | fun_decl { FunDecl $1 }
(* Type declarations *) (* Type declarations *)
@ -137,23 +137,27 @@ type_decl:
} }
type_expr: type_expr:
cartesian { TProd $1 } sum_type { TSum $1 }
| sum_type { TSum $1 }
| record_type { TRecord $1 } | record_type { TRecord $1 }
| cartesian { $1 }
cartesian: cartesian:
nsepseq(function_type,TIMES) { function_type TIMES nsepseq(function_type,TIMES) {
let region = nsepseq_to_region type_expr_to_region $1 let value = Utils.nsepseq_cons $1 $2 $3 in
in {region; value=$1}} let region = nsepseq_to_region type_expr_to_region value
in TProd {region; value}
}
| function_type { ($1 : type_expr) }
function_type: function_type:
core_type { core_type {
$1 $1
} }
| core_type ARROW function_type { | core_type ARROW function_type {
let region = cover (type_expr_to_region $1) let start = type_expr_to_region $1
(type_expr_to_region $3) and stop = type_expr_to_region $3 in
in TFun {region; value = ($1, $2, $3)} } let region = cover start stop in
TFun {region; value = $1,$2,$3} }
core_type: core_type:
type_name { type_name {
@ -200,7 +204,7 @@ sum_type:
variant: variant:
Constr Of cartesian { Constr Of cartesian {
let region = cover $1.region $3.region let region = cover $1.region (type_expr_to_region $3)
and value = {constr = $1; args = Some ($2, $3)} and value = {constr = $1; args = Some ($2, $3)}
in {region; value} in {region; value}
} }
@ -235,11 +239,7 @@ field_decl:
and value = {field_name = $1; colon = $2; field_type = $3} and value = {field_name = $1; colon = $2; field_type = $3}
in {region; value} } in {region; value} }
(* Function and procedure declarations *) (* Function declarations *)
lambda_decl:
fun_decl { FunDecl $1 }
| proc_decl { ProcDecl $1 }
fun_decl: fun_decl:
Function fun_name parameters COLON type_expr Is Function fun_name parameters COLON type_expr Is
@ -265,26 +265,6 @@ fun_decl:
terminator = $11} terminator = $11}
in {region; value}} in {region; value}}
proc_decl:
Procedure fun_name parameters Is
seq(local_decl)
block option(SEMI)
{
let stop =
match $7 with
Some region -> region
| None -> $6.region in
let region = cover $1 stop
and value = {
kwd_procedure = $1;
name = $2;
param = $3;
kwd_is = $4;
local_decls = $5;
block = $6;
terminator = $7}
in {region; value}}
parameters: parameters:
par(nsepseq(param_decl,SEMI)) { $1 } par(nsepseq(param_decl,SEMI)) { $1 }
@ -310,7 +290,7 @@ param_decl:
in ParamConst {region; value}} in ParamConst {region; value}}
param_type: param_type:
cartesian { TProd $1 } cartesian { $1 }
block: block:
Begin sep_or_term_list(statement,SEMI) End { Begin sep_or_term_list(statement,SEMI) End {
@ -342,7 +322,7 @@ open_data_decl:
| open_var_decl { LocalVar $1 } | open_var_decl { LocalVar $1 }
open_const_decl: open_const_decl:
Const unqualified_decl(EQUAL) { Const unqualified_decl(EQ) {
let name, colon, const_type, equal, init, stop = $2 in let name, colon, const_type, equal, init, stop = $2 in
let region = cover $1 stop let region = cover $1 stop
and value = { and value = {
@ -371,7 +351,6 @@ open_var_decl:
local_decl: local_decl:
fun_decl { LocalFun $1 } fun_decl { LocalFun $1 }
| proc_decl { LocalProc $1 }
| data_decl { LocalData $1 } | data_decl { LocalData $1 }
data_decl: data_decl:
@ -616,38 +595,42 @@ while_loop:
in While {region; value}} in While {region; value}}
for_loop: for_loop:
For var_assign Down? To expr option(step_clause) block { For var_assign To expr block {
let region = cover $1 $7.region in let region = cover $1 $5.region in
let value = { let value = {
kwd_for = $1; kwd_for = $1;
assign = $2; assign = $2;
down = $3; kwd_to = $3;
kwd_to = $4; bound = $4;
bound = $5; block = $5}
step = $6;
block = $7}
in For (ForInt {region; value}) in For (ForInt {region; value})
} }
| For var option(arrow_clause) In expr block { | For var option(arrow_clause) COLON type_expr
let region = cover $1 $6.region in In collection expr block {
let region = cover $1 $9.region in
let value = { let value = {
kwd_for = $1; kwd_for = $1;
var = $2; var = $2;
bind_to = $3; bind_to = $3;
kwd_in = $4; colon = $4;
expr = $5; elt_type = $5;
block = $6} kwd_in = $6;
collection = $7;
expr = $8;
block = $9}
in For (ForCollect {region; value})} in For (ForCollect {region; value})}
collection:
Map { Map $1 }
| Set { Set $1 }
| List { List $1 }
var_assign: var_assign:
var ASS expr { var ASS expr {
let region = cover $1.region (expr_to_region $3) let region = cover $1.region (expr_to_region $3)
and value = {name = $1; assign = $2; expr = $3} and value = {name = $1; assign = $2; expr = $3}
in {region; value}} in {region; value}}
step_clause:
Step expr { $1,$2 }
arrow_clause: arrow_clause:
ARROW var { $1,$2 } ARROW var { $1,$2 }
@ -701,7 +684,7 @@ comp_expr:
and value = {arg1 = $1; op = $2; arg2 = $3} and value = {arg1 = $1; op = $2; arg2 = $3}
in ELogic (CompExpr (Lt {region; value})) in ELogic (CompExpr (Lt {region; value}))
} }
| comp_expr LEQ cat_expr { | comp_expr LE cat_expr {
let start = expr_to_region $1 let start = expr_to_region $1
and stop = expr_to_region $3 in and stop = expr_to_region $3 in
let region = cover start stop let region = cover start stop
@ -715,21 +698,21 @@ comp_expr:
and value = {arg1 = $1; op = $2; arg2 = $3} and value = {arg1 = $1; op = $2; arg2 = $3}
in ELogic (CompExpr (Gt {region; value})) in ELogic (CompExpr (Gt {region; value}))
} }
| comp_expr GEQ cat_expr { | comp_expr GE cat_expr {
let start = expr_to_region $1 let start = expr_to_region $1
and stop = expr_to_region $3 in and stop = expr_to_region $3 in
let region = cover start stop let region = cover start stop
and value = {arg1 = $1; op = $2; arg2 = $3} and value = {arg1 = $1; op = $2; arg2 = $3}
in ELogic (CompExpr (Geq {region; value})) in ELogic (CompExpr (Geq {region; value}))
} }
| comp_expr EQUAL cat_expr { | comp_expr EQ cat_expr {
let start = expr_to_region $1 let start = expr_to_region $1
and stop = expr_to_region $3 in and stop = expr_to_region $3 in
let region = cover start stop let region = cover start stop
and value = {arg1 = $1; op = $2; arg2 = $3} and value = {arg1 = $1; op = $2; arg2 = $3}
in ELogic (CompExpr (Equal {region; value})) in ELogic (CompExpr (Equal {region; value}))
} }
| comp_expr NEQ cat_expr { | comp_expr NE cat_expr {
let start = expr_to_region $1 let start = expr_to_region $1
and stop = expr_to_region $3 in and stop = expr_to_region $3 in
let region = cover start stop let region = cover start stop
@ -826,6 +809,7 @@ core_expr:
| C_Unit { EUnit $1 } | C_Unit { EUnit $1 }
| annot_expr { EAnnot $1 } | annot_expr { EAnnot $1 }
| tuple_expr { ETuple $1 } | tuple_expr { ETuple $1 }
| par(expr) { EPar $1 }
| list_expr { EList $1 } | list_expr { EList $1 }
| C_None { EConstr (NoneExpr $1) } | C_None { EConstr (NoneExpr $1) }
| fun_call { ECall $1 } | fun_call { ECall $1 }
@ -906,7 +890,7 @@ record_expr:
in {region; value} } in {region; value} }
field_assignment: field_assignment:
field_name EQUAL expr { field_name EQ expr {
let region = cover $1.region (expr_to_region $3) let region = cover $1.region (expr_to_region $3)
and value = { and value = {
field_name = $1; field_name = $1;
@ -920,13 +904,14 @@ fun_call:
in {region; value = $1,$2}} in {region; value = $1,$2}}
tuple_expr: tuple_expr:
tuple_inj { TupleInj $1 } par(tuple_comp) { $1 }
tuple_inj: tuple_comp:
par(nsepseq(expr,COMMA)) { $1 } expr COMMA nsepseq(expr,COMMA) {
Utils.nsepseq_cons $1 $2 $3}
arguments: arguments:
tuple_inj { $1 } par(nsepseq(expr,COMMA)) { $1 }
list_expr: list_expr:
injection(List,expr) { List $1 } injection(List,expr) { List $1 }
@ -935,14 +920,18 @@ list_expr:
(* Patterns *) (* Patterns *)
pattern: pattern:
nsepseq(core_pattern,CONS) { core_pattern CONS nsepseq(core_pattern,CONS) {
let region = nsepseq_to_region pattern_to_region $1 let value = Utils.nsepseq_cons $1 $2 $3 in
in PCons {region; value=$1}} let region = nsepseq_to_region pattern_to_region value
in PCons {region; value}}
| core_pattern { $1 }
core_pattern: core_pattern:
var { PVar $1 } var { PVar $1 }
| WILD { PWild $1 } | WILD { PWild $1 }
| Int { PInt $1 } | Int { PInt $1 }
| Nat { PNat $1 }
| Bytes { PBytes $1 }
| String { PString $1 } | String { PString $1 }
| C_Unit { PUnit $1 } | C_Unit { PUnit $1 }
| C_False { PFalse $1 } | C_False { PFalse $1 }

778
src/passes/1-parser/pascaligo/ParserLog.ml
View File

@ -62,6 +62,11 @@ let print_int buffer {region; value = lexeme, abstract} =
(Z.to_string abstract) (Z.to_string abstract)
in Buffer.add_string buffer line in Buffer.add_string buffer 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
(* Main printing function *) (* Main printing function *)
@ -73,7 +78,7 @@ let rec print_tokens buffer ast =
and print_decl buffer = function and print_decl buffer = function
TypeDecl decl -> print_type_decl buffer decl TypeDecl decl -> print_type_decl buffer decl
| ConstDecl decl -> print_const_decl buffer decl | ConstDecl decl -> print_const_decl buffer decl
| LambdaDecl decl -> print_lambda_decl buffer decl | FunDecl decl -> print_fun_decl buffer decl
and print_const_decl buffer {value; _} = and print_const_decl buffer {value; _} =
let {kwd_const; name; colon; const_type; let {kwd_const; name; colon; const_type;
@ -107,14 +112,14 @@ and print_type_expr buffer = function
and print_cartesian buffer {value; _} = and print_cartesian buffer {value; _} =
print_nsepseq buffer "*" print_type_expr value print_nsepseq buffer "*" print_type_expr value
and print_variant buffer {value; _} = and print_variant buffer ({value; _}: variant reg) =
let {constr; args} = value in let {constr; args} = value in
print_constr buffer constr; print_constr buffer constr;
match args with match args with
None -> () None -> ()
| Some (kwd_of, product) -> | Some (kwd_of, t_expr) ->
print_token buffer kwd_of "of"; print_token buffer kwd_of "of";
print_cartesian buffer product print_type_expr buffer t_expr
and print_sum_type buffer {value; _} = and print_sum_type buffer {value; _} =
print_nsepseq buffer "|" print_variant value print_nsepseq buffer "|" print_variant value
@ -151,10 +156,6 @@ and print_type_tuple buffer {value; _} =
print_nsepseq buffer "," print_type_expr inside; print_nsepseq buffer "," print_type_expr inside;
print_token buffer rpar ")" print_token buffer rpar ")"
and print_lambda_decl buffer = function
FunDecl fun_decl -> print_fun_decl buffer fun_decl
| ProcDecl proc_decl -> print_proc_decl buffer proc_decl
and print_fun_decl buffer {value; _} = and print_fun_decl buffer {value; _} =
let {kwd_function; name; param; colon; let {kwd_function; name; param; colon;
ret_type; kwd_is; local_decls; ret_type; kwd_is; local_decls;
@ -171,17 +172,6 @@ and print_fun_decl buffer {value; _} =
print_expr buffer return; print_expr buffer return;
print_terminator buffer terminator print_terminator buffer terminator
and print_proc_decl buffer {value; _} =
let {kwd_procedure; name; param; kwd_is;
local_decls; block; terminator} = value in
print_token buffer kwd_procedure "procedure";
print_var buffer name;
print_parameters buffer param;
print_token buffer kwd_is "is";
print_local_decls buffer local_decls;
print_block buffer block;
print_terminator buffer terminator
and print_parameters buffer {value; _} = and print_parameters buffer {value; _} =
let {lpar; inside; rpar} = value in let {lpar; inside; rpar} = value in
print_token buffer lpar "("; print_token buffer lpar "(";
@ -229,7 +219,6 @@ and print_local_decls buffer sequence =
and print_local_decl buffer = function and print_local_decl buffer = function
LocalFun decl -> print_fun_decl buffer decl LocalFun decl -> print_fun_decl buffer decl
| LocalProc decl -> print_proc_decl buffer decl
| LocalData decl -> print_data_decl buffer decl | LocalData decl -> print_data_decl buffer decl
and print_data_decl buffer = function and print_data_decl buffer = function
@ -342,14 +331,11 @@ and print_for_loop buffer = function
| ForCollect for_collect -> print_for_collect buffer for_collect | ForCollect for_collect -> print_for_collect buffer for_collect
and print_for_int buffer ({value; _} : for_int reg) = and print_for_int buffer ({value; _} : for_int reg) =
let {kwd_for; assign; down; kwd_to; let {kwd_for; assign; kwd_to; bound; block} = value in
bound; step; block} = value in
print_token buffer kwd_for "for"; print_token buffer kwd_for "for";
print_var_assign buffer assign; print_var_assign buffer assign;
print_down buffer down;
print_token buffer kwd_to "to"; print_token buffer kwd_to "to";
print_expr buffer bound; print_expr buffer bound;
print_step buffer step;
print_block buffer block print_block buffer block
and print_var_assign buffer {value; _} = and print_var_assign buffer {value; _} =
@ -358,25 +344,27 @@ and print_var_assign buffer {value; _} =
print_token buffer assign ":="; print_token buffer assign ":=";
print_expr buffer expr print_expr buffer expr
and print_down buffer = function
Some kwd_down -> print_token buffer kwd_down "down"
| None -> ()
and print_step buffer = function
Some (kwd_step, expr) ->
print_token buffer kwd_step "step";
print_expr buffer expr
| None -> ()
and print_for_collect buffer ({value; _} : for_collect reg) = and print_for_collect buffer ({value; _} : for_collect reg) =
let {kwd_for; var; bind_to; kwd_in; expr; block} = value in let {kwd_for; var; bind_to; colon; elt_type;
kwd_in; collection; expr; block} = value in
print_token buffer kwd_for "for"; print_token buffer kwd_for "for";
print_var buffer var; print_var buffer var;
print_bind_to buffer bind_to; print_bind_to buffer bind_to;
print_token buffer colon ":";
print_type_expr buffer elt_type;
print_token buffer kwd_in "in"; print_token buffer kwd_in "in";
print_collection buffer collection;
print_expr buffer expr; print_expr buffer expr;
print_block buffer block print_block buffer block
and print_collection buffer = function
Map kwd_map ->
print_token buffer kwd_map "map"
| Set kwd_set ->
print_token buffer kwd_set "set"
| List kwd_list ->
print_token buffer kwd_list "list"
and print_bind_to buffer = function and print_bind_to buffer = function
Some (arrow, variable) -> Some (arrow, variable) ->
print_token buffer arrow "->"; print_token buffer arrow "->";
@ -632,10 +620,7 @@ and print_binding buffer {value; _} =
print_token buffer arrow "->"; print_token buffer arrow "->";
print_expr buffer image print_expr buffer image
and print_tuple_expr buffer = function and print_tuple_expr buffer {value; _} =
TupleInj inj -> print_tuple_inj buffer inj
and print_tuple_inj buffer {value; _} =
let {lpar; inside; rpar} = value in let {lpar; inside; rpar} = value in
print_token buffer lpar "("; print_token buffer lpar "(";
print_nsepseq buffer "," print_expr inside; print_nsepseq buffer "," print_expr inside;
@ -648,19 +633,19 @@ and print_none_expr buffer value = print_token buffer value "None"
and print_fun_call buffer {value; _} = and print_fun_call buffer {value; _} =
let fun_name, arguments = value in let fun_name, arguments = value in
print_var buffer fun_name; print_var buffer fun_name;
print_tuple_inj buffer arguments print_tuple_expr buffer arguments
and print_constr_app buffer {value; _} = and print_constr_app buffer {value; _} =
let constr, arguments = value in let constr, arguments = value in
print_constr buffer constr; print_constr buffer constr;
match arguments with match arguments with
None -> () None -> ()
| Some args -> print_tuple_inj buffer args | Some args -> print_tuple_expr buffer args
and print_some_app buffer {value; _} = and print_some_app buffer {value; _} =
let c_Some, arguments = value in let c_Some, arguments = value in
print_token buffer c_Some "Some"; print_token buffer c_Some "Some";
print_tuple_inj buffer arguments print_tuple_expr buffer arguments
and print_par_expr buffer {value; _} = and print_par_expr buffer {value; _} =
let {lpar; inside; rpar} = value in let {lpar; inside; rpar} = value in
@ -673,6 +658,7 @@ and print_pattern buffer = function
| PVar var -> print_var buffer var | PVar var -> print_var buffer var
| PWild wild -> print_token buffer wild "_" | PWild wild -> print_token buffer wild "_"
| PInt i -> print_int buffer i | PInt i -> print_int buffer i
| PNat n -> print_nat buffer n
| PBytes b -> print_bytes buffer b | PBytes b -> print_bytes buffer b
| PString s -> print_string buffer s | PString s -> print_string buffer s
| PUnit region -> print_token buffer region "Unit" | PUnit region -> print_token buffer region "Unit"
@ -740,3 +726,711 @@ let tokens_to_string = to_string print_tokens
let path_to_string = to_string print_path let path_to_string = to_string print_path
let pattern_to_string = to_string print_pattern let pattern_to_string = to_string print_pattern
let instruction_to_string = to_string print_instruction let instruction_to_string = to_string print_instruction
(* 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,_) name =
let node = sprintf "%s%s\n" pd name
in Buffer.add_string buffer node
let pp_string buffer = pp_ident buffer
let pp_node buffer = pp_ident buffer
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:(_,pc as pad) = function
TypeDecl {value; _} ->
pp_node buffer ~pad "TypeDecl";
pp_ident buffer ~pad:(mk_pad 2 0 pc) value.name.value;
pp_type_expr buffer ~pad:(mk_pad 2 1 pc) value.type_expr
| ConstDecl {value; _} ->
pp_node buffer ~pad "ConstDecl";
pp_const_decl buffer ~pad:(mk_pad 1 0 pc) value
| FunDecl {value; _} ->
pp_node buffer ~pad "FunDecl";
pp_fun_decl buffer ~pad:(mk_pad 1 0 pc) value
and pp_const_decl buffer ~pad:(_,pc) decl =
pp_ident buffer ~pad:(mk_pad 3 0 pc) decl.name.value;
pp_type_expr buffer ~pad:(mk_pad 3 1 pc) decl.const_type;
pp_expr buffer ~pad:(mk_pad 3 2 pc) decl.init
and pp_type_expr buffer ~pad:(_,pc as pad) = function
TProd cartesian ->
pp_node buffer ~pad "TProd";
pp_cartesian buffer ~pad cartesian
| TAlias {value; _} ->
pp_node buffer ~pad "TAlias";
pp_ident buffer ~pad:(mk_pad 1 0 pc) value
| TPar {value; _} ->
pp_node buffer ~pad "TPar";
pp_type_expr buffer ~pad:(mk_pad 1 0 pc) value.inside
| TApp {value=name,tuple; _} ->
pp_node buffer ~pad "TApp";
pp_ident buffer ~pad:(mk_pad 1 0 pc) name.value;
pp_type_tuple buffer ~pad:(mk_pad 2 1 pc) tuple
| TFun {value; _} ->
pp_node buffer ~pad "TFun";
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]
| TSum {value; _} ->
pp_node buffer ~pad "TSum";
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; _} ->
pp_node buffer ~pad "TRecord";
let apply len rank field_decl =
pp_field_decl buffer ~pad:(mk_pad len rank pc)
field_decl.value in
let fields = Utils.sepseq_to_list value.elements in
List.iteri (List.length fields |> apply) fields
and pp_cartesian buffer ~pad:(_,pc) {value; _} =
let apply len rank =
pp_type_expr buffer ~pad:(mk_pad len rank pc) in
let components = Utils.nsepseq_to_list value
in List.iteri (List.length components |> apply) components
and pp_variant buffer ~pad:(_,pc as pad) {constr; args} =
pp_node buffer ~pad constr.value;
match args with
None -> ()
| Some (_,c) ->
pp_type_expr buffer ~pad:(mk_pad 1 0 pc) c
and pp_field_decl buffer ~pad:(_,pc as pad) decl =
pp_node buffer ~pad decl.field_name.value;
pp_type_expr buffer ~pad:(mk_pad 1 0 pc) decl.field_type
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_fun_decl buffer ~pad:(_,pc) decl =
let () =
let pad = mk_pad 6 0 pc in
pp_ident buffer ~pad decl.name.value in
let () =
let pad = mk_pad 6 1 pc in
pp_node buffer ~pad "<parameters>";
pp_parameters buffer ~pad decl.param in
let () =
let _, pc as pad = mk_pad 6 2 pc in
pp_node buffer ~pad "<return type>";
pp_type_expr buffer ~pad:(mk_pad 1 0 pc) decl.ret_type in
let () =
let pad = mk_pad 6 3 pc in
pp_node buffer ~pad "<local declarations>";
pp_local_decls buffer ~pad decl.local_decls in
let () =
let pad = mk_pad 6 4 pc in
pp_node buffer ~pad "<block>";
let statements = decl.block.value.statements in
pp_statements buffer ~pad statements in
let () =
let _, pc as pad = mk_pad 6 5 pc in
pp_node buffer ~pad "<return>";
pp_expr buffer ~pad:(mk_pad 1 0 pc) decl.return
in ()
and pp_parameters buffer ~pad:(_,pc) {value; _} =
let params = Utils.nsepseq_to_list value.inside in
let arity = List.length params in
let apply len rank =
pp_param_decl buffer ~pad:(mk_pad len rank pc)
in List.iteri (apply arity) params
and pp_param_decl buffer ~pad:(_,pc as pad) = function
ParamConst {value; _} ->
pp_node buffer ~pad "ParamConst";
pp_ident buffer ~pad:(mk_pad 2 0 pc) value.var.value;
pp_type_expr buffer ~pad:(mk_pad 2 1 pc) value.param_type
| ParamVar {value; _} ->
pp_node buffer ~pad "ParamVar";
pp_ident buffer ~pad:(mk_pad 2 0 pc) value.var.value;
pp_type_expr buffer ~pad:(mk_pad 2 1 pc) value.param_type
and pp_statements buffer ~pad:(_,pc) statements =
let statements = Utils.nsepseq_to_list statements in
let length = List.length statements in
let apply len rank =
pp_statement buffer ~pad:(mk_pad len rank pc)
in List.iteri (apply length) statements
and pp_statement buffer ~pad:(_,pc as pad) = function
Instr instr ->
pp_node buffer ~pad "Instr";
pp_instruction buffer ~pad:(mk_pad 1 0 pc) instr
| Data data_decl ->
pp_node buffer ~pad "Data";
pp_data_decl buffer ~pad:(mk_pad 1 0 pc) data_decl
and pp_instruction buffer ~pad:(_,pc as pad) = function
Single single_instr ->
pp_node buffer ~pad "Single";
pp_single_instr buffer ~pad:(mk_pad 1 0 pc) single_instr
| Block {value; _} ->
pp_node buffer ~pad "Block";
pp_statements buffer ~pad value.statements
and pp_single_instr buffer ~pad:(_,pc as pad) = function
Cond {value; _} ->
pp_node buffer ~pad "Cond";
pp_conditional buffer ~pad value
| CaseInstr {value; _} ->
pp_node buffer ~pad "CaseInstr";
pp_case pp_instruction buffer ~pad value
| Assign {value; _} ->
pp_node buffer ~pad "Assign";
pp_assignment buffer ~pad value
| Loop loop ->
pp_node buffer ~pad "Loop";
pp_loop buffer ~pad:(mk_pad 1 0 pc) loop
| ProcCall {value; _} ->
pp_node buffer ~pad "ProcCall";
pp_fun_call buffer ~pad value
| Skip _ ->
pp_node buffer ~pad "Skip"
| RecordPatch {value; _} ->
pp_node buffer ~pad "RecordPatch";
pp_record_patch buffer ~pad value
| MapPatch {value; _} ->
pp_node buffer ~pad "MapPatch";
pp_map_patch buffer ~pad value
| SetPatch {value; _} ->
pp_node buffer ~pad "SetPatch";
pp_set_patch buffer ~pad value
| MapRemove {value; _} ->
pp_node buffer ~pad "MapRemove";
pp_map_remove buffer ~pad value
| SetRemove {value; _} ->
pp_node buffer ~pad "SetRemove";
pp_set_remove buffer ~pad value
and pp_conditional buffer ~pad:(_,pc) cond =
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_if_clause 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_if_clause buffer ~pad:(mk_pad 1 0 pc) cond.ifnot
in ()
and pp_if_clause buffer ~pad:(_,pc as pad) = function
ClauseInstr instr ->
pp_node buffer ~pad "ClauseInstr";
pp_instruction buffer ~pad:(mk_pad 1 0 pc) instr
| ClauseBlock {value; _} ->
pp_node buffer ~pad "ClauseBlock";
let statements, _ = value.inside in
pp_statements buffer ~pad statements
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_pattern buffer ~pad:(_,pc as pad) = function
PNone _ ->
pp_node buffer ~pad "PNone"
| PSome {value=_,{value=par; _}; _} ->
pp_node buffer ~pad "PSome";
pp_pattern buffer ~pad:(mk_pad 1 0 pc) par.inside
| PWild _ ->
pp_node buffer ~pad "PWild"
| PConstr {value; _} ->
pp_node buffer ~pad "PConstr";
pp_constr_pattern buffer ~pad:(mk_pad 1 0 pc) value
| PCons {value; _} ->
let patterns = Utils.nsepseq_to_list value in
let length = List.length patterns in
let apply len rank =
pp_pattern buffer ~pad:(mk_pad len rank pc) in
pp_node buffer ~pad "PCons";
List.iteri (apply length) patterns
| PVar {value; _} ->
pp_node buffer ~pad "PVar";
pp_ident buffer ~pad:(mk_pad 1 0 pc) value
| PInt {value; _} ->
pp_node buffer ~pad "PInt";
pp_int buffer ~pad value
| PNat {value; _} ->
pp_node buffer ~pad "PNat";
pp_int buffer ~pad value
| PBytes {value; _} ->
pp_node buffer ~pad "PBytes";
pp_bytes buffer ~pad value
| PString {value; _} ->
pp_node buffer ~pad "PString";
pp_ident buffer ~pad:(mk_pad 1 0 pc) value
| PUnit _ ->
pp_node buffer ~pad "PUnit"
| PFalse _ ->
pp_node buffer ~pad "PFalse"
| PTrue _ ->
pp_node buffer ~pad "PTrue"
| PList plist ->
pp_node buffer ~pad "PList";
pp_plist buffer ~pad:(mk_pad 1 0 pc) plist
| PTuple {value; _} ->
pp_node buffer ~pad "PTuple";
pp_tuple_pattern buffer ~pad:(mk_pad 1 0 pc) value
and pp_bytes buffer ~pad:(_,pc) (lexeme, hex) =
pp_string buffer ~pad:(mk_pad 2 0 pc) lexeme;
pp_string buffer ~pad:(mk_pad 2 1 pc) (Hex.to_string hex)
and pp_int buffer ~pad:(_,pc) (lexeme, z) =
pp_string buffer ~pad:(mk_pad 2 0 pc) lexeme;
pp_string buffer ~pad:(mk_pad 2 1 pc) (Z.to_string z)
and pp_constr_pattern buffer ~pad = function
{value; _}, None ->
pp_ident buffer ~pad value
| {value=id; _}, Some {value=ptuple; _} ->
pp_ident buffer ~pad id;
pp_tuple_pattern buffer ~pad ptuple
and pp_plist buffer ~pad:(_,pc as pad) = function
Sugar {value; _} ->
pp_node buffer ~pad "Sugar";
pp_injection pp_pattern buffer ~pad:(mk_pad 1 0 pc) value
| PNil _ ->
pp_node buffer ~pad "PNil"
| Raw {value; _} ->
pp_node buffer ~pad "Raw";
pp_raw buffer ~pad:(mk_pad 1 0 pc) value.inside
and pp_raw buffer ~pad:(_,pc) (head, _, tail) =
pp_pattern buffer ~pad:(mk_pad 2 0 pc) head;
pp_pattern buffer ~pad:(mk_pad 2 1 pc) tail
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_tuple_pattern buffer ~pad:(_,pc) tuple =
let patterns = Utils.nsepseq_to_list tuple.inside 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_assignment buffer ~pad:(_,pc) asgn =
pp_lhs buffer ~pad:(mk_pad 2 0 pc) asgn.lhs;
pp_expr buffer ~pad:(mk_pad 2 1 pc) asgn.rhs
and pp_lhs buffer ~pad:(_,pc as pad) = function
Path path ->
pp_node buffer ~pad "Path";
pp_path buffer ~pad:(mk_pad 1 0 pc) path
| MapPath {value; _} ->
pp_node buffer ~pad "MapPath";
pp_map_lookup buffer ~pad value
and pp_path buffer ~pad:(_,pc as pad) = function
Name {value; _} ->
pp_node buffer ~pad "Name";
pp_ident buffer ~pad:(mk_pad 1 0 pc) value
| Path {value; _} ->
pp_node buffer ~pad "Path";
pp_projection buffer ~pad value
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.value;
List.iteri (apply len) selections
and pp_selection buffer ~pad:(_,pc as pad) = function
FieldName {value; _} ->
pp_node buffer ~pad "FieldName";
pp_ident buffer ~pad:(mk_pad 1 0 pc) value
| Component {value; _} ->
pp_node buffer ~pad "Component";
pp_int buffer ~pad value
and pp_map_lookup buffer ~pad:(_,pc) lookup =
pp_path buffer ~pad:(mk_pad 2 0 pc) lookup.path;
pp_expr buffer ~pad:(mk_pad 2 1 pc) lookup.index.value.inside
and pp_loop buffer ~pad:(_,pc as pad) = function
While {value; _} ->
pp_node buffer ~pad "<while>";
let () =
let _, pc as pad = mk_pad 2 0 pc in
pp_node buffer ~pad "<condition>";
pp_expr buffer ~pad:(mk_pad 1 0 pc) value.cond in
let () =
let pad = mk_pad 2 1 pc in
let statements = value.block.value.statements in
pp_node buffer ~pad "<statements>";
pp_statements buffer ~pad statements
in ()
| For for_loop ->
pp_node buffer ~pad "<for>";
pp_for_loop buffer ~pad:(mk_pad 1 0 pc) for_loop
and pp_for_loop buffer ~pad = function
ForInt {value; _} ->
pp_node buffer ~pad "ForInt";
pp_for_int buffer ~pad value
| ForCollect {value; _} ->
pp_node buffer ~pad "ForCollect";
pp_for_collect buffer ~pad value
and pp_for_int buffer ~pad:(_,pc) for_int =
let () =
let pad = mk_pad 3 0 pc in
pp_node buffer ~pad "<init>";
pp_var_assign buffer ~pad for_int.assign.value in
let () =
let _, pc as pad = mk_pad 3 1 pc in
pp_node buffer ~pad "<bound>";
pp_expr buffer ~pad:(mk_pad 1 0 pc) for_int.bound in
let () =
let pad = mk_pad 3 2 pc in
let statements = for_int.block.value.statements in
pp_node buffer ~pad "<statements>";
pp_statements buffer ~pad statements
in ()
and pp_var_assign buffer ~pad:(_,pc) asgn =
let pad = mk_pad 2 0 pc in
pp_ident buffer ~pad asgn.name.value;
let pad = mk_pad 2 1 pc in
pp_expr buffer ~pad asgn.expr
and pp_for_collect buffer ~pad:(_,pc) collect =
let () =
let pad = mk_pad 4 0 pc in
match collect.bind_to with
None ->
pp_ident buffer ~pad collect.var.value
| Some (_, var) ->
pp_var_binding buffer ~pad (collect.var, var) in
let () =
let _, pc as pad = mk_pad 4 1 pc in
pp_node buffer ~pad "<element type>";
pp_type_expr buffer ~pad:(mk_pad 1 0 pc) collect.elt_type in
let () =
let _, pc as pad = mk_pad 4 2 pc in
pp_node buffer ~pad "<collection>";
pp_collection buffer ~pad:(mk_pad 2 0 pc) collect.collection;
pp_expr buffer ~pad:(mk_pad 1 0 pc) collect.expr in
let () =
let pad = mk_pad 4 3 pc in
let statements = collect.block.value.statements in
pp_node buffer ~pad "<statements>";
pp_statements buffer ~pad statements
in ()
and pp_collection buffer ~pad = function
Map _ -> pp_string buffer ~pad "map"
| Set _ -> pp_string buffer ~pad "set"
| List _ -> pp_string buffer ~pad "list"
and pp_var_binding buffer ~pad:(_,pc as pad) (source, image) =
pp_node buffer ~pad "<binding>";
pp_ident buffer ~pad:(mk_pad 2 0 pc) source.value;
pp_ident buffer ~pad:(mk_pad 2 1 pc) image.value
and pp_fun_call buffer ~pad:(_,pc) (name, args) =
let args = Utils.nsepseq_to_list args.value.inside in
let arity = List.length args in
let apply len rank =
pp_expr buffer ~pad:(mk_pad len rank pc)
in pp_ident buffer ~pad:(mk_pad (1+arity) 0 pc) name.value;
List.iteri (apply arity) args
and pp_record_patch buffer ~pad:(_,pc as pad) patch =
pp_path buffer ~pad:(mk_pad 2 0 pc) patch.path;
pp_injection pp_field_assign buffer
~pad patch.record_inj.value
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.value;
pp_expr buffer ~pad:(mk_pad 2 1 pc) value.field_expr
and pp_map_patch buffer ~pad:(_,pc as pad) patch =
pp_path buffer ~pad:(mk_pad 2 0 pc) patch.path;
pp_injection pp_binding buffer
~pad patch.map_inj.value
and pp_binding buffer ~pad:(_,pc as pad) {value; _} =
let source, image = value.source, value.image in
pp_node buffer ~pad "<binding>";
pp_expr buffer ~pad:(mk_pad 2 0 pc) source;
pp_expr buffer ~pad:(mk_pad 2 1 pc) image
and pp_set_patch buffer ~pad:(_,pc as pad) patch =
pp_path buffer ~pad:(mk_pad 2 0 pc) patch.path;
pp_injection pp_expr buffer ~pad patch.set_inj.value
and pp_map_remove buffer ~pad:(_,pc) rem =
pp_expr buffer ~pad:(mk_pad 2 0 pc) rem.key;
pp_path buffer ~pad:(mk_pad 2 1 pc) rem.map
and pp_set_remove buffer ~pad:(_,pc) rem =
pp_expr buffer ~pad:(mk_pad 2 0 pc) rem.element;
pp_path buffer ~pad:(mk_pad 2 1 pc) rem.set
and pp_local_decls buffer ~pad:(_,pc) decls =
let apply len rank =
pp_local_decl buffer ~pad:(mk_pad len rank pc)
in List.iteri (List.length decls |> apply) decls
and pp_local_decl buffer ~pad:(_,pc as pad) = function
LocalFun {value; _} ->
pp_node buffer ~pad "LocalFun";
pp_fun_decl buffer ~pad:(mk_pad 1 0 pc) value
| LocalData data ->
pp_node buffer ~pad "LocalData";
pp_data_decl buffer ~pad:(mk_pad 1 0 pc) data
and pp_data_decl buffer ~pad = function
LocalConst {value; _} ->
pp_node buffer ~pad "LocalConst";
pp_const_decl buffer ~pad value
| LocalVar {value; _} ->
pp_node buffer ~pad "LocalVar";
pp_var_decl buffer ~pad value
and pp_var_decl buffer ~pad:(_,pc) decl =
pp_ident buffer ~pad:(mk_pad 3 0 pc) decl.name.value;
pp_type_expr buffer ~pad:(mk_pad 3 1 pc) decl.var_type;
pp_expr buffer ~pad:(mk_pad 3 2 pc) decl.init
and pp_expr buffer ~pad:(_,pc as pad) = function
ECase {value; _} ->
pp_node buffer ~pad "ECase";
pp_case pp_expr buffer ~pad value
| EAnnot {value; _} ->
pp_node buffer ~pad "EAnnot";
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
| ESet e_set ->
pp_node buffer ~pad "ESet";
pp_set_expr buffer ~pad:(mk_pad 1 0 pc) e_set
| EConstr e_constr ->
pp_node buffer ~pad "EConstr";
pp_constr_expr buffer ~pad:(mk_pad 1 0 pc) e_constr
| ERecord {value; _} ->
pp_node buffer ~pad "ERecord";
pp_injection pp_field_assign buffer ~pad value
| EProj {value; _} ->
pp_node buffer ~pad "EProj";
pp_projection buffer ~pad value
| EMap e_map ->
pp_node buffer ~pad "EMap";
pp_map_expr buffer ~pad:(mk_pad 1 0 pc) e_map
| EVar {value; _} ->
pp_node buffer ~pad "EVar";
pp_ident buffer ~pad:(mk_pad 1 0 pc) value
| ECall {value; _} ->
pp_node buffer ~pad "ECall";
pp_fun_call buffer ~pad value
| EBytes {value; _} ->
pp_node buffer ~pad "EBytes";
pp_bytes buffer ~pad value
| EUnit _ ->
pp_node buffer ~pad "EUnit"
| ETuple e_tuple ->
pp_node buffer ~pad "ETuple";
pp_tuple_expr buffer ~pad e_tuple
| EPar {value; _} ->
pp_node buffer ~pad "EPar";
pp_expr buffer ~pad:(mk_pad 1 0 pc) value.inside
and pp_list_expr buffer ~pad:(_,pc as pad) = function
Cons {value; _} ->
pp_node buffer ~pad "Cons";
pp_expr buffer ~pad:(mk_pad 2 0 pc) value.arg1;
pp_expr buffer ~pad:(mk_pad 2 1 pc) value.arg2
| List {value; _} ->
pp_node buffer ~pad "List";
pp_injection pp_expr buffer ~pad value
| Nil _ ->
pp_node buffer ~pad "Nil"
and pp_arith_expr buffer ~pad:(_,pc as pad) = function
Add {value; _} ->
pp_bin_op "Add" buffer ~pad value
| Sub {value; _} ->
pp_bin_op "Sub" buffer ~pad value
| Mult {value; _} ->
pp_bin_op "Mult" buffer ~pad value
| Div {value; _} ->
pp_bin_op "Div" buffer ~pad value
| Mod {value; _} ->
pp_bin_op "Mod" buffer ~pad value
| Neg {value; _} ->
pp_node buffer ~pad "Neg";
pp_expr buffer ~pad:(mk_pad 1 0 pc) value.arg;
| Int {value; _} ->
pp_node buffer ~pad "Int";
pp_int buffer ~pad value
| Nat {value; _} ->
pp_node buffer ~pad "Nat";
pp_int buffer ~pad value
| Mtz {value; _} ->
pp_node buffer ~pad "Mtz";
pp_int buffer ~pad value
and pp_set_expr buffer ~pad:(_,pc as pad) = function
SetInj {value; _} ->
pp_node buffer ~pad "SetInj";
pp_injection pp_expr buffer ~pad value
| SetMem {value; _} ->
pp_node buffer ~pad "SetMem";
pp_expr buffer ~pad:(mk_pad 2 0 pc) value.set;
pp_expr buffer ~pad:(mk_pad 2 1 pc) value.element
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; _} ->
pp_bin_op "Or" buffer ~pad value
| And {value; _} ->
pp_bin_op "And" 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 _ ->
pp_node buffer ~pad:(mk_pad 1 0 pc) "False"
| True _ ->
pp_node buffer ~pad:(mk_pad 1 0 pc) "True"
and pp_comp_expr buffer ~pad = function
Lt {value; _} ->
pp_bin_op "Lt" buffer ~pad value
| Leq {value; _} ->
pp_bin_op "Leq" buffer ~pad value
| Gt {value; _} ->
pp_bin_op "Gt" buffer ~pad value
| Geq {value; _} ->
pp_bin_op "Geq" buffer ~pad value
| Equal {value; _} ->
pp_bin_op "Equal" buffer ~pad value
| Neq {value; _} ->
pp_bin_op "Neq" buffer ~pad value
and pp_constr_expr buffer ~pad:(_, pc as pad) = function
SomeApp {value=some_region,args; _} ->
let constr = {value="Some"; region=some_region} in
let app = constr, Some args in
pp_node buffer ~pad "SomeApp";
pp_constr_app buffer ~pad app
| NoneExpr _ ->
pp_node buffer ~pad "NoneExpr"
| ConstrApp {value; _} ->
pp_node buffer ~pad "ConstrApp";
pp_constr_app buffer ~pad:(mk_pad 1 0 pc) value
and pp_constr_app buffer ~pad (constr, args_opt) =
pp_ident buffer ~pad constr.value;
match args_opt with
None -> ()
| Some args -> pp_tuple_expr buffer ~pad args
and pp_map_expr buffer ~pad = function
MapLookUp {value; _} ->
pp_node buffer ~pad "MapLookUp";
pp_map_lookup buffer ~pad value
| MapInj {value; _} ->
pp_node buffer ~pad "MapInj";
pp_injection pp_binding buffer ~pad value
and pp_tuple_expr buffer ~pad:(_,pc) {value; _} =
let exprs = Utils.nsepseq_to_list value.inside 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_string_expr buffer ~pad:(_,pc as pad) = function
Cat {value; _} ->
pp_node buffer ~pad "Cat";
pp_expr buffer ~pad:(mk_pad 2 0 pc) value.arg1;
pp_expr buffer ~pad:(mk_pad 2 1 pc) value.arg2;
| String {value; _} ->
pp_node buffer ~pad "String";
pp_string buffer ~pad:(mk_pad 1 0 pc) value
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_bin_op node buffer ~pad:(_,pc) op =
pp_node buffer ~pad:(mk_pad 1 0 pc) node;
let _, pc = mk_pad 1 0 pc in
(pp_expr buffer ~pad:(mk_pad 2 0 pc) op.arg1;
pp_expr buffer ~pad:(mk_pad 2 1 pc) op.arg2)
let pp_ast buffer = pp_ast buffer ~pad:("","")

2
src/passes/1-parser/pascaligo/ParserLog.mli
View File

@ -12,3 +12,5 @@ val tokens_to_string : AST.t -> string
val path_to_string : AST.path -> string val path_to_string : AST.path -> string
val pattern_to_string : AST.pattern -> string val pattern_to_string : AST.pattern -> string
val instruction_to_string : AST.instruction -> string val instruction_to_string : AST.instruction -> string
val pp_ast : Buffer.t -> AST.t -> unit

8
src/passes/1-parser/pascaligo/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;

2
src/passes/1-parser/shared/EvalOpt.ml
View File

@ -39,7 +39,7 @@ let help language extension () =
print " -q, --quiet No output, except errors (default)"; print " -q, --quiet No output, except errors (default)";
print " --columns Columns for source locations"; print " --columns Columns for source locations";
print " --bytes Bytes for source locations"; print " --bytes Bytes for source locations";
print " --verbose=<stages> cmdline, cpp, ast (colon-separated)"; print " --verbose=<stages> cmdline, cpp, ast-tokens, ast (colon-separated)";
print " --version Commit hash on stdout"; print " --version Commit hash on stdout";
print " -h, --help This help"; print " -h, --help This help";
exit 0 exit 0

12
src/passes/1-parser/shared/Lexer.mli
View File

@ -62,20 +62,20 @@ module type TOKEN =
type int_err = Non_canonical_zero type int_err = Non_canonical_zero
type ident_err = Reserved_name type ident_err = Reserved_name
type invalid_natural = type nat_err = Invalid_natural
| Invalid_natural
| Non_canonical_zero_nat | Non_canonical_zero_nat
type sym_err = Invalid_symbol
(* Injections *) (* Injections *)
val mk_string : lexeme -> Region.t -> token
val mk_bytes : lexeme -> Region.t -> token
val mk_int : lexeme -> Region.t -> (token, int_err) result val mk_int : lexeme -> Region.t -> (token, int_err) result
val mk_nat : lexeme -> Region.t -> (token, invalid_natural) result val mk_nat : lexeme -> Region.t -> (token, nat_err) result
val mk_mtz : lexeme -> Region.t -> (token, int_err) result val mk_mtz : lexeme -> Region.t -> (token, int_err) result
val mk_ident : lexeme -> Region.t -> (token, ident_err) result val mk_ident : lexeme -> Region.t -> (token, ident_err) result
val mk_sym : lexeme -> Region.t -> (token, sym_err) result
val mk_string : lexeme -> Region.t -> token
val mk_bytes : lexeme -> Region.t -> token
val mk_constr : lexeme -> Region.t -> token val mk_constr : lexeme -> Region.t -> token
val mk_sym : lexeme -> Region.t -> token
val eof : Region.t -> token val eof : Region.t -> token
(* Predicates *) (* Predicates *)

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

@ -103,20 +103,20 @@ module type TOKEN =
type int_err = Non_canonical_zero type int_err = Non_canonical_zero
type ident_err = Reserved_name type ident_err = Reserved_name
type invalid_natural = type nat_err = Invalid_natural
| Invalid_natural
| Non_canonical_zero_nat | Non_canonical_zero_nat
type sym_err = Invalid_symbol
(* Injections *) (* Injections *)
val mk_string : lexeme -> Region.t -> token
val mk_bytes : lexeme -> Region.t -> token
val mk_int : lexeme -> Region.t -> (token, int_err) result val mk_int : lexeme -> Region.t -> (token, int_err) result
val mk_nat : lexeme -> Region.t -> (token, invalid_natural) result val mk_nat : lexeme -> Region.t -> (token, nat_err) result
val mk_mtz : lexeme -> Region.t -> (token, int_err) result val mk_mtz : lexeme -> Region.t -> (token, int_err) result
val mk_ident : lexeme -> Region.t -> (token, ident_err) result val mk_ident : lexeme -> Region.t -> (token, ident_err) result
val mk_sym : lexeme -> Region.t -> (token, sym_err) result
val mk_string : lexeme -> Region.t -> token
val mk_bytes : lexeme -> Region.t -> token
val mk_constr : lexeme -> Region.t -> token val mk_constr : lexeme -> Region.t -> token
val mk_sym : lexeme -> Region.t -> token
val eof : Region.t -> token val eof : Region.t -> token
(* Predicates *) (* Predicates *)
@ -343,6 +343,7 @@ module Make (Token: TOKEN) : (S with module Token = Token) =
type Error.t += Broken_string type Error.t += Broken_string
type Error.t += Invalid_character_in_string type Error.t += Invalid_character_in_string
type Error.t += Reserved_name type Error.t += Reserved_name
type Error.t += Invalid_symbol
type Error.t += Invalid_natural type Error.t += Invalid_natural
let error_to_string = function let error_to_string = function
@ -386,6 +387,9 @@ module Make (Token: TOKEN) : (S with module Token = Token) =
| Reserved_name -> | Reserved_name ->
"Reserved named.\n\ "Reserved named.\n\
Hint: Change the name.\n" Hint: Change the name.\n"
| Invalid_symbol ->
"Invalid symbol.\n\
Hint: Check the LIGO syntax you use.\n"
| Invalid_natural -> | Invalid_natural ->
"Invalid natural." "Invalid natural."
| _ -> assert false | _ -> assert false
@ -487,8 +491,10 @@ module Make (Token: TOKEN) : (S with module Token = Token) =
in Token.mk_constr lexeme region, state in Token.mk_constr lexeme region, state
let mk_sym state buffer = let mk_sym state buffer =
let region, lexeme, state = sync state buffer let region, lexeme, state = sync state buffer in
in Token.mk_sym lexeme region, state match Token.mk_sym lexeme region with
Ok token -> token, state
| Error Token.Invalid_symbol -> fail region Invalid_symbol
let mk_eof state buffer = let mk_eof state buffer =
let region, _, state = sync state buffer let region, _, state = sync state buffer
@ -518,11 +524,16 @@ let byte_seq = byte | byte (byte | '_')* byte
let bytes = "0x" (byte_seq? as seq) let bytes = "0x" (byte_seq? as seq)
let esc = "\\n" | "\\\"" | "\\\\" | "\\b" let esc = "\\n" | "\\\"" | "\\\\" | "\\b"
| "\\r" | "\\t" | "\\x" byte | "\\r" | "\\t" | "\\x" byte
let symbol = ';' | ',' | '(' | ')'| '[' | ']' | '{' | '}' let pascaligo_sym = "=/=" | '#' | ":="
| '#' | '|' | "->" | ":=" | '=' | ':' let cameligo_sym = "<>" | "::" | "||" | "&&"
| '<' | "<=" | '>' | ">=" | "=/=" | "<>"
| '+' | '-' | '*' | '/' | '.' | '_' | '^' let symbol =
| "::" | "||" | "&&" ';' | ',' | '(' | ')'| '[' | ']' | '{' | '}'
| '=' | ':' | '|' | "->" | '.' | '_' | '^'
| '+' | '-' | '*' | '/'
| '<' | "<=" | '>' | ">="
| pascaligo_sym | cameligo_sym
let string = [^'"' '\\' '\n']* (* For strings of #include *) let string = [^'"' '\\' '\n']* (* For strings of #include *)
(* RULES *) (* RULES *)

51
src/passes/2-simplify/pascaligo.ml
View File

@ -35,26 +35,6 @@ module Errors = struct
] in ] in
error ~data title message error ~data title message
let unsupported_proc_decl decl =
let title () = "procedure declarations" in
let message () =
Format.asprintf "procedures are not supported yet" in
let data = [
("declaration",
fun () -> Format.asprintf "%a" Location.pp_lift @@ decl.Region.region)
] in
error ~data title message
let unsupported_local_proc region =
let title () = "local procedure declarations" in
let message () =
Format.asprintf "local procedures are not supported yet" in
let data = [
("declaration",
fun () -> Format.asprintf "%a" Location.pp_lift @@ region)
] in
error ~data title message
let corner_case ~loc message = let corner_case ~loc message =
let title () = "corner case" in let title () = "corner case" in
let content () = "We don't have a good error message for this case. \ let content () = "We don't have a good error message for this case. \
@ -88,16 +68,6 @@ module Errors = struct
] in ] in
error ~data title message error ~data title message
let unsupported_proc_calls call =
let title () = "procedure calls" in
let message () =
Format.asprintf "procedure calls are not supported yet" in
let data = [
("call_loc",
fun () -> Format.asprintf "%a" Location.pp_lift @@ call.Region.region)
] in
error ~data title message
let unsupported_for_loops region = let unsupported_for_loops region =
let title () = "bounded iterators" in let title () = "bounded iterators" in
let message () = let message () =
@ -273,10 +243,11 @@ let rec simpl_type_expression (t:Raw.type_expr) : type_expression result =
let args = let args =
match v.value.args with match v.value.args with
None -> [] None -> []
| Some (_, product) -> | Some (_, t_expr) ->
npseq_to_list product.value in match t_expr with
let%bind te = simpl_list_type_expression TProd product -> npseq_to_list product.value
@@ args in | _ -> [t_expr] in
let%bind te = simpl_list_type_expression @@ args in
ok (v.value.constr.value, te) ok (v.value.constr.value, te)
in in
let%bind lst = bind_list let%bind lst = bind_list
@ -345,8 +316,7 @@ let rec simpl_expression (t:Raw.expr) : expr result =
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 -> | ETuple tpl ->
let (Raw.TupleInj tpl') = tpl in let (tpl' , loc) = r_split tpl in
let (tpl' , loc) = r_split tpl' in
simpl_tuple_expression ~loc @@ npseq_to_list tpl'.inside simpl_tuple_expression ~loc @@ npseq_to_list tpl'.inside
| ERecord r -> | ERecord r ->
let%bind fields = bind_list let%bind fields = bind_list
@ -550,8 +520,7 @@ and simpl_local_declaration : Raw.local_decl -> _ result = fun t ->
let (f , loc) = r_split f in let (f , loc) = r_split f in
let%bind (name , e) = simpl_fun_declaration ~loc f in let%bind (name , e) = simpl_fun_declaration ~loc f in
return_let_in ~loc name e return_let_in ~loc name e
| LocalProc d ->
fail @@ unsupported_local_proc d.Region.region
and simpl_data_declaration : Raw.data_decl -> _ result = fun t -> and simpl_data_declaration : Raw.data_decl -> _ result = fun t ->
match t with match t with
| LocalVar x -> | LocalVar x ->
@ -659,13 +628,11 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap result =
ok @@ Declaration_constant (name.value , type_annotation , expression) ok @@ Declaration_constant (name.value , type_annotation , expression)
in in
bind_map_location simpl_const_decl (Location.lift_region x) bind_map_location simpl_const_decl (Location.lift_region x)
| LambdaDecl (FunDecl x) -> ( | FunDecl x -> (
let (x , loc) = r_split x in let (x , loc) = r_split x in
let%bind ((name , ty_opt) , expr) = simpl_fun_declaration ~loc x in let%bind ((name , ty_opt) , expr) = simpl_fun_declaration ~loc x in
ok @@ Location.wrap ~loc (Declaration_constant (name , ty_opt , expr)) ok @@ Location.wrap ~loc (Declaration_constant (name , ty_opt , expr))
) )
| LambdaDecl (ProcDecl decl) ->
fail @@ unsupported_proc_decl decl
and simpl_statement : Raw.statement -> (_ -> expression result) result = and simpl_statement : Raw.statement -> (_ -> expression result) result =
fun s -> fun s ->
@ -882,7 +849,7 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t -
| [] -> ok x' | [] -> ok x'
| _ -> ok t | _ -> ok t
) )
| _ -> fail @@ corner_case ~loc:__LOC__ "unexpected pattern" in | pattern -> ok pattern in
let get_constr (t: Raw.pattern) = let get_constr (t: Raw.pattern) =
match t with match t with
| PConstr v -> ( | PConstr v -> (

8
src/passes/2-simplify/pascaligo.mli
View File

@ -6,14 +6,10 @@ open Ast_simplified
module Raw = Parser.Pascaligo.AST module Raw = Parser.Pascaligo.AST
module SMap = Map.String module SMap = Map.String
module Errors : sig module Errors :
sig
val bad_bytes : Location.t -> string -> unit -> error val bad_bytes : Location.t -> string -> unit -> error
val unsupported_arith_op : Raw.expr -> unit -> error val unsupported_arith_op : Raw.expr -> unit -> error
val unsupported_proc_calls : 'a Raw.reg -> unit -> error
end end