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

Merge branch 'master' of gitlab.com:gabriel.alfour/tezos

Browse Source
This commit is contained in:
Galfour 2019-03-28 13:43:11 +00:00
commit 3bc925cac3
18 changed files with 2231 additions and 599 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
src/ligo/ligo-parser/.gitignore vendored
View File

@ -1 +1,8 @@
_build/*
*/_build
*~
.merlin
*/.merlin
*.install
/Version.ml
/dune-project

21
src/ligo/ligo-parser/.gitlab-ci.yml Normal file
View File

@ -0,0 +1,21 @@
before_script:
- apt-get update -qq
- apt-get -y -qq install libhidapi-dev libcap-dev bubblewrap
- wget https://github.com/ocaml/opam/releases/download/2.0.1/opam-2.0.1-x86_64-linux -O opam-2.0.1-x86_64-linux
- cp opam-2.0.1-x86_64-linux /usr/local/bin/opam
- chmod +x /usr/local/bin/opam
- export PATH="/usr/local/bin${PATH:+:}${PATH:-}"
- echo "$PATH"
- printf '' | opam init
- eval $(opam config env)
- opam repository add tezos-opam-repository https://gitlab.com/gabriel.alfour/tezos-opam-repository.git
- eval $(opam config env)
- opam --version
- printf '' | ocaml
default-job:
script:
- opam install -y --working-dir .
artifacts:
paths:
- Parser.exe

461
src/ligo/ligo-parser/AST.ml
View File

@ -39,26 +39,36 @@ let sepseq_to_region to_region = function
(* Keywords of LIGO *)
type keyword = Region.t
type kwd_and = Region.t
type kwd_begin = Region.t
type kwd_block = Region.t
type kwd_case = Region.t
type kwd_const = Region.t
type kwd_contains = Region.t
type kwd_down = Region.t
type kwd_else = Region.t
type kwd_end = Region.t
type kwd_entrypoint = Region.t
type kwd_fail = Region.t
type kwd_for = Region.t
type kwd_from = Region.t
type kwd_function = Region.t
type kwd_if = Region.t
type kwd_in = Region.t
type kwd_is = Region.t
type kwd_list = Region.t
type kwd_map = Region.t
type kwd_mod = Region.t
type kwd_nil = Region.t
type kwd_not = Region.t
type kwd_of = Region.t
type kwd_or = Region.t
type kwd_patch = Region.t
type kwd_procedure = Region.t
type kwd_record = Region.t
type kwd_remove = Region.t
type kwd_set = Region.t
type kwd_skip = Region.t
type kwd_step = Region.t
type kwd_storage = Region.t
@ -93,8 +103,6 @@ type arrow = Region.t
type assign = Region.t
type equal = Region.t
type colon = Region.t
type bool_or = Region.t
type bool_and = Region.t
type lt = Region.t
type leq = Region.t
type gt = Region.t
@ -119,6 +127,7 @@ type fun_name = string reg
type type_name = string reg
type field_name = string reg
type map_name = string reg
type set_name = string reg
type constr = string reg
(* Parentheses *)
@ -196,9 +205,10 @@ and variant = {
}
and record_type = {
kwd_record : kwd_record;
fields : field_decls;
kwd_end : kwd_end
opening : kwd_record;
field_decls : field_decls;
terminator : semi option;
closing : kwd_end
}
and field_decls = (field_decl reg, semi) nsepseq
@ -291,15 +301,32 @@ and param_var = {
}
and block = {
opening : kwd_begin;
instr : instructions;
opening : block_opening;
statements : statements;
terminator : semi option;
close : kwd_end
closing : block_closing
}
and block_opening =
Block of kwd_block * lbrace
| Begin of kwd_begin
and block_closing =
Block of rbrace
| End of kwd_end
and statements = (statement, semi) nsepseq
and statement =
Instr of instruction
| Data of data_decl
and local_decl =
LocalLam of lambda_decl
| LocalConst of const_decl reg
| LocalData of data_decl
and data_decl =
LocalConst of const_decl reg
| LocalVar of var_decl reg
and var_decl = {
@ -312,8 +339,6 @@ and var_decl = {
terminator : semi option
}
and instructions = (instruction, semi) nsepseq
and instruction =
Single of single_instr
| Block of block reg
@ -328,19 +353,38 @@ and single_instr =
| Skip of kwd_skip
| RecordPatch of record_patch reg
| MapPatch of map_patch reg
| SetPatch of set_patch reg
| MapRemove of map_remove reg
| SetRemove of set_remove reg
and set_remove = {
kwd_remove : kwd_remove;
element : expr;
kwd_from : kwd_from;
kwd_set : kwd_set;
set : path
}
and map_remove = {
kwd_remove : kwd_remove;
key : expr;
kwd_from : kwd_from;
kwd_map : kwd_map;
map : path
}
and set_patch = {
kwd_patch : kwd_patch;
path : path;
kwd_with : kwd_with;
set_inj : expr injection reg
}
and map_patch = {
kwd_patch : kwd_patch;
path : path;
kwd_with : kwd_with;
map_inj : map_injection reg
}
and map_injection = {
opening : kwd_map;
bindings : (binding reg, semi) nsepseq;
terminator : semi option;
close : kwd_end
map_inj : binding reg injection reg
}
and binding = {
@ -362,12 +406,23 @@ and fail_instr = {
}
and conditional = {
kwd_if : kwd_if;
test : expr;
kwd_then : kwd_then;
ifso : instruction;
kwd_else : kwd_else;
ifnot : instruction
kwd_if : kwd_if;
test : expr;
kwd_then : kwd_then;
ifso : if_clause;
terminator : semi option;
kwd_else : kwd_else;
ifnot : if_clause
}
and if_clause =
ClauseInstr of instruction
| ClauseBlock of (statements * semi option) braces reg
and set_membership = {
set : expr;
kwd_contains : kwd_contains;
element : expr
}
and case_instr = {
@ -450,17 +505,37 @@ and expr =
| ESet of set_expr
| EConstr of constr_expr
| ERecord of record_expr
| EProj of projection reg
| EMap of map_expr
| EVar of Lexer.lexeme reg
| ECall of fun_call
| EBytes of (Lexer.lexeme * Hex.t) reg
| EUnit of c_Unit
| ETuple of tuple
| ETuple of tuple_expr
| EPar of expr par reg
and set_expr =
SetInj of expr injection reg
| SetMem of set_membership reg
and 'a injection = {
opening : opening;
elements : ('a, semi) sepseq;
terminator : semi option;
closing : closing
}
and opening =
Kwd of keyword
| KwdBracket of keyword * lbracket
and closing =
End of kwd_end
| RBracket of rbracket
and map_expr =
MapLookUp of map_lookup reg
| MapInj of map_injection reg
| MapInj of binding reg injection reg
and map_lookup = {
path : path;
@ -468,17 +543,17 @@ and map_lookup = {
}
and path =
Name of variable
| RecordPath of record_projection reg
Name of variable
| Path of projection reg
and logic_expr =
BoolExpr of bool_expr
| CompExpr of comp_expr
and bool_expr =
Or of bool_or bin_op reg
| And of bool_and bin_op reg
| Not of kwd_not un_op reg
Or of kwd_or bin_op reg
| And of kwd_and bin_op reg
| Not of kwd_not un_op reg
| False of c_False
| True of c_True
@ -515,13 +590,15 @@ and string_expr =
| String of Lexer.lexeme reg
and list_expr =
Cons of cons bin_op reg
| List of (expr, comma) nsepseq brackets reg
| EmptyList of empty_list reg
Cons of cons bin_op reg
| List of expr injection reg
| Nil of nil par reg
and set_expr =
Set of (expr, comma) nsepseq braces reg
| EmptySet of empty_set reg
and nil = {
nil : kwd_nil;
colon : colon;
list_type : type_expr
}
and constr_expr =
SomeApp of (c_Some * arguments) reg
@ -529,14 +606,13 @@ and constr_expr =
| ConstrApp of (constr * arguments) reg
and record_expr =
RecordInj of record_injection reg
| RecordProj of record_projection reg
RecordInj of record_injection reg
and record_injection = {
opening : kwd_record;
fields : (field_assign reg, semi) nsepseq;
terminator : semi option;
close : kwd_end
closing : kwd_end
}
and field_assign = {
@ -545,31 +621,20 @@ and field_assign = {
field_expr : expr
}
and record_projection = {
and projection = {
record_name : variable;
selector : dot;
field_path : (field_name, dot) nsepseq
field_path : (selection, dot) nsepseq
}
and tuple = (expr, comma) nsepseq par reg
and selection =
FieldName of field_name
| Component of (Lexer.lexeme * Z.t) reg
and empty_list = typed_empty_list par
and tuple_expr =
TupleInj of tuple_injection
and typed_empty_list = {
lbracket : lbracket;
rbracket : rbracket;
colon : colon;
list_type : type_expr
}
and empty_set = typed_empty_set par
and typed_empty_set = {
lbrace : lbrace;
rbrace : rbrace;
colon : colon;
set_type : type_expr
}
and tuple_injection = (expr, comma) nsepseq par reg
and none_expr = typed_none_expr par
@ -581,7 +646,7 @@ and typed_none_expr = {
and fun_call = (fun_name * arguments) reg
and arguments = tuple
and arguments = tuple_injection
(* Patterns *)
@ -601,7 +666,8 @@ and pattern =
| PTuple of (pattern, comma) nsepseq par reg
and list_pattern =
Sugar of (pattern, comma) sepseq brackets reg
Sugar of pattern injection reg
| PNil of kwd_nil
| Raw of (pattern * cons * pattern) par reg
(* Projecting regions *)
@ -625,17 +691,25 @@ let rec expr_to_region = function
| EConstr e -> constr_expr_to_region e
| ERecord e -> record_expr_to_region e
| EMap e -> map_expr_to_region e
| ETuple e -> tuple_expr_to_region e
| EProj {region; _}
| EVar {region; _}
| ECall {region; _}
| EBytes {region; _}
| EUnit region
| ETuple {region; _}
| EPar {region; _} -> region
and tuple_expr_to_region = function
TupleInj {region; _} -> region
and map_expr_to_region = function
MapLookUp {region; _}
| MapInj {region; _} -> region
and set_expr_to_region = function
SetInj {region; _}
| SetMem {region; _} -> region
and logic_expr_to_region = function
BoolExpr e -> bool_expr_to_region e
| CompExpr e -> comp_expr_to_region e
@ -669,13 +743,9 @@ and string_expr_to_region = function
| String {region; _} -> region
and list_expr_to_region = function
Cons {region; _}
| List {region; _}
| EmptyList {region; _} -> region
and set_expr_to_region = function
Set {region; _}
| EmptySet {region; _} -> region
Cons {region; _}
| List {region; _}
| Nil {region; _} -> region
and constr_expr_to_region = function
NoneExpr {region; _}
@ -683,12 +753,11 @@ and constr_expr_to_region = function
| SomeApp {region; _} -> region
and record_expr_to_region = function
RecordInj {region; _}
| RecordProj {region; _} -> region
RecordInj {region; _} -> region
let path_to_region = function
Name var -> var.region
| RecordPath {region; _} -> region
| Path {region; _} -> region
let instr_to_region = function
Single Cond {region; _}
@ -702,8 +771,15 @@ let instr_to_region = function
| Single Fail {region; _}
| Single RecordPatch {region; _}
| Single MapPatch {region; _}
| Single SetPatch {region; _}
| Single MapRemove {region; _}
| Single SetRemove {region; _}
| Block {region; _} -> region
let if_clause_to_region = function
ClauseInstr instr -> instr_to_region instr
| ClauseBlock {region; _} -> region
let pattern_to_region = function
PCons {region; _}
| PVar {region; _}
@ -717,17 +793,18 @@ let pattern_to_region = function
| PNone region
| PSome {region; _}
| PList Sugar {region; _}
| PList PNil region
| PList Raw {region; _}
| PTuple {region; _} -> region
let local_decl_to_region = function
LocalLam FunDecl {region; _}
| LocalLam ProcDecl {region; _}
| LocalLam EntryDecl {region; _}
| LocalConst {region; _}
| LocalVar {region; _} -> region
LocalLam FunDecl {region; _}
| LocalLam ProcDecl {region; _}
| LocalLam EntryDecl {region; _}
| LocalData LocalConst {region; _}
| LocalData LocalVar {region; _} -> region
let lhs_to_region = function
let lhs_to_region : lhs -> Region.t = function
Path path -> path_to_region path
| MapPath {region; _} -> region
@ -735,6 +812,10 @@ let rhs_to_region = function
Expr e -> expr_to_region e
| NoneExpr r -> r
let selection_to_region = function
FieldName {region; _}
| Component {region; _} -> region
(* Printing the tokens with their source regions *)
let printf = Printf.printf
@ -833,10 +914,11 @@ and print_sum_type {value; _} =
print_nsepseq "|" print_variant value
and print_record_type {value; _} =
let {kwd_record; fields; kwd_end} = value in
print_token kwd_record "record";
print_field_decls fields;
print_token kwd_end "end"
let {opening; field_decls; terminator; closing} = value in
print_token opening "record";
print_field_decls field_decls;
print_terminator terminator;
print_token closing "end"
and print_type_app {value; _} =
let type_name, type_tuple = value in
@ -955,19 +1037,31 @@ and print_param_var {value; _} =
print_type_expr param_type
and print_block {value; _} =
let {opening; instr; terminator; close} = value in
print_token opening "begin";
print_instructions instr;
print_terminator terminator;
print_token close "end"
let {opening; statements; terminator; closing} = value in
print_block_opening opening;
print_statements statements;
print_terminator terminator;
print_block_closing closing
and print_block_opening = function
Block (kwd_block, lbrace) -> print_token kwd_block "block";
print_token lbrace "{"
| Begin kwd_begin -> print_token kwd_begin "begin"
and print_block_closing = function
Block rbrace -> print_token rbrace "}"
| End kwd_end -> print_token kwd_end "end"
and print_local_decls sequence =
List.iter print_local_decl sequence
and print_local_decl = function
LocalLam decl -> print_lambda_decl decl
| LocalConst decl -> print_const_decl decl
| LocalVar decl -> print_var_decl decl
LocalLam decl -> print_lambda_decl decl
| LocalData decl -> print_data_decl decl
and print_data_decl = function
LocalConst decl -> print_const_decl decl
| LocalVar decl -> print_var_decl decl
and print_var_decl {value; _} =
let {kwd_var; name; colon; var_type;
@ -980,12 +1074,16 @@ and print_var_decl {value; _} =
print_expr init;
print_terminator terminator
and print_instructions sequence =
print_nsepseq ";" print_instruction sequence
and print_statements sequence =
print_nsepseq ";" print_statement sequence
and print_statement = function
Instr instr -> print_instruction instr
| Data data -> print_data_decl data
and print_instruction = function
Single instr -> print_single_instr instr
| Block block -> print_block block
| Block block -> print_block block
and print_single_instr = function
Cond {value; _} -> print_conditional value
@ -997,20 +1095,34 @@ and print_single_instr = function
| Skip kwd_skip -> print_token kwd_skip "skip"
| RecordPatch {value; _} -> print_record_patch value
| MapPatch {value; _} -> print_map_patch value
| SetPatch {value; _} -> print_set_patch value
| MapRemove {value; _} -> print_map_remove value
| SetRemove {value; _} -> print_set_remove value
and print_fail {kwd_fail; fail_expr} =
print_token kwd_fail "fail";
print_expr fail_expr
and print_conditional node =
let {kwd_if; test; kwd_then; ifso;
let {kwd_if; test; kwd_then; ifso; terminator;
kwd_else; ifnot} = node in
print_token kwd_if "if";
print_expr test;
print_token kwd_then "then";
print_instruction ifso;
print_token kwd_else "else";
print_instruction ifnot
print_token kwd_if "if";
print_expr test;
print_token kwd_then "then";
print_if_clause ifso;
print_terminator terminator;
print_token kwd_else "else";
print_if_clause ifnot
and print_if_clause = function
ClauseInstr instr -> print_instruction instr
| ClauseBlock {value; _} ->
let {lbrace; inside; rbrace} = value in
let statements, terminator = inside in
print_token lbrace "{";
print_statements statements;
print_terminator terminator;
print_token rbrace "}"
and print_case_instr (node : case_instr) =
let {kwd_case; expr; kwd_of;
@ -1113,18 +1225,28 @@ and print_expr = function
| ESet e -> print_set_expr e
| EConstr e -> print_constr_expr e
| ERecord e -> print_record_expr e
| EProj e -> print_projection e
| EMap e -> print_map_expr e
| EVar v -> print_var v
| ECall e -> print_fun_call e
| EBytes b -> print_bytes b
| EUnit r -> print_token r "Unit"
| ETuple e -> print_tuple e
| ETuple e -> print_tuple_expr e
| EPar e -> print_par_expr e
and print_map_expr = function
MapLookUp {value; _} -> print_map_lookup value
| MapInj inj ->
print_map_injection inj
| MapInj inj -> print_injection "map" print_binding inj
and print_set_expr = function
SetInj inj -> print_injection "set" print_expr inj
| SetMem mem -> print_set_membership mem
and print_set_membership {value; _} =
let {set; kwd_contains; element} = value in
print_expr set;
print_token kwd_contains "contains";
print_expr element
and print_map_lookup {path; index} =
let {lbracket; inside; rbracket} = index.value in
@ -1134,8 +1256,8 @@ and print_map_lookup {path; index} =
print_token rbracket "]"
and print_path = function
Name var -> print_var var
| RecordPath path -> print_record_projection path
Name var -> print_var var
| Path path -> print_projection path
and print_logic_expr = function
BoolExpr e -> print_bool_expr e
@ -1188,12 +1310,8 @@ and print_string_expr = function
and print_list_expr = function
Cons {value = {arg1; op; arg2}; _} ->
print_expr arg1; print_token op "#"; print_expr arg2
| List e -> print_list e
| EmptyList e -> print_empty_list e
and print_set_expr = function
Set e -> print_set e
| EmptySet e -> print_empty_set e
| List e -> print_injection "list" print_expr e
| Nil e -> print_nil e
and print_constr_expr = function
SomeApp e -> print_some_app e
@ -1201,15 +1319,14 @@ and print_constr_expr = function
| ConstrApp e -> print_constr_app e
and print_record_expr = function
RecordInj e -> print_record_injection e
| RecordProj e -> print_record_projection e
RecordInj e -> print_record_injection e
and print_record_injection {value; _} =
let {opening; fields; terminator; close} = value in
let {opening; fields; terminator; closing} = value in
print_token opening "record";
print_nsepseq ";" print_field_assign fields;
print_terminator terminator;
print_token close "end"
print_token closing "end"
and print_field_assign {value; _} =
let {field_name; equal; field_expr} = value in
@ -1217,14 +1334,18 @@ and print_field_assign {value; _} =
print_token equal "=";
print_expr field_expr
and print_record_projection {value; _} =
and print_projection {value; _} =
let {record_name; selector; field_path} = value in
print_var record_name;
print_token selector ".";
print_field_path field_path
and print_field_path sequence =
print_nsepseq "." print_var sequence
print_nsepseq "." print_selection sequence
and print_selection = function
FieldName name -> print_var name
| Component int -> print_int int
and print_record_patch node =
let {kwd_patch; path; kwd_with; record_inj} = node in
@ -1233,19 +1354,54 @@ and print_record_patch node =
print_token kwd_with "with";
print_record_injection record_inj
and print_set_patch node =
let {kwd_patch; path; kwd_with; set_inj} = node in
print_token kwd_patch "patch";
print_path path;
print_token kwd_with "with";
print_injection "set" print_expr set_inj
and print_map_patch node =
let {kwd_patch; path; kwd_with; map_inj} = node in
print_token kwd_patch "patch";
print_path path;
print_token kwd_with "with";
print_map_injection map_inj
print_injection "map" print_binding map_inj
and print_map_injection {value; _} =
let {opening; bindings; terminator; close} = value in
print_token opening "record";
print_nsepseq ";" print_binding bindings;
print_terminator terminator;
print_token close "end"
and print_map_remove node =
let {kwd_remove; key; kwd_from; kwd_map; map} = node in
print_token kwd_remove "remove";
print_expr key;
print_token kwd_from "from";
print_token kwd_map "map";
print_path map
and print_set_remove node =
let {kwd_remove; element; kwd_from; kwd_set; set} = node in
print_token kwd_remove "remove";
print_expr element;
print_token kwd_from "from";
print_token kwd_set "set";
print_path set
and print_injection :
'a.string -> ('a -> unit) -> 'a injection reg -> unit =
fun kwd print {value; _} ->
let {opening; elements; terminator; closing} = value in
print_opening kwd opening;
print_sepseq ";" print elements;
print_terminator terminator;
print_closing closing
and print_opening lexeme = function
Kwd kwd -> print_token kwd lexeme
| KwdBracket (kwd, lbracket) ->
print_token kwd lexeme;
print_token lbracket "{"
and print_closing = function
RBracket rbracket -> print_token rbracket "}"
| End kwd_end -> print_token kwd_end "end"
and print_binding {value; _} =
let {source; arrow; image} = value in
@ -1253,44 +1409,24 @@ and print_binding {value; _} =
print_token arrow "->";
print_expr image
and print_tuple {value; _} =
and print_tuple_expr = function
TupleInj inj -> print_tuple_inj inj
and print_tuple_inj {value; _} =
let {lpar; inside; rpar} = value in
print_token lpar "(";
print_nsepseq "," print_expr inside;
print_token rpar ")"
and print_list {value; _} =
let {lbracket; inside; rbracket} = value in
print_token lbracket "[";
print_nsepseq "," print_expr inside;
print_token rbracket "]"
and print_empty_list {value; _} =
and print_nil {value; _} =
let {lpar; inside; rpar} = value in
let {lbracket; rbracket; colon; list_type} = inside in
let {nil; colon; list_type} = inside in
print_token lpar "(";
print_token lbracket "[";
print_token rbracket "]";
print_token nil "nil";
print_token colon ":";
print_type_expr list_type;
print_token rpar ")"
and print_set {value; _} =
let {lbrace; inside; rbrace} = value in
print_token lbrace "{";
print_nsepseq "," print_expr inside;
print_token rbrace "}"
and print_empty_set {value; _} =
let {lpar; inside; rpar} = value in
let {lbrace; rbrace; colon; set_type} = inside in
print_token lpar "(";
print_token lbrace "{";
print_token rbrace "}";
print_token colon ":";
print_type_expr set_type;
print_token rpar ")"
and print_none_expr {value; _} =
let {lpar; inside; rpar} = value in
let {c_None; colon; opt_type} = inside in
@ -1302,18 +1438,18 @@ and print_none_expr {value; _} =
and print_fun_call {value; _} =
let fun_name, arguments = value in
print_var fun_name;
print_tuple arguments
print_var fun_name;
print_tuple_inj arguments
and print_constr_app {value; _} =
let constr, arguments = value in
print_constr constr;
print_tuple arguments
print_constr constr;
print_tuple_inj arguments
and print_some_app {value; _} =
let c_Some, arguments = value in
print_token c_Some "Some";
print_tuple arguments
print_tuple_inj arguments
and print_par_expr {value; _} =
let {lpar; inside; rpar} = value in
@ -1348,14 +1484,9 @@ and print_patterns {value; _} =
print_token rpar ")"
and print_list_pattern = function
Sugar sugar -> print_sugar sugar
| Raw raw -> print_raw raw
and print_sugar {value; _} =
let {lbracket; inside; rbracket} = value in
print_token lbracket "[";
print_sepseq "," print_pattern inside;
print_token rbracket "]"
Sugar sugar -> print_injection "list" print_pattern sugar
| PNil kwd_nil -> print_token kwd_nil "nil"
| Raw raw -> print_raw raw
and print_raw {value; _} =
let {lpar; inside; rpar} = value in

194
src/ligo/ligo-parser/AST.mli
View File

@ -23,26 +23,36 @@ val sepseq_to_region : ('a -> Region.t) -> ('a,'sep) sepseq -> Region.t
(* Keywords of LIGO *)
type keyword = Region.t
type kwd_and = Region.t
type kwd_begin = Region.t
type kwd_case = Region.t
type kwd_block = Region.t
type kwd_case = Region.t
type kwd_const = Region.t
type kwd_contains = Region.t
type kwd_down = Region.t
type kwd_else = Region.t
type kwd_end = Region.t
type kwd_entrypoint = Region.t
type kwd_fail = Region.t
type kwd_for = Region.t
type kwd_from = Region.t
type kwd_function = Region.t
type kwd_if = Region.t
type kwd_in = Region.t
type kwd_is = Region.t
type kwd_list = Region.t
type kwd_map = Region.t
type kwd_mod = Region.t
type kwd_nil = Region.t
type kwd_not = Region.t
type kwd_of = Region.t
type kwd_or = Region.t
type kwd_patch = Region.t
type kwd_procedure = Region.t
type kwd_record = Region.t
type kwd_remove = Region.t
type kwd_set = Region.t
type kwd_skip = Region.t
type kwd_step = Region.t
type kwd_storage = Region.t
@ -77,8 +87,6 @@ type arrow = Region.t (* "->" *)
type assign = Region.t (* ":=" *)
type equal = Region.t (* "=" *)
type colon = Region.t (* ":" *)
type bool_or = Region.t (* "||" *)
type bool_and = Region.t (* "&&" *)
type lt = Region.t (* "<" *)
type leq = Region.t (* "<=" *)
type gt = Region.t (* ">" *)
@ -103,6 +111,7 @@ type fun_name = string reg
type type_name = string reg
type field_name = string reg
type map_name = string reg
type set_name = string reg
type constr = string reg
(* Parentheses *)
@ -180,9 +189,10 @@ and variant = {
}
and record_type = {
kwd_record : kwd_record;
fields : field_decls;
kwd_end : kwd_end
opening : kwd_record;
field_decls : field_decls;
terminator : semi option;
closing : kwd_end
}
and field_decls = (field_decl reg, semi) nsepseq
@ -275,15 +285,32 @@ and param_var = {
}
and block = {
opening : kwd_begin;
instr : instructions;
opening : block_opening;
statements : statements;
terminator : semi option;
close : kwd_end
closing : block_closing
}
and block_opening =
Block of kwd_block * lbrace
| Begin of kwd_begin
and block_closing =
Block of rbrace
| End of kwd_end
and statements = (statement, semi) nsepseq
and statement =
Instr of instruction
| Data of data_decl
and local_decl =
LocalLam of lambda_decl
| LocalConst of const_decl reg
| LocalData of data_decl
and data_decl =
LocalConst of const_decl reg
| LocalVar of var_decl reg
and var_decl = {
@ -296,8 +323,6 @@ and var_decl = {
terminator : semi option
}
and instructions = (instruction, semi) nsepseq
and instruction =
Single of single_instr
| Block of block reg
@ -312,19 +337,38 @@ and single_instr =
| Skip of kwd_skip
| RecordPatch of record_patch reg
| MapPatch of map_patch reg
| SetPatch of set_patch reg
| MapRemove of map_remove reg
| SetRemove of set_remove reg
and set_remove = {
kwd_remove : kwd_remove;
element : expr;
kwd_from : kwd_from;
kwd_set : kwd_set;
set : path
}
and map_remove = {
kwd_remove : kwd_remove;
key : expr;
kwd_from : kwd_from;
kwd_map : kwd_map;
map : path
}
and set_patch = {
kwd_patch : kwd_patch;
path : path;
kwd_with : kwd_with;
set_inj : expr injection reg
}
and map_patch = {
kwd_patch : kwd_patch;
path : path;
kwd_with : kwd_with;
map_inj : map_injection reg
}
and map_injection = {
opening : kwd_map;
bindings : (binding reg, semi) nsepseq;
terminator : semi option;
close : kwd_end
map_inj : binding reg injection reg
}
and binding = {
@ -346,12 +390,23 @@ and fail_instr = {
}
and conditional = {
kwd_if : kwd_if;
test : expr;
kwd_then : kwd_then;
ifso : instruction;
kwd_else : kwd_else;
ifnot : instruction
kwd_if : kwd_if;
test : expr;
kwd_then : kwd_then;
ifso : if_clause;
terminator : semi option;
kwd_else : kwd_else;
ifnot : if_clause
}
and if_clause =
ClauseInstr of instruction
| ClauseBlock of (statements * semi option) braces reg
and set_membership = {
set : expr;
kwd_contains : kwd_contains;
element : expr
}
and case_instr = {
@ -434,17 +489,37 @@ and expr =
| ESet of set_expr
| EConstr of constr_expr
| ERecord of record_expr
| EProj of projection reg
| EMap of map_expr
| EVar of Lexer.lexeme reg
| ECall of fun_call
| EBytes of (Lexer.lexeme * Hex.t) reg
| EUnit of c_Unit
| ETuple of tuple
| ETuple of tuple_expr
| EPar of expr par reg
and set_expr =
SetInj of expr injection reg
| SetMem of set_membership reg
and 'a injection = {
opening : opening;
elements : ('a, semi) sepseq;
terminator : semi option;
closing : closing
}
and opening =
Kwd of keyword
| KwdBracket of keyword * lbracket
and closing =
End of kwd_end
| RBracket of rbracket
and map_expr =
MapLookUp of map_lookup reg
| MapInj of map_injection reg
| MapInj of binding reg injection reg
and map_lookup = {
path : path;
@ -452,17 +527,17 @@ and map_lookup = {
}
and path =
Name of variable
| RecordPath of record_projection reg
Name of variable
| Path of projection reg
and logic_expr =
BoolExpr of bool_expr
| CompExpr of comp_expr
and bool_expr =
Or of bool_or bin_op reg
| And of bool_and bin_op reg
| Not of kwd_not un_op reg
Or of kwd_or bin_op reg
| And of kwd_and bin_op reg
| Not of kwd_not un_op reg
| False of c_False
| True of c_True
@ -499,13 +574,15 @@ and string_expr =
| String of Lexer.lexeme reg
and list_expr =
Cons of cons bin_op reg
| List of (expr, comma) nsepseq brackets reg
| EmptyList of empty_list reg
Cons of cons bin_op reg
| List of expr injection reg
| Nil of nil par reg
and set_expr =
Set of (expr, comma) nsepseq braces reg
| EmptySet of empty_set reg
and nil = {
nil : kwd_nil;
colon : colon;
list_type : type_expr
}
and constr_expr =
SomeApp of (c_Some * arguments) reg
@ -513,14 +590,13 @@ and constr_expr =
| ConstrApp of (constr * arguments) reg
and record_expr =
RecordInj of record_injection reg
| RecordProj of record_projection reg
RecordInj of record_injection reg
and record_injection = {
opening : kwd_record;
fields : (field_assign reg, semi) nsepseq;
terminator : semi option;
close : kwd_end
closing : kwd_end
}
and field_assign = {
@ -529,31 +605,20 @@ and field_assign = {
field_expr : expr
}
and record_projection = {
and projection = {
record_name : variable;
selector : dot;
field_path : (field_name, dot) nsepseq
field_path : (selection, dot) nsepseq
}
and tuple = (expr, comma) nsepseq par reg
and selection =
FieldName of field_name
| Component of (Lexer.lexeme * Z.t) reg
and empty_list = typed_empty_list par
and tuple_expr =
TupleInj of tuple_injection
and typed_empty_list = {
lbracket : lbracket;
rbracket : rbracket;
colon : colon;
list_type : type_expr
}
and empty_set = typed_empty_set par
and typed_empty_set = {
lbrace : lbrace;
rbrace : rbrace;
colon : colon;
set_type : type_expr
}
and tuple_injection = (expr, comma) nsepseq par reg
and none_expr = typed_none_expr par
@ -565,7 +630,7 @@ and typed_none_expr = {
and fun_call = (fun_name * arguments) reg
and arguments = tuple
and arguments = tuple_injection
(* Patterns *)
@ -585,7 +650,8 @@ and pattern =
| PTuple of (pattern, comma) nsepseq par reg
and list_pattern =
Sugar of (pattern, comma) sepseq brackets reg
Sugar of pattern injection reg
| PNil of kwd_nil
| Raw of (pattern * cons * pattern) par reg
(* Projecting regions *)
@ -598,6 +664,8 @@ val local_decl_to_region : local_decl -> Region.t
val path_to_region : path -> Region.t
val lhs_to_region : lhs -> Region.t
val rhs_to_region : rhs -> Region.t
val if_clause_to_region : if_clause -> Region.t
val selection_to_region : selection -> Region.t
(* Printing *)

799
src/ligo/ligo-parser/AST2.ml Normal file
View File

@ -0,0 +1,799 @@
(*
[@@@warning "-30"]
module I = AST
open Region
module SMap = Map.Make(String)
module O = struct
type asttodo = [`TODO] (* occurrences of asttodo will point to some part of the original parser AST *)
type name_and_region = {name: string; orig: Region.t}
type type_name = name_and_region
type var_name = name_and_region
type field_name = name_and_region
type pattern =
PVar of var_name
| PWild
| PInt of Z.t
| PBytes of MBytes.t
| PString of string
| PUnit
| PFalse
| PTrue
| PNone
| PSome of pattern
| PCons of pattern * pattern
| PNull
| PRecord of (field_name * pattern) SMap.t
type type_constructor =
Option
| List
| Set
| Map
type type_expr_case =
Sum of (type_name * type_expr) SMap.t
| Record of (field_name * type_expr) SMap.t
| TypeApp of type_constructor * (type_expr list)
| Function of { arg: type_expr; ret: type_expr }
| Ref of type_expr
| String
| Bytes
| Int
| Unit
| Bool
and type_expr = { type_expr: type_expr_case; name: type_name option; orig: Region.t }
type typed_var = { name:var_name; ty:type_expr; orig: asttodo }
type type_decl = { name:type_name; ty:type_expr; orig: asttodo }
type expr =
App of { operator: operator; arguments: expr list }
| Var of var_name
| Constant of constant
| Record of (field_name * expr) list
| Lambda of lambda
and decl = { name:var_name; ty:type_expr; value: expr }
and lambda = {
parameter: typed_var;
declarations: decl list;
instructions: instr list;
result: expr;
}
and operator =
Function of var_name
| Constructor of var_name
| UpdateField of field_name
| GetField of field_name
| Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod
| Neg | Not
| Set | List
| MapLookup
and constant =
Unit
| Int of Z.t | String of string | Bytes of MBytes.t
| False | True
| Null of type_expr
| EmptySet of type_expr
| CNone of type_expr
and instr =
Assignment of { name: var_name; value: expr; orig: asttodo }
| While of { condition: expr; body: instr list; orig: asttodo }
| ForCollection of { list: expr; var: var_name; body: instr list; orig: asttodo }
| Match of { expr: expr; cases: (pattern * instr list) list; orig: asttodo }
| ProcedureCall of { expr: expr; orig: asttodo } (* expr returns unit, drop the result. Similar to OCaml's ";". *)
| Fail of { expr: expr; orig: asttodo }
type ast = {
types : type_decl list;
storage_decl : typed_var;
declarations : decl list;
orig : AST.t
}
end
(* open Sanity: *)
let (|>) v f = f v (* pipe f to v *)
let (@@) f v = f v (* apply f on v *)
let (@.) f g x = f (g x) (* compose *)
let map f l = List.rev (List.rev_map f l)
let mapi f l =
let f (i, l) elem =
(i + 1, (f i elem) :: l)
in snd (List.fold_left f (0,[]) l)
(* TODO: check that List.append is not broken
(i.e. check that it is tail-recursive) *)
let append_map f l = map f l |> List.flatten
let append l1 l2 = List.append l1 l2
let list_to_map l = List.fold_left (fun m (k,v) -> SMap.add k v m) SMap.empty l
let fold_map f a l =
let f (acc, l) elem =
let acc', elem' = f acc elem
in acc', (elem' :: l) in
let last_acc, last_l = List.fold_left f (a, []) l
in last_acc, List.rev last_l
(* Simplify the AST *)
let name_and_region_of_int i = O.{name = string_of_int i; orig = Region.ghost}
let s_nsepseq : ('a,'sep) Utils.nsepseq -> 'a list =
fun (first, rest) -> first :: (map snd rest)
let s_sepseq : ('a,'sep) Utils.sepseq -> 'a list =
function
None -> []
| Some nsepseq -> s_nsepseq nsepseq
let s_name {value=name; region} : O.var_name =
let () = ignore (region) in
{name;orig = region}
let name_to_string {value=name; region} : string =
let () = ignore (region) in
name
let type_expr (orig : Region.t) (e : O.type_expr_case) : O.type_expr =
{ type_expr = e; name = None; orig }
let s_type_constructor {value=name;region} : O.type_constructor =
let () = ignore (region) in
match name with
"Option" -> Option
| "List" -> List
| "Map" -> Map
| "Set" -> Set
(* TODO: escape the name, prevent any \x1b and other weird characters from appearing in the output *)
| _ -> failwith ("Unknown type constructor: " ^ name)
let named_list_to_map (l : (O.name_and_region * 'a) list) : (O.name_and_region * 'a) SMap.t =
List.fold_left
(fun m ((x,_) as p) ->
let {name;_} : O.name_and_region = x in
SMap.add name p m)
SMap.empty
l
let rec s_cartesian {value=sequence; region} : O.type_expr =
let () = ignore (region) in
s_nsepseq sequence
|>map s_type_expr
|> mapi (fun i p -> name_and_region_of_int i, p)
|> named_list_to_map
|> (fun x -> (Record x : O.type_expr_case))
|> type_expr region
and s_sum_type {value=sequence; region} : O.type_expr =
let () = ignore (region) in
type_expr region (Sum (map s_variant (s_nsepseq sequence) |> named_list_to_map))
and s_variant {value=(constr, kwd_of, cartesian); region} =
let () = ignore (kwd_of,region) in
(s_name constr, s_cartesian cartesian)
and s_record_type {value=(kwd_record, field_decls, kwd_end); region} : O.type_expr =
let () = ignore (kwd_record,region,kwd_end) in
type_expr region (Record (map s_field_decl (s_nsepseq field_decls) |> named_list_to_map) : O.type_expr_case)
and s_field_decl {value=(var, colon, type_expr); region} : O.type_name * O.type_expr =
let () = ignore (colon,region) in
((s_name var), (s_type_expr type_expr))
and s_type_app {value=(type_name,type_tuple); region} : O.type_expr =
let () = ignore (region) in
type_expr region (TypeApp (s_type_constructor type_name, s_type_tuple type_tuple))
and s_type_tuple ({value=(lpar, sequence, rpar); region} : (I.type_name, I.comma) Utils.nsepseq I.par) : O.type_expr list =
let () = ignore (lpar,rpar,region) in
(* TODO: the grammar should allow any type expr, not just type_name in the tuple elements *)
map s_type_expr (map (fun a -> I.TAlias a) (s_nsepseq sequence))
and s_par_type {value=(lpar, type_expr, rpar); region} : O.type_expr =
let () = ignore (lpar,rpar,region) in
s_type_expr type_expr
and s_type_alias name : O.type_expr =
let () = ignore () in
type_expr name.region (TypeApp (s_type_constructor name, []))
and s_type_expr (orig : I.type_expr) : O.type_expr = match orig with
Prod cartesian -> s_cartesian cartesian
| Sum sum_type -> s_sum_type sum_type
| Record record_type -> s_record_type record_type
| TypeApp type_app -> s_type_app type_app
| ParType par_type -> s_par_type par_type
| TAlias type_alias -> s_type_alias type_alias
let s_type_decl I.{value={kwd_type;name;kwd_is;type_expr;terminator}; region} : O.type_decl =
let () = ignore (kwd_type,kwd_is,terminator,region) in
let ty = s_type_expr type_expr in
O.{ name = s_name name; ty = { ty with name = Some (s_name name) }; orig = `TODO }
let s_storage_decl I.{value={kwd_storage; name; colon; store_type; terminator}; region} : O.typed_var =
let () = ignore (kwd_storage,colon,terminator,region) in
O.{ name = s_name name; ty = s_type_expr store_type; orig = `TODO }
let s_operations_decl I.{value={kwd_operations;name;colon;op_type;terminator}; region} : O.typed_var =
let () = ignore (kwd_operations,colon,terminator,region) in
O.{ name = s_name name; ty = s_type_expr op_type; orig = `TODO }
let s_empty_list {value=(l, (lbracket, rbracket, colon, type_expr), r); region} : O.expr =
let () = ignore (l, lbracket, rbracket, colon, r, region) in
Constant (Null (s_type_expr type_expr))
let s_empty_set {value=(l, (lbrace, rbrace, colon, type_expr), r); region} : O.expr =
let () = ignore (l, lbrace, rbrace, colon, r, region) in
Constant (EmptySet (s_type_expr type_expr))
let s_none {value=(l, (c_None, colon, type_expr), r); region} : O.expr =
let () = ignore (l, c_None, colon, r, region) in
Constant (CNone (s_type_expr type_expr))
let parameters_to_tuple (parameters : (string * O.type_expr) list) : O.type_expr =
(* TODO: use records with named fields to have named arguments. *)
let parameter_tuple : O.type_expr_case =
Record (mapi (fun i (_name,ty) -> name_and_region_of_int i, ty) parameters |> named_list_to_map) in
O.{ type_expr = parameter_tuple; name = None; orig = Region.ghost }
and parameters_to_decls singleparam (parameters : (string * O.type_expr) list) : O.decl list =
let f i (name,ty) =
O.{ name = {name; orig=Region.ghost};
ty = ty;
value = App { operator = O.GetField (name_and_region_of_int i);
arguments = [Var singleparam] } }
in mapi f parameters
let rec bin l operator r = O.App { operator; arguments = [s_expr l; s_expr r] }
and una operator v = O.App { operator; arguments = [s_expr v] }
and s_expr : I.expr -> O.expr =
function
Or {value=(l, bool_or, r); region} -> let () = ignore (region, bool_or) in bin l Or r
| And {value=(l, bool_and, r); region} -> let () = ignore (region,bool_and) in bin l And r
| Lt {value=(l, lt, r); region} -> let () = ignore (region, lt) in bin l Lt r
| Leq {value=(l, leq, r); region} -> let () = ignore (region, leq) in bin l Leq r
| Gt {value=(l, gt, r); region} -> let () = ignore (region, gt) in bin l Gt r
| Geq {value=(l, geq, r); region} -> let () = ignore (region, geq) in bin l Geq r
| Equal {value=(l, equal, r); region} -> let () = ignore (region, equal) in bin l Equal r
| Neq {value=(l, neq, r); region} -> let () = ignore (region, neq) in bin l Neq r
| Cat {value=(l, cat, r); region} -> let () = ignore (region, cat) in bin l Cat r
| Cons {value=(l, cons, r); region} -> let () = ignore (region, cons) in bin l Cons r
| Add {value=(l, plus, r); region} -> let () = ignore (region, plus) in bin l Add r
| Sub {value=(l, minus, r); region} -> let () = ignore (region, minus) in bin l Sub r
| Mult {value=(l, times, r); region} -> let () = ignore (region, times) in bin l Mult r
| Div {value=(l, slash, r); region} -> let () = ignore (region, slash) in bin l Div r
| Mod {value=(l, kwd_mod, r); region} -> let () = ignore (region, kwd_mod) in bin l Mod r
| Neg {value=(minus, expr); region} -> let () = ignore (region, minus) in una Neg expr
| Not {value=(kwd_not, expr); region} -> let () = ignore (region, kwd_not) in una Not expr
| Int {value=(lexeme, z); region} -> let () = ignore (region, lexeme) in Constant (Int z)
| Var lexeme -> Var (s_name lexeme)
| String {value=s; region} -> let () = ignore (region) in Constant (String s)
| Bytes {value=(lexeme, mbytes); region} -> let () = ignore (region, lexeme) in Constant (Bytes mbytes)
| False c_False -> let () = ignore (c_False) in Constant (False)
| True c_True -> let () = ignore (c_True) in Constant (True)
| Unit c_Unit -> let () = ignore (c_Unit) in Constant (Unit)
| Tuple {value=(l,tuple,r); region} -> let () = ignore (l,r,region) in s_tuple_expr (tuple |> s_nsepseq |> map s_expr)
| List list -> s_list list
| EmptyList empty_list -> s_empty_list empty_list
| Set set -> s_set set
| EmptySet empty_set -> s_empty_set empty_set
| NoneExpr none_expr -> s_none none_expr
| FunCall fun_call -> s_fun_call fun_call
| ConstrApp constr_app -> s_constr_app constr_app
| SomeApp some_app -> s_some_app some_app
| MapLookUp map_lookup -> s_map_lookup map_lookup
| ParExpr {value=(lpar,expr,rpar); region} -> let () = ignore (lpar,rpar,region) in s_expr expr
and s_tuple_expr tuple : O.expr =
Record (mapi (fun i e -> name_and_region_of_int i, e) tuple)
and s_map_lookup I.{value = {map_name; selector; index}; region} : O.expr =
let {value = lbracket, index_expr, rbracket; region=region2} = index in
let () = ignore (selector, lbracket, rbracket, region2, region) in
App { operator = MapLookup; arguments = [Var (s_name map_name); s_expr index_expr] }
and s_some_app {value=(c_Some, {value=(l,arguments,r); region=region2}); region} : O.expr =
let () = ignore (c_Some,l,r,region2,region) in
match s_nsepseq arguments with
[] -> failwith "tuple cannot be empty"
| [a] -> s_expr a
| l -> s_tuple_expr (map s_expr l)
and s_list {value=(l, list, r); region} : O.expr =
let () = ignore (l, r, region) in
App { operator = List; arguments = map s_expr (s_nsepseq list) }
and s_set {value=(l, set, r); region} : O.expr =
let () = ignore (l, r, region) in
App { operator = Set; arguments = map s_expr (s_nsepseq set) }
and s_pattern {value=sequence; region} : O.pattern =
let () = ignore (region) in
s_pattern_conses (s_nsepseq sequence)
and s_pattern_conses : I.core_pattern list -> O.pattern = function
[] -> assert false
| [p] -> s_core_pattern p
| hd :: tl -> PCons (s_core_pattern hd, s_pattern_conses tl)
and s_case ({value=(pattern, arrow, instruction); region} : I.case) : O.pattern * O.instr list =
let () = ignore (arrow,region) in
s_pattern pattern, s_instruction instruction
and s_core_pattern : I.core_pattern -> O.pattern = function
PVar var -> PVar (s_name var)
| PWild wild -> let () = ignore (wild) in PWild
| PInt {value=(si,i);region} -> let () = ignore (si,region) in PInt i
| PBytes {value=(sb,b);region} -> let () = ignore (sb,region) in PBytes b
| PString {value=s;region} -> let () = ignore (region) in PString s
| PUnit region -> let () = ignore (region) in PUnit
| PFalse region -> let () = ignore (region) in PFalse
| PTrue region -> let () = ignore (region) in PTrue
| PNone region -> let () = ignore (region) in PNone
| PSome psome -> s_psome psome
| PList pattern -> s_list_pattern pattern
| PTuple ptuple -> s_ptuple ptuple
and s_list_pattern = function
Sugar sugar -> s_sugar sugar
| Raw raw -> s_raw raw
and s_sugar {value=(lbracket, sequence, rbracket); region} : O.pattern =
let () = ignore (lbracket, rbracket, region) in
List.fold_left (fun acc p -> O.PCons (s_core_pattern p, acc))
O.PNull
(s_sepseq sequence);
and s_raw {value=(lpar, (core_pattern, cons, pattern), rpar); region} =
let () = ignore (lpar, cons, rpar, region) in
O.PCons (s_core_pattern core_pattern, s_pattern pattern)
and s_ptuple {value=(lpar, sequence, rpar); region} =
let () = ignore (lpar, rpar, region) in
s_nsepseq sequence
|> map s_core_pattern
|> mapi (fun i p -> name_and_region_of_int i, p)
|> fun x -> O.PRecord (x |> named_list_to_map)
and s_psome {value=(c_Some,{value=(l,psome,r);region=region2});region} : O.pattern =
let () = ignore (c_Some,l,r,region2,region) in
PSome (s_core_pattern psome)
and s_const_decl I.{value={kwd_const;name;colon;const_type;equal;init;terminator}; region} : O.decl =
let () = ignore (kwd_const,colon,equal,terminator,region) in
O.{ name = s_name name; ty = s_type_expr const_type; value = s_expr init }
and s_param_const {value=(kwd_const,variable,colon,type_expr); region} : string * O.type_expr =
let () = ignore (kwd_const,colon,region) in
name_to_string variable, s_type_expr type_expr
and s_param_var {value=(kwd_var,variable,colon,type_expr); region} : string * O.type_expr =
let () = ignore (kwd_var,colon,region) in
name_to_string variable, s_type_expr type_expr
and s_param_decl : I.param_decl -> string * O.type_expr = function
ParamConst p -> s_param_const p
| ParamVar p -> s_param_var p
and s_parameters ({value=(lpar,param_decl,rpar);region} : I.parameters) : (string * O.type_expr) list =
let () = ignore (lpar,rpar,region) in
let l = (s_nsepseq param_decl) in
map s_param_decl l
and s_var_decl I.{value={kwd_var;name;colon;var_type;ass;init;terminator}; region} : O.decl =
let () = ignore (kwd_var,colon,ass,terminator,region) in
O.{
name = s_name name;
ty = s_type_expr var_type;
value = s_expr init
}
and s_local_decl : I.local_decl -> O.decl = function
LocalLam decl -> s_lambda_decl decl
| LocalConst decl -> s_const_decl decl
| LocalVar decl -> s_var_decl decl
and s_instructions ({value=sequence; region} : I.instructions) : O.instr list =
let () = ignore (region) in
append_map s_instruction (s_nsepseq sequence)
and s_instruction : I.instruction -> O.instr list = function
Single instr -> s_single_instr instr
| Block block -> (s_block block)
and s_conditional I.{kwd_if;test;kwd_then;ifso;kwd_else;ifnot} : O.instr =
let () = ignore (kwd_if,kwd_then,kwd_else) in
let test = s_expr test in
let ifso = O.PTrue, s_instruction ifso in
let ifnot = O.PFalse, s_instruction ifnot in
Match {
expr = test;
cases = [ifso; ifnot];
orig = `TODO
}
and s_match_instr I.{kwd_match;expr;kwd_with;lead_vbar;cases;kwd_end} : O.instr =
let {value=cases;region} = cases in
let () = ignore (kwd_match,kwd_with,lead_vbar,kwd_end,region) in
Match { expr = s_expr expr; cases = map s_case (s_nsepseq cases); orig = `TODO }
and s_ass_instr {value=(variable,ass,expr); region} : O.instr =
let () = ignore (ass,region) in
Assignment { name = s_name variable; value = s_expr expr; orig = `TODO }
and s_while_loop {value=(kwd_while, expr, block); region} : O.instr list =
let () = ignore (kwd_while,region) in
[While {condition = s_expr expr; body = s_block block; orig = `TODO}]
and s_for_loop : I.for_loop -> O.instr list = function
ForInt for_int -> s_for_int for_int
| ForCollect for_collect -> s_for_collect for_collect
and s_for_int ({value={kwd_for;ass;down;kwd_to;bound;step;block}; region} : I.for_int reg) : O.instr list =
let {value=(variable,ass_kwd,expr);region = ass_region} = ass in
let () = ignore (kwd_for,ass_region,ass_kwd,kwd_to,region) in
let name = s_name variable in
let condition, operator = match down with Some kwd_down -> ignore kwd_down; O.Gt, O.Sub
| None -> O.Lt, O.Add in
let step = s_step step
in [
Assignment { name; value = s_expr expr; orig = `TODO };
(* TODO: lift the declaration of the variable, to avoid creating a nested scope here. *)
While {
condition = App { operator = condition;
arguments = [Var name; s_expr bound]};
body = append (s_block block)
[O.Assignment { name;
value = App { operator;
arguments = [Var name; step]};
orig = `TODO }];
orig = `TODO
}
]
and s_for_collect ({value={kwd_for;var;bind_to;kwd_in;expr;block}; _} : I.for_collect reg) : O.instr list =
let () = ignore (kwd_for,kwd_in) in
let for_instr =
match s_bind_to bind_to with
Some _ ->
failwith "TODO: For on maps is not supported yet!"
| None ->
O.ForCollection {
list = s_expr expr;
var = s_name var;
body = s_block block;
orig = `TODO
}
in [for_instr]
and s_step : (I.kwd_step * I.expr) option -> O.expr = function
Some (kwd_step, expr) -> let () = ignore (kwd_step) in s_expr expr
| None -> Constant (Int (Z.of_int 1))
and s_bind_to : (I.arrow * I.variable) option -> O.var_name option = function
Some (arrow, variable) -> let () = ignore (arrow) in Some (s_name variable)
| None -> None
and s_loop : I.loop -> O.instr list = function
While while_loop -> s_while_loop while_loop
| For for_loop -> s_for_loop for_loop
and s_fun_call {value=(fun_name, arguments); region} : O.expr =
let () = ignore (region) in
let {value=fun_name_string;_} = fun_name in
let firstchar = String.sub fun_name_string 0 1 in
(* If it starts with a capital letter, then it is a constructor *)
if String.equal firstchar (String.uppercase_ascii firstchar) then
App { operator = Constructor (s_name fun_name); arguments = s_arguments arguments }
else
App { operator = Function (s_name fun_name); arguments = s_arguments arguments }
and s_constr_app {value=(constr, arguments); region} : O.expr =
let () = ignore (region) in
App { operator = Function (s_name constr); arguments = s_arguments arguments }
and s_arguments {value=(lpar, sequence, rpar); region} : O.expr list =
(* TODO: should return a tuple *)
let () = ignore (lpar,rpar,region) in
match map s_expr (s_nsepseq sequence) with
[] -> [Constant Unit]
| [single_argument] -> [single_argument]
| args -> [s_tuple_expr args] ;
and s_fail ((kwd_fail, expr) : (I.kwd_fail * I.expr)) : O.instr =
let () = ignore (kwd_fail) in
Fail { expr = s_expr expr; orig = `TODO }
and s_single_instr : I.single_instr -> O.instr list = function
Cond {value; _} -> [s_conditional value]
| Match {value; _} -> [s_match_instr value]
| Ass instr -> [s_ass_instr instr]
| Loop loop -> s_loop loop
| ProcCall fun_call -> [ProcedureCall { expr = s_fun_call fun_call; orig = `TODO }]
| Null kwd_null -> let () = ignore (kwd_null) in
[]
| Fail {value; _} -> [s_fail value]
and s_block I.{value={opening;instr;terminator;close}; _} : O.instr list =
let () = ignore (opening,terminator,close) in
s_instructions instr
and gensym =
let i = ref 0 in
fun ty ->
i := !i + 1;
(* TODO: Region.ghost *)
({name = {name=(string_of_int !i) ^ "gensym"; orig = Region.ghost}; ty; orig = `TODO} : O.typed_var)
and s_fun_decl I.{value={kwd_function;name;param;colon;ret_type;kwd_is;local_decls;block;kwd_with;return;terminator}; region} : O.decl =
let () = ignore (kwd_function,colon,kwd_is,kwd_with,terminator,region) in
let tuple_type = s_parameters param |> parameters_to_tuple in
let single_argument = gensym tuple_type in
let ({name = single_argument_xxx; ty = _; orig = `TODO} : O.typed_var) = single_argument in
O.{
name = s_name name;
ty = type_expr region (Function { arg = tuple_type;
ret = s_type_expr ret_type });
value = Lambda {
parameter = single_argument;
declarations = append
(s_parameters param |> parameters_to_decls single_argument_xxx)
(map s_local_decl local_decls);
instructions = s_block block;
result = s_expr return
}
}
and s_proc_decl I.{value={kwd_procedure;name;param;kwd_is;local_decls;block;terminator}; region} =
let () = ignore (kwd_procedure,kwd_is,terminator,region) in
let tuple_type = s_parameters param |> parameters_to_tuple in
let single_argument = gensym tuple_type in
let ({name = single_argument_xxx; ty = _; orig = `TODO} : O.typed_var) = single_argument in
O.{
name = s_name name;
ty = type_expr region (Function { arg = tuple_type;
ret = type_expr region Unit });
value = Lambda {
parameter = single_argument;
declarations = append
(s_parameters param |> parameters_to_decls single_argument_xxx)
(map s_local_decl local_decls);
instructions = s_block block;
result = O.Constant O.Unit
}
}
and s_entry_decl I.{value={kwd_entrypoint;name;param;kwd_is;local_decls;block;terminator}; region} =
let () = ignore (kwd_entrypoint,kwd_is,terminator,region) in
let tuple_type = s_parameters param |> parameters_to_tuple in
let single_argument = gensym tuple_type in
let ({name = single_argument_xxx; ty = _; orig = `TODO} : O.typed_var) = single_argument in
O.{
name = s_name name;
ty = type_expr region (Function { arg = tuple_type;
ret = type_expr region Unit });
value = Lambda {
parameter = single_argument;
declarations = append
(s_parameters param |> parameters_to_decls single_argument_xxx)
(map s_local_decl local_decls);
instructions = s_block block;
result = O.Constant O.Unit
}
}
and s_lambda_decl : I.lambda_decl -> O.decl = function
FunDecl fun_decl -> s_fun_decl fun_decl
| EntryDecl entry_decl -> s_entry_decl entry_decl
| ProcDecl proc_decl -> s_proc_decl proc_decl
type tmp_ast = {
types : O.type_decl list;
storage_decl : O.typed_var option;
operations_decl : O.typed_var option;
declarations : O.decl list;
}
let s_declaration (ast : tmp_ast) : I.declaration -> tmp_ast = function
TypeDecl t -> { ast with types = (s_type_decl t) :: ast.types }
| ConstDecl c -> { ast with declarations = (s_const_decl c) :: ast.declarations }
| StorageDecl s -> { ast with storage_decl = Some (s_storage_decl s) }
| OpDecl o -> { ast with operations_decl = Some (s_operations_decl o) }
| LambdaDecl l -> { ast with declarations = (s_lambda_decl l) :: ast.declarations }
let s_ast (ast : I.ast) : O.ast =
let I.{decl=(decl1,decls);eof} = ast in
let () = ignore (eof) in
let {types; storage_decl; operations_decl; declarations} =
List.fold_left s_declaration
{ types = [];
storage_decl = None;
operations_decl = None;
declarations = [] }
( decl1 :: decls ) in
let storage_decl = match storage_decl with
Some x -> x
| None -> failwith "Missing storage declaration" in
let () = match operations_decl with
Some _ -> failwith "Operations declaration is not allowed anymore TODO"
| None -> ()
in {types; storage_decl; declarations; orig = ast}
(* let s_token region lexeme = *)
(* printf "%s: %s\n"(compact region) lexeme *)
(* and s_var {region; value=lexeme} = *)
(* printf "%s: Ident \"%s\"\n" (compact region) lexeme *)
(* and s_constr {region; value=lexeme} = *)
(* printf "%s: Constr \"%s\"\n" *)
(* (compact region) lexeme *)
(* and s_string {region; value=lexeme} = *)
(* printf "%s: String \"%s\"\n" *)
(* (compact region) lexeme *)
(* and s_bytes {region; value = lexeme, abstract} = *)
(* printf "%s: Bytes (\"%s\", \"0x%s\")\n" *)
(* (compact region) lexeme *)
(* (MBytes.to_hex abstract |> Hex.to_string) *)
(* and s_int {region; value = lexeme, abstract} = *)
(* printf "%s: Int (\"%s\", %s)\n" *)
(* (compact region) lexeme *)
(* (Z.to_string abstract) *)
(* and s_parameters {value=node; _} = *)
(* let lpar, sequence, rpar = node in *)
(* s_token lpar "("; *)
(* s_nsepseq ";" s_param_decl sequence; *)
(* s_token rpar ")" *)
(* and s_param_decl = function *)
(* ParamConst param_const -> s_param_const param_const *)
(* | ParamVar param_var -> s_param_var param_var *)
(* and s_region_cases {value=sequence; _} = *)
(* s_nsepseq "|" s_case sequence *)
(* and s_expr = function *)
(* Or {value = expr1, bool_or, expr2; _} -> *)
(* s_expr expr1; s_token bool_or "||"; s_expr expr2 *)
(* | And {value = expr1, bool_and, expr2; _} -> *)
(* s_expr expr1; s_token bool_and "&&"; s_expr expr2 *)
(* | Lt {value = expr1, lt, expr2; _} -> *)
(* s_expr expr1; s_token lt "<"; s_expr expr2 *)
(* | Leq {value = expr1, leq, expr2; _} -> *)
(* s_expr expr1; s_token leq "<="; s_expr expr2 *)
(* | Gt {value = expr1, gt, expr2; _} -> *)
(* s_expr expr1; s_token gt ">"; s_expr expr2 *)
(* | Geq {value = expr1, geq, expr2; _} -> *)
(* s_expr expr1; s_token geq ">="; s_expr expr2 *)
(* | Equal {value = expr1, equal, expr2; _} -> *)
(* s_expr expr1; s_token equal "="; s_expr expr2 *)
(* | Neq {value = expr1, neq, expr2; _} -> *)
(* s_expr expr1; s_token neq "=/="; s_expr expr2 *)
(* | Cat {value = expr1, cat, expr2; _} -> *)
(* s_expr expr1; s_token cat "^"; s_expr expr2 *)
(* | Cons {value = expr1, cons, expr2; _} -> *)
(* s_expr expr1; s_token cons "<:"; s_expr expr2 *)
(* | Add {value = expr1, add, expr2; _} -> *)
(* s_expr expr1; s_token add "+"; s_expr expr2 *)
(* | Sub {value = expr1, sub, expr2; _} -> *)
(* s_expr expr1; s_token sub "-"; s_expr expr2 *)
(* | Mult {value = expr1, mult, expr2; _} -> *)
(* s_expr expr1; s_token mult "*"; s_expr expr2 *)
(* | Div {value = expr1, div, expr2; _} -> *)
(* s_expr expr1; s_token div "/"; s_expr expr2 *)
(* | Mod {value = expr1, kwd_mod, expr2; _} -> *)
(* s_expr expr1; s_token kwd_mod "mod"; s_expr expr2 *)
(* | Neg {value = minus, expr; _} -> *)
(* s_token minus "-"; s_expr expr *)
(* | Not {value = kwd_not, expr; _} -> *)
(* s_token kwd_not "not"; s_expr expr *)
(* | Int i -> s_int i *)
(* | Var var -> s_var var *)
(* | String s -> s_string s *)
(* | Bytes b -> s_bytes b *)
(* | False region -> s_token region "False" *)
(* | True region -> s_token region "True" *)
(* | Unit region -> s_token region "Unit" *)
(* | Tuple tuple -> s_tuple tuple *)
(* | List list -> s_list list *)
(* | EmptyList elist -> s_empty_list elist *)
(* | Set set -> s_set set *)
(* | EmptySet eset -> s_empty_set eset *)
(* | NoneExpr nexpr -> s_none_expr nexpr *)
(* | FunCall fun_call -> s_fun_call fun_call *)
(* | ConstrApp capp -> s_constr_app capp *)
(* | SomeApp sapp -> s_some_app sapp *)
(* | MapLookUp lookup -> s_map_lookup lookup *)
(* | ParExpr pexpr -> s_par_expr pexpr *)
(* and s_list {value=node; _} = *)
(* let lbra, sequence, rbra = node in *)
(* s_token lbra "["; *)
(* s_nsepseq "," s_expr sequence; *)
(* s_token rbra "]" *)
(* and s_empty_list {value=node; _} = *)
(* let lpar, (lbracket, rbracket, colon, type_expr), rpar = node in *)
(* s_token lpar "("; *)
(* s_token lbracket "["; *)
(* s_token rbracket "]"; *)
(* s_token colon ":"; *)
(* s_type_expr type_expr; *)
(* s_token rpar ")" *)
(* and s_set {value=node; _} = *)
(* let lbrace, sequence, rbrace = node in *)
(* s_token lbrace "{"; *)
(* s_nsepseq "," s_expr sequence; *)
(* s_token rbrace "}" *)
(* and s_empty_set {value=node; _} = *)
(* let lpar, (lbrace, rbrace, colon, type_expr), rpar = node in *)
(* s_token lpar "("; *)
(* s_token lbrace "{"; *)
(* s_token rbrace "}"; *)
(* s_token colon ":"; *)
(* s_type_expr type_expr; *)
(* s_token rpar ")" *)
(* and s_none_expr {value=node; _} = *)
(* let lpar, (c_None, colon, type_expr), rpar = node in *)
(* s_token lpar "("; *)
(* s_token c_None "None"; *)
(* s_token colon ":"; *)
(* s_type_expr type_expr; *)
(* s_token rpar ")" *)
(* and s_constr_app {value=node; _} = *)
(* let constr, arguments = node in *)
(* s_constr constr; *)
(* s_tuple arguments *)
(* and s_some_app {value=node; _} = *)
(* let c_Some, arguments = node in *)
(* s_token c_Some "Some"; *)
(* s_tuple arguments *)
(* and s_par_expr {value=node; _} = *)
(* let lpar, expr, rpar = node in *)
(* s_token lpar "("; *)
(* s_expr expr; *)
(* s_token rpar ")" *)
(* and s_psome {value=node; _} = *)
(* let c_Some, patterns = node in *)
(* s_token c_Some "Some"; *)
(* s_patterns patterns *)
(* and s_terminator = function *)
(* Some semi -> s_token semi ";" *)
(* | None -> () *)
*)

7
src/ligo/ligo-parser/LexToken.mli
View File

@ -67,26 +67,33 @@ type t =
| And of Region.t (* "and" *)
| Begin of Region.t (* "begin" *)
| Block of Region.t (* "block" *)
| Case of Region.t (* "case" *)
| Const of Region.t (* "const" *)
| Contains of Region.t (* "contains" *)
| Down of Region.t (* "down" *)
| Else of Region.t (* "else" *)
| End of Region.t (* "end" *)
| Entrypoint of Region.t (* "entrypoint" *)
| Fail of Region.t (* "fail" *)
| For of Region.t (* "for" *)
| From of Region.t (* "from" *)
| Function of Region.t (* "function" *)
| If of Region.t (* "if" *)
| In of Region.t (* "in" *)
| Is of Region.t (* "is" *)
| List of Region.t (* "list" *)
| Map of Region.t (* "map" *)
| Mod of Region.t (* "mod" *)
| Nil of Region.t (* "nil" *)
| Not of Region.t (* "not" *)
| Of of Region.t (* "of" *)
| Or of Region.t (* "or" *)
| Patch of Region.t (* "patch" *)
| Procedure of Region.t (* "procedure" *)
| Record of Region.t (* "record" *)
| Remove of Region.t (* "remove" *)
| Set of Region.t (* "set" *)
| Skip of Region.t (* "skip" *)
| Step of Region.t (* "step" *)
| Storage of Region.t (* "storage" *)

141
src/ligo/ligo-parser/LexToken.mll
View File

@ -66,26 +66,33 @@ type t =
| And of Region.t (* "and" *)
| Begin of Region.t (* "begin" *)
| Block of Region.t (* "block" *)
| Case of Region.t (* "case" *)
| Const of Region.t (* "const" *)
| Contains of Region.t (* "contains" *)
| Down of Region.t (* "down" *)
| Else of Region.t (* "else" *)
| End of Region.t (* "end" *)
| Entrypoint of Region.t (* "entrypoint" *)
| Fail of Region.t (* "fail" *)
| For of Region.t (* "for" *)
| From of Region.t (* "from" *)
| Function of Region.t (* "function" *)
| If of Region.t (* "if" *)
| In of Region.t (* "in" *)
| Is of Region.t (* "is" *)
| List of Region.t (* "list" *)
| Map of Region.t (* "map" *)
| Mod of Region.t (* "mod" *)
| Nil of Region.t (* "nil" *)
| Not of Region.t (* "not" *)
| Of of Region.t (* "of" *)
| Or of Region.t (* "or" *)
| Patch of Region.t (* "patch" *)
| Procedure of Region.t (* "procedure" *)
| Record of Region.t (* "record" *)
| Remove of Region.t (* "remove" *)
| Set of Region.t (* "set" *)
| Skip of Region.t (* "skip" *)
| Step of Region.t (* "step" *)
| Storage of Region.t (* "storage" *)
@ -186,26 +193,33 @@ let proj_token = function
| And region -> region, "And"
| Begin region -> region, "Begin"
| Block region -> region, "Block"
| Case region -> region, "Case"
| Const region -> region, "Const"
| Contains region -> region, "Contains"
| Down region -> region, "Down"
| Else region -> region, "Else"
| End region -> region, "End"
| Entrypoint region -> region, "Entrypoint"
| Fail region -> region, "Fail"
| For region -> region, "For"
| From region -> region, "From"
| Function region -> region, "Function"
| If region -> region, "If"
| In region -> region, "In"
| Is region -> region, "Is"
| List region -> region, "List"
| Map region -> region, "Map"
| Mod region -> region, "Mod"
| Nil region -> region, "Nil"
| Not region -> region, "Not"
| Of region -> region, "Of"
| Or region -> region, "Or"
| Patch region -> region, "Patch"
| Procedure region -> region, "Procedure"
| Record region -> region, "Record"
| Remove region -> region, "Remove"
| Set region -> region, "Set"
| Skip region -> region, "Skip"
| Step region -> region, "Step"
| Storage region -> region, "Storage"
@ -271,33 +285,40 @@ let to_lexeme = function
| And _ -> "and"
| Begin _ -> "begin"
| Block _ -> "block"
| Case _ -> "case"
| Const _ -> "const"
| Contains _ -> "contains"
| Down _ -> "down"
| Else _ -> "else"
| End _ -> "end"
| Entrypoint _ -> "entrypoint"
| Fail _ -> "fail"
| For _ -> "for"
| From _ -> "from"
| Function _ -> "function"
| If _ -> "if"
| In _ -> "in"
| Is _ -> "is"
| Entrypoint _ -> "entrypoint"
| For _ -> "for"
| Function _ -> "function"
| Type _ -> "type"
| List _ -> "list"
| Map _ -> "map"
| Mod _ -> "mod"
| Nil _ -> "nil"
| Not _ -> "not"
| Of _ -> "of"
| Or _ -> "or"
| Var _ -> "var"
| End _ -> "end"
| Then _ -> "then"
| Else _ -> "else"
| Map _ -> "map"
| Patch _ -> "patch"
| Procedure _ -> "procedure"
| Record _ -> "record"
| Remove _ -> "remove"
| Set _ -> "set"
| Skip _ -> "skip"
| Step _ -> "step"
| Storage _ -> "storage"
| Then _ -> "then"
| To _ -> "to"
| Mod _ -> "mod"
| Not _ -> "not"
| Type _ -> "type"
| Var _ -> "var"
| While _ -> "while"
| With _ -> "with"
@ -326,78 +347,47 @@ let to_region token = proj_token token |> fst
let keywords = [
(fun reg -> And reg);
(fun reg -> Begin reg);
(fun reg -> Block reg);
(fun reg -> Case reg);
(fun reg -> Const reg);
(fun reg -> Contains reg);
(fun reg -> Down reg);
(fun reg -> Else reg);
(fun reg -> End reg);
(fun reg -> Entrypoint reg);
(fun reg -> For reg);
(fun reg -> From reg);
(fun reg -> Function reg);
(fun reg -> Fail reg);
(fun reg -> If reg);
(fun reg -> In reg);
(fun reg -> Is reg);
(fun reg -> Entrypoint reg);
(fun reg -> For reg);
(fun reg -> Function reg);
(fun reg -> Type reg);
(fun reg -> List reg);
(fun reg -> Map reg);
(fun reg -> Mod reg);
(fun reg -> Nil reg);
(fun reg -> Not reg);
(fun reg -> Of reg);
(fun reg -> Or reg);
(fun reg -> Var reg);
(fun reg -> End reg);
(fun reg -> Then reg);
(fun reg -> Else reg);
(fun reg -> Map reg);
(fun reg -> Patch reg);
(fun reg -> Procedure reg);
(fun reg -> Record reg);
(fun reg -> Remove reg);
(fun reg -> Set reg);
(fun reg -> Skip reg);
(fun reg -> Step reg);
(fun reg -> Storage reg);
(fun reg -> Then reg);
(fun reg -> To reg);
(fun reg -> Mod reg);
(fun reg -> Not reg);
(fun reg -> Type reg);
(fun reg -> Var reg);
(fun reg -> While reg);
(fun reg -> With reg)
]
let reserved =
let open SSet in
empty |> add "as"
|> add "asr"
|> add "assert"
|> add "class"
|> add "constraint"
|> add "do"
|> add "done"
|> add "downto"
|> add "exception"
|> add "external"
|> add "false"
|> add "fun"
|> add "functor"
|> add "include"
|> add "inherit"
|> add "initializer"
|> add "land"
|> add "lazy"
|> add "let"
|> add "lor"
|> add "lsl"
|> add "lsr"
|> add "lxor"
|> add "method"
|> add "module"
|> add "mutable"
|> add "new"
|> add "nonrec"
|> add "object"
|> add "open"
|> add "private"
|> add "rec"
|> add "sig"
|> add "struct"
|> add "true"
|> add "try"
|> add "val"
|> add "virtual"
|> add "when"
empty |> add "args"
let constructors = [
(fun reg -> C_False reg);
@ -549,33 +539,40 @@ let is_ident = function
let is_kwd = function
And _
| Begin _
| Block _
| Case _
| Const _
| Contains _
| Down _
| Else _
| End _
| Entrypoint _
| Fail _
| For _
| From _
| Function _
| If _
| In _
| Is _
| Entrypoint _
| For _
| Function _
| Type _
| List _
| Map _
| Mod _
| Nil _
| Not _
| Of _
| Or _
| Var _
| End _
| Then _
| Else _
| Map _
| Patch _
| Procedure _
| Record _
| Remove _
| Set _
| Skip _
| Step _
| Storage _
| Then _
| To _
| Mod _
| Not _
| Type _
| Var _
| While _
| With _ -> true
| _ -> false

3
src/ligo/ligo-parser/Lexer.mll
View File

@ -459,8 +459,7 @@ let byte_seq = byte | byte (byte | '_')* byte
let bytes = "0x" (byte_seq? as seq)
let esc = "\\n" | "\\\"" | "\\\\" | "\\b"
| "\\r" | "\\t" | "\\x" byte
let symbol = ';' | ','
| '(' | ')' | '{' | '}' | '[' | ']'
let symbol = ';' | ',' | '(' | ')'| '[' | ']' | '{' | '}'
| '#' | '|' | "->" | ":=" | '=' | ':'
| '<' | "<=" | '>' | ">=" | "=/="
| '+' | '-' | '*' | '.' | '_' | '^'

6
src/ligo/ligo-parser/MBytes.ml
View File

@ -1,6 +0,0 @@
(* TEMPORARY: SHOULD BE ERASED *)
type t = Hex.t
let of_hex x = x
let to_hex x = x

6
src/ligo/ligo-parser/MBytes.mli
View File

@ -1,6 +0,0 @@
(* TEMPORARY: SHOULD BE ERASED *)
type t
val of_hex : Hex.t -> t
val to_hex : t -> Hex.t

29
src/ligo/ligo-parser/ParToken.mly
View File

@ -44,33 +44,40 @@
%token <Region.t> And (* "and" *)
%token <Region.t> Begin (* "begin" *)
%token <Region.t> Block (* "block" *)
%token <Region.t> Case (* "case" *)
%token <Region.t> Const (* "const" *)
%token <Region.t> Contains (* "contains" *)
%token <Region.t> Down (* "down" *)
%token <Region.t> Else (* "else" *)
%token <Region.t> End (* "end" *)
%token <Region.t> Entrypoint (* "entrypoint" *)
%token <Region.t> Fail (* "fail" *)
%token <Region.t> For (* "for" *)
%token <Region.t> Function (* "function" *)
%token <Region.t> From (* "from" *)
%token <Region.t> If (* "if" *)
%token <Region.t> In (* "in" *)
%token <Region.t> Is (* "is" *)
%token <Region.t> Entrypoint (* "entrypoint" *)
%token <Region.t> For (* "for" *)
%token <Region.t> Function (* "function" *)
%token <Region.t> Type (* "type" *)
%token <Region.t> List (* "list" *)
%token <Region.t> Map (* "map" *)
%token <Region.t> Mod (* "mod" *)
%token <Region.t> Nil (* "nil" *)
%token <Region.t> Not (* "not" *)
%token <Region.t> Of (* "of" *)
%token <Region.t> Or (* "or" *)
%token <Region.t> Var (* "var" *)
%token <Region.t> End (* "end" *)
%token <Region.t> Then (* "then" *)
%token <Region.t> Else (* "else" *)
%token <Region.t> Map (* "map" *)
%token <Region.t> Patch (* "patch" *)
%token <Region.t> Procedure (* "procedure" *)
%token <Region.t> Record (* "record" *)
%token <Region.t> Remove (* "remove" *)
%token <Region.t> Set (* "set" *)
%token <Region.t> Skip (* "skip" *)
%token <Region.t> Step (* "step" *)
%token <Region.t> Storage (* "storage" *)
%token <Region.t> Then (* "then" *)
%token <Region.t> To (* "to" *)
%token <Region.t> Mod (* "mod" *)
%token <Region.t> Not (* "not" *)
%token <Region.t> Type (* "type" *)
%token <Region.t> Var (* "var" *)
%token <Region.t> While (* "while" *)
%token <Region.t> With (* "with" *)

629
src/ligo/ligo-parser/Parser.mly
View File

@ -21,32 +21,32 @@ open AST
(* RULES *)
(* The rule [series(Item)] parses a list of [Item] separated by
semi-colons and optionally terminated by a semi-colon, then the
keyword [End]. *)
(* The rule [series(Item,TERM)] parses a list of [Item] separated by
semicolons and optionally terminated by a semicolon, then the
terminal TERM. *)
series(Item):
Item after_item(Item) { $1,$2 }
series(Item,TERM):
Item after_item(Item,TERM) { $1,$2 }
after_item(Item):
SEMI item_or_end(Item) {
after_item(Item,TERM):
SEMI item_or_closing(Item,TERM) {
match $2 with
`Some (item, items, term, close) ->
($1, item)::items, term, close
| `End close ->
[], Some $1, close
`Some (item, items, term, closing) ->
($1, item)::items, term, closing
| `Closing closing ->
[], Some $1, closing
}
| End {
| TERM {
[], None, $1
}
item_or_end(Item):
End {
`End $1
item_or_closing(Item,TERM):
TERM {
`Closing $1
}
| series(Item) {
let item, (items, term, close) = $1
in `Some (item, items, term, close)
| series(Item,TERM) {
let item, (items, term, closing) = $1
in `Some (item, items, term, closing)
}
(* Compound constructs *)
@ -61,20 +61,10 @@ par(X):
in {region; value}
}
braces(X):
LBRACE X RBRACE {
let region = cover $1 $3
and value = {
lbrace = $1;
inside = $2;
rbrace = $3}
in {region; value}
}
brackets(X):
LBRACKET X RBRACKET {
let region = cover $1 $3
and value = {
and value = {
lbracket = $1;
inside = $2;
rbracket = $3}
@ -135,9 +125,9 @@ contract:
}
declaration:
type_decl { TypeDecl $1 }
| const_decl { ConstDecl $1 }
| lambda_decl { LambdaDecl $1 }
type_decl { TypeDecl $1 }
| const_decl { ConstDecl $1 }
| lambda_decl { LambdaDecl $1 }
(* Type declarations *)
@ -164,8 +154,7 @@ type_expr:
cartesian:
nsepseq(core_type,TIMES) {
let region = nsepseq_to_region type_expr_to_region $1
in {region; value=$1}
}
in {region; value=$1}}
core_type:
type_name {
@ -177,12 +166,25 @@ core_type:
}
| Map type_tuple {
let region = cover $1 $2.region in
let value = {value="map"; region=$1}
in TApp {region; value = value, $2}
let type_constr = {value="map"; region=$1}
in TApp {region; value = type_constr, $2}
}
| Set par(type_expr) {
let total = cover $1 $2.region in
let type_constr = {value="set"; region=$1} in
let {region; value = {lpar; inside; rpar}} = $2 in
let tuple = {region; value={lpar; inside=inside,[]; rpar}}
in TApp {region=total; value = type_constr, tuple}
}
| List par(type_expr) {
let total = cover $1 $2.region in
let type_constr = {value="list"; region=$1} in
let {region; value = {lpar; inside; rpar}} = $2 in
let tuple = {region; value={lpar; inside=inside,[]; rpar}}
in TApp {region=total; value = type_constr, tuple}
}
| par(type_expr) {
TPar $1
}
TPar $1}
type_tuple:
par(nsepseq(type_expr,COMMA)) { $1 }
@ -190,39 +192,37 @@ type_tuple:
sum_type:
nsepseq(variant,VBAR) {
let region = nsepseq_to_region (fun x -> x.region) $1
in {region; value = $1}
}
in {region; value = $1}}
variant:
Constr Of cartesian {
let region = cover $1.region $3.region
and value = {constr = $1; kwd_of = $2; product = $3}
in {region; value}
}
in {region; value}}
record_type:
Record
nsepseq(field_decl,SEMI)
End
{
let region = cover $1 $3
and value = {kwd_record = $1; fields = $2; kwd_end = $3}
in {region; value}
}
Record series(field_decl,End) {
let first, (others, terminator, closing) = $2 in
let region = cover $1 closing
and value = {
opening = $1;
field_decls = first, others;
terminator;
closing}
in {region; value}}
field_decl:
field_name COLON type_expr {
let stop = type_expr_to_region $3 in
let region = cover $1.region stop
and value = {field_name = $1; colon = $2; field_type = $3}
in {region; value}
}
in {region; value}}
(* Function and procedure declarations *)
lambda_decl:
fun_decl { FunDecl $1 }
| proc_decl { ProcDecl $1 }
fun_decl { FunDecl $1 }
| proc_decl { ProcDecl $1 }
| entry_decl { EntryDecl $1 }
fun_decl:
@ -234,8 +234,8 @@ fun_decl:
match $11 with
Some region -> region
| None -> expr_to_region $10 in
let region = cover $1 stop in
let value = {
let region = cover $1 stop
and value = {
kwd_function = $1;
name = $2;
param = $3;
@ -247,8 +247,7 @@ fun_decl:
kwd_with = $9;
return = $10;
terminator = $11}
in {region; value}
}
in {region; value}}
entry_decl:
Entrypoint fun_name entry_params COLON type_expr Is
@ -259,8 +258,8 @@ entry_decl:
match $11 with
Some region -> region
| None -> expr_to_region $10 in
let region = cover $1 stop in
let value = {
let region = cover $1 stop
and value = {
kwd_entrypoint = $1;
name = $2;
param = $3;
@ -272,8 +271,7 @@ entry_decl:
kwd_with = $9;
return = $10;
terminator = $11}
in {region; value}
}
in {region; value}}
entry_params:
par(nsepseq(entry_param_decl,SEMI)) { $1 }
@ -287,8 +285,8 @@ proc_decl:
match $7 with
Some region -> region
| None -> $6.region in
let region = cover $1 stop in
let value = {
let region = cover $1 stop
and value = {
kwd_procedure = $1;
name = $2;
param = $3;
@ -296,14 +294,13 @@ proc_decl:
local_decls = $5;
block = $6;
terminator = $7}
in {region; value}
}
in {region; value}}
parameters:
par(nsepseq(param_decl,SEMI)) { $1 }
param_decl:
Var var COLON type_expr {
Var var COLON param_type {
let stop = type_expr_to_region $4 in
let region = cover $1 stop
and value = {
@ -313,7 +310,7 @@ param_decl:
param_type = $4}
in ParamVar {region; value}
}
| Const var COLON type_expr {
| Const var COLON param_type {
let stop = type_expr_to_region $4 in
let region = cover $1 stop
and value = {
@ -321,8 +318,7 @@ param_decl:
var = $2;
colon = $3;
param_type = $4}
in ParamConst {region; value}
}
in ParamConst {region; value}}
entry_param_decl:
param_decl {
@ -330,7 +326,7 @@ entry_param_decl:
ParamConst const -> EntryConst const
| ParamVar var -> EntryVar var
}
| Storage var COLON type_expr {
| Storage var COLON param_type {
let stop = type_expr_to_region $4 in
let region = cover $1 stop
and value = {
@ -338,46 +334,101 @@ entry_param_decl:
var = $2;
colon = $3;
storage_type = $4}
in EntryStore {region; value}
in EntryStore {region; value}}
param_type:
nsepseq(core_param_type,TIMES) {
let region = nsepseq_to_region type_expr_to_region $1
in TProd {region; value=$1}}
core_param_type:
type_name {
TAlias $1
}
| type_name type_tuple {
let region = cover $1.region $2.region
in TApp {region; value = $1,$2}}
block:
Begin series(instruction) {
let first, (others, terminator, close) = $2 in
let region = cover $1 close
Begin series(statement,End) {
let first, (others, terminator, closing) = $2 in
let region = cover $1 closing
and value = {
opening = $1;
instr = first, others;
opening = Begin $1;
statements = first, others;
terminator;
close}
closing = End closing}
in {region; value}
}
| Block LBRACE series(statement,RBRACE) {
let first, (others, terminator, closing) = $3 in
let region = cover $1 closing
and value = {
opening = Block ($1,$2);
statements = first, others;
terminator;
closing = Block closing}
in {region; value}}
statement:
instruction { Instr $1 }
| open_data_decl { Data $1 }
open_data_decl:
open_const_decl { LocalConst $1 }
| open_var_decl { LocalVar $1 }
open_const_decl:
Const unqualified_decl(EQUAL) {
let name, colon, const_type, equal, init, stop = $2 in
let region = cover $1 stop
and value = {
kwd_const = $1;
name;
colon;
const_type;
equal;
init;
terminator = None}
in {region; value}}
open_var_decl:
Var unqualified_decl(ASS) {
let name, colon, var_type, assign, init, stop = $2 in
let region = cover $1 stop
and value = {
kwd_var = $1;
name;
colon;
var_type;
assign;
init;
terminator = None}
in {region; value}}
local_decl:
lambda_decl { LocalLam $1 }
| const_decl { LocalConst $1 }
| var_decl { LocalVar $1 }
lambda_decl { LocalLam $1 }
| data_decl { LocalData $1 }
data_decl:
const_decl { LocalConst $1 }
| var_decl { LocalVar $1 }
unqualified_decl(OP):
var COLON type_expr OP extended_expr option(SEMI) {
let stop = match $6 with
Some region -> region
| None -> $5.region in
let init =
match $5.value with
`Expr e -> e
| `EList (lbracket, rbracket) ->
let region = $5.region
and value = {
lbracket;
rbracket;
var COLON type_expr OP extended_expr {
let init, region =
match $5 with
`Expr e -> e, expr_to_region e
| `EList kwd_nil ->
let value = {
nil = kwd_nil;
colon = Region.ghost;
list_type = $3} in
let value = {
lpar = Region.ghost;
inside = value;
rpar = Region.ghost} in
EList (EmptyList {region; value})
EList (Nil {region=kwd_nil; value}), kwd_nil
| `ENone region ->
let value = {
lpar = Region.ghost;
@ -386,56 +437,49 @@ unqualified_decl(OP):
colon = Region.ghost;
opt_type = $3};
rpar = Region.ghost}
in EConstr (NoneExpr {region; value})
| `EMap inj ->
EMap (MapInj inj)
in $1, $2, $3, $4, init, $6, stop
}
in EConstr (NoneExpr {region; value}), region
in $1, $2, $3, $4, init, region}
const_decl:
Const unqualified_decl(EQUAL) {
let name, colon, const_type, equal,
init, terminator, stop = $2 in
let region = cover $1 stop in
let value = {
Const unqualified_decl(EQUAL) SEMI {
let name, colon, const_type, equal, init, _ = $2 in
let region = cover $1 $3
and value = {
kwd_const = $1;
name;
colon;
const_type;
equal;
init;
terminator}
terminator = Some $3}
in {region; value}
}
| open_const_decl { $1 }
var_decl:
Var unqualified_decl(ASS) {
let name, colon, var_type, assign,
init, terminator, stop = $2 in
let region = cover $1 stop in
let value = {
Var unqualified_decl(ASS) SEMI {
let name, colon, var_type, assign, init, _ = $2 in
let region = cover $1 $3
and value = {
kwd_var = $1;
name;
colon;
var_type;
assign;
init;
terminator}
terminator = Some $3}
in {region; value}
}
| open_var_decl { $1 }
extended_expr:
expr { {region = expr_to_region $1;
value = `Expr $1} }
| LBRACKET RBRACKET { {region = cover $1 $2;
value = `EList ($1,$2)} }
| C_None { {region = $1; value = `ENone $1} }
| map_injection { {region = $1.region; value = `EMap $1} }
expr { `Expr $1 }
| Nil { `EList $1 }
| C_None { `ENone $1 }
instruction:
single_instr { Single $1 }
| block { Block $1 }
| block { Block $1 : instruction }
single_instr:
conditional { Cond $1 }
@ -447,6 +491,41 @@ single_instr:
| Skip { Skip $1 }
| record_patch { RecordPatch $1 }
| map_patch { MapPatch $1 }
| set_patch { SetPatch $1 }
| map_remove { MapRemove $1 }
| set_remove { SetRemove $1 }
set_remove:
Remove expr From Set path {
let region = cover $1 (path_to_region $5) in
let value = {
kwd_remove = $1;
element = $2;
kwd_from = $3;
kwd_set = $4;
set = $5}
in {region; value}}
map_remove:
Remove expr From Map path {
let region = cover $1 (path_to_region $5) in
let value = {
kwd_remove = $1;
key = $2;
kwd_from = $3;
kwd_map = $4;
map = $5}
in {region; value}}
set_patch:
Patch path With injection(Set,expr) {
let region = cover $1 $4.region in
let value = {
kwd_patch = $1;
path = $2;
kwd_with = $3;
set_inj = $4}
in {region; value}}
map_patch:
Patch path With map_injection {
@ -456,20 +535,85 @@ map_patch:
path = $2;
kwd_with = $3;
map_inj = $4}
in {region; value}}
injection(Kind,element):
Kind series(element,End) {
let first, (others, terminator, closing) = $2 in
let region = cover $1 closing
and value = {
opening = Kwd $1;
elements = Some (first, others);
terminator;
closing = End closing}
in {region; value}
}
| Kind End {
let region = cover $1 $2
and value = {
opening = Kwd $1;
elements = None;
terminator = None;
closing = End $2}
in {region; value}
}
| Kind LBRACKET series(element,RBRACKET) {
let first, (others, terminator, closing) = $3 in
let region = cover $1 closing
and value = {
opening = KwdBracket ($1,$2);
elements = Some (first, others);
terminator;
closing = RBracket closing}
in {region; value}
}
| Kind LBRACKET RBRACKET {
let region = cover $1 $3
and value = {
opening = KwdBracket ($1,$2);
elements = None;
terminator = None;
closing = RBracket $3}
in {region; value}}
map_injection:
Map series(binding) {
let first, (others, terminator, close) = $2 in
let region = cover $1 close
Map series(binding,End) {
let first, (others, terminator, closing) = $2 in
let region = cover $1 closing
and value = {
opening = $1;
bindings = first, others;
opening = Kwd $1;
elements = Some (first, others);
terminator;
close}
closing = End closing}
in {region; value}
}
| Map End {
let region = cover $1 $2
and value = {
opening = Kwd $1;
elements = None;
terminator = None;
closing = End $2}
in {region; value}
}
| Map LBRACKET series(binding,RBRACKET) {
let first, (others, terminator, closing) = $3 in
let region = cover $1 closing
and value = {
opening = KwdBracket ($1,$2);
elements = Some (first, others);
terminator;
closing = RBracket closing}
in {region; value}
}
| Map LBRACKET RBRACKET {
let region = cover $1 $3
and value = {
opening = KwdBracket ($1,$2);
elements = None;
terminator = None;
closing = RBracket $3}
in {region; value}}
binding:
expr ARROW expr {
@ -480,8 +624,7 @@ binding:
source = $1;
arrow = $2;
image = $3}
in {region; value}
}
in {region; value}}
record_patch:
Patch path With record_injection {
@ -491,8 +634,7 @@ record_patch:
path = $2;
kwd_with = $3;
record_inj = $4}
in {region; value}
}
in {region; value}}
fail_instr:
Fail expr {
@ -504,17 +646,30 @@ proc_call:
fun_call { $1 }
conditional:
If expr Then instruction Else instruction {
let region = cover $1 (instr_to_region $6) in
If expr Then if_clause option(SEMI) Else if_clause {
let region = cover $1 (if_clause_to_region $7) in
let value = {
kwd_if = $1;
test = $2;
kwd_then = $3;
ifso = $4;
kwd_else = $5;
ifnot = $6}
in {region; value}
kwd_if = $1;
test = $2;
kwd_then = $3;
ifso = $4;
terminator = $5;
kwd_else = $6;
ifnot = $7}
in {region; value}}
if_clause:
instruction {
ClauseInstr $1
}
| LBRACE series(statement,RBRACE) {
let first, (others, terminator, closing) = $2 in
let region = cover $1 closing in
let value = {
lbrace = $1;
inside = (first, others), terminator;
rbrace = closing} in
ClauseBlock {value; region}}
case_instr:
Case expr Of option(VBAR) cases End {
@ -526,29 +681,25 @@ case_instr:
lead_vbar = $4;
cases = $5;
kwd_end = $6}
in {region; value}
}
in {region; value}}
cases:
nsepseq(case,VBAR) {
let region = nsepseq_to_region (fun x -> x.region) $1
in {region; value = $1}
}
in {region; value = $1}}
case:
pattern ARROW instruction {
let region = cover (pattern_to_region $1) (instr_to_region $3)
and value = {pattern = $1; arrow = $2; instr = $3}
in {region; value}
}
in {region; value}}
assignment:
lhs ASS rhs {
let stop = rhs_to_region $3 in
let region = cover (lhs_to_region $1) stop
and value = {lhs = $1; assign = $2; rhs = $3}
in {region; value}
}
in {region; value}}
rhs:
expr { Expr $1 }
@ -569,20 +720,19 @@ while_loop:
kwd_while = $1;
cond = $2;
block = $3}
in While {region; value}
}
in While {region; value}}
for_loop:
For var_assign Down? To expr option(step_clause) block {
let region = cover $1 $7.region in
let value = {
kwd_for = $1;
assign = $2;
down = $3;
kwd_to = $4;
bound = $5;
step = $6;
block = $7}
kwd_for = $1;
assign = $2;
down = $3;
kwd_to = $4;
bound = $5;
step = $6;
block = $7}
in For (ForInt {region; value})
}
| For var option(arrow_clause) In expr block {
@ -594,15 +744,13 @@ for_loop:
kwd_in = $4;
expr = $5;
block = $6}
in For (ForCollect {region; value})
}
in For (ForCollect {region; value})}
var_assign:
var ASS expr {
let region = cover $1.region (expr_to_region $3)
and value = {name = $1; assign = $2; expr = $3}
in {region; value}
}
in {region; value}}
step_clause:
Step expr { $1,$2 }
@ -626,13 +774,26 @@ expr:
| conj_expr { $1 }
conj_expr:
conj_expr And comp_expr {
conj_expr And set_membership {
let start = expr_to_region $1
and stop = expr_to_region $3 in
let region = cover start stop
and value = {arg1 = $1; op = $2; arg2 = $3}
in ELogic (BoolExpr (And {region; value}))
}
| set_membership { $1 }
set_membership:
core_expr Contains set_membership {
let start = expr_to_region $1
and stop = expr_to_region $3 in
let region = cover start stop in
let value = {
set = $1;
kwd_contains = $2;
element = $3}
in ESet (SetMem {region; value})
}
| comp_expr { $1 }
comp_expr:
@ -757,62 +918,73 @@ unary_expr:
| core_expr { $1 }
core_expr:
Int { EArith (Int $1) }
| var { EVar $1 }
| String { EString (String $1) }
| Bytes { EBytes $1 }
Int { EArith (Int $1) }
| var { EVar $1 }
| String { EString (String $1) }
| Bytes { EBytes $1 }
| C_False { ELogic (BoolExpr (False $1)) }
| C_True { ELogic (BoolExpr (True $1)) }
| C_Unit { EUnit $1 }
| tuple { ETuple $1 }
| list_expr { EList (List $1) }
| empty_list { EList (EmptyList $1) }
| set_expr { ESet (Set $1) }
| empty_set { ESet (EmptySet $1) }
| none_expr { EConstr (NoneExpr $1) }
| fun_call { ECall $1 }
| map_expr { EMap $1 }
| record_expr { ERecord $1 }
| C_True { ELogic (BoolExpr (True $1)) }
| C_Unit { EUnit $1 }
| tuple_expr { ETuple $1 }
| list_expr { EList $1 }
| none_expr { EConstr (NoneExpr $1) }
| fun_call { ECall $1 }
| map_expr { EMap $1 }
| set_expr { ESet $1 }
| record_expr { ERecord $1 }
| projection { EProj $1 }
| Constr arguments {
let region = cover $1.region $2.region in
EConstr (ConstrApp {region; value = $1,$2})
}
| C_Some arguments {
let region = cover $1 $2.region in
EConstr (SomeApp {region; value = $1,$2})
}
EConstr (SomeApp {region; value = $1,$2})}
set_expr:
injection(Set,expr) { SetInj $1 }
map_expr:
map_lookup { MapLookUp $1 }
path:
var { Name $1 }
| record_projection { RecordPath $1 }
map_lookup { MapLookUp $1 }
| map_injection { MapInj $1 }
map_lookup:
path brackets(expr) {
let region = cover (path_to_region $1) $2.region in
let value = {
path = $1;
index = $2}
in {region; value}
}
let value = {path=$1; index=$2}
in {region; value}}
path:
var { Name $1 }
| projection { Path $1 }
record_expr:
record_injection { RecordInj $1 }
| record_projection { RecordProj $1 }
record_injection { RecordInj $1 }
projection:
record_name DOT nsepseq(selection,DOT) {
let stop = nsepseq_to_region selection_to_region $3 in
let region = cover $1.region stop
and value = {
record_name = $1;
selector = $2;
field_path = $3}
in {region; value}}
selection:
field_name { FieldName $1 }
| Int { Component $1 }
record_injection:
Record series(field_assignment) {
let first, (others, terminator, close) = $2 in
let region = cover $1 close
Record series(field_assignment,End) {
let first, (others, terminator, closing) = $2 in
let region = cover $1 closing
and value = {
opening = $1;
fields = first, others;
terminator;
close}
in {region; value}
}
closing}
in {region; value}}
field_assignment:
field_name EQUAL expr {
@ -821,59 +993,34 @@ field_assignment:
field_name = $1;
equal = $2;
field_expr = $3}
in {region; value}
}
record_projection:
record_name DOT nsepseq(field_name,DOT) {
let stop = nsepseq_to_region (fun x -> x.region) $3 in
let region = cover $1.region stop
and value = {
record_name = $1;
selector = $2;
field_path = $3}
in {region; value}
}
in {region; value}}
fun_call:
fun_name arguments {
let region = cover $1.region $2.region
in {region; value = $1,$2}
}
in {region; value = $1,$2}}
tuple:
tuple_expr:
tuple_inj { TupleInj $1 }
tuple_inj:
par(nsepseq(expr,COMMA)) { $1 }
arguments:
tuple { $1 }
tuple_inj { $1 }
list_expr:
brackets(nsepseq(expr,COMMA)) { $1 }
injection(List,expr) { List $1 }
| nil { Nil $1 }
empty_list:
nil:
par(typed_empty_list) { $1 }
typed_empty_list:
LBRACKET RBRACKET COLON type_expr {
{lbracket = $1;
rbracket = $2;
colon = $3;
list_type = $4}
}
set_expr:
braces(nsepseq(expr,COMMA)) { $1 }
empty_set:
par(typed_empty_set) { $1 }
typed_empty_set:
LBRACE RBRACE COLON type_expr {
{lbrace = $1;
rbrace = $2;
colon = $3;
set_type = $4}
}
Nil COLON type_expr {
{nil = $1;
colon = $2;
list_type = $3}}
none_expr:
par(typed_none_expr) { $1 }
@ -882,16 +1029,14 @@ typed_none_expr:
C_None COLON type_expr {
{c_None = $1;
colon = $2;
opt_type = $3}
}
opt_type = $3}}
(* Patterns *)
pattern:
nsepseq(core_pattern,CONS) {
let region = nsepseq_to_region pattern_to_region $1
in PCons {region; value=$1}
}
in PCons {region; value=$1}}
core_pattern:
var { PVar $1 }
@ -906,12 +1051,12 @@ core_pattern:
| tuple_patt { PTuple $1 }
| C_Some par(core_pattern) {
let region = cover $1 $2.region
in PSome {region; value = $1,$2}
}
in PSome {region; value = $1,$2}}
list_patt:
brackets(sepseq(core_pattern,COMMA)) { Sugar $1 }
| par(cons_pattern) { Raw $1 }
injection(List,core_pattern) { Sugar $1 }
| Nil { PNil $1 }
| par(cons_pattern) { Raw $1 }
cons_pattern:
core_pattern CONS pattern { $1,$2,$3 }

29
src/ligo/ligo-parser/Tests/a.li
View File

@ -1,29 +0,0 @@
type t is int * string
type u is t
type v is record foo: key; bar: mutez; baz: address end
type w is K of (U of int) (*v * u*)
storage s : w // Line comment
operations o : u;
type i is int;
(* Block comment *)
entrypoint g (const l : list (int)) is
function f (const x : int) : int is
var y : int := 5 - x
const z : int = 6
begin
y := x + y
end with y * 2
begin
match l with
[] -> null
| h#t -> q (h+2)
end;
begin
g (Unit);
fail "in extremis"
end
end

45
src/ligo/ligo-parser/Tests/a.ligo Normal file
View File

@ -0,0 +1,45 @@
type t is int * string
type u is t
type v is record
foo: key;
bar: mutez;
baz: address
end
type w is K of (U of int) // v * u
type i is int;
const x : v =
record
foo = 4;
bar = 5;
baz = 0x3244
end
(* Block comment *)
entrypoint g (storage s : u; const l : list (int))
: operation (list) is
var m : map (int, string) := empty_map;
var y : v := copy x with record bar = 7 end;
function f (const x : int) : int is
var y : int := 5 - x
const z : int = 6
begin
y := x + y
end with y * 2
begin
y.[4] := "hello";
match l with
[] -> null
| h#t -> q (h+2)
end;
begin
g (Unit);
fail "in extremis"
end
end with (s, ([]: (u * operation (list))))

64
src/ligo/ligo-parser/Tests/crowdfunding.ligo Normal file
View File

@ -0,0 +1,64 @@
type store is
record
goal : nat;
deadline : timestamp;
backers : map (address, nat);
funded : bool;
end
entrypoint contribute (storage store : store;
const sender : address;
const amount : mutez)
: store * list (operation) is
var operations : list (operation) := nil
const s : list (int) = list [1; 2; 3]
const t : set (int) = set []
block {
if now > store.deadline then
fail "Deadline passed";
else
case store.backers[sender] of
None -> store.backers[sender] := Some (amount)
// None -> patch store.backers with map sender -> amount end
| _ -> skip
end
} with (store, operations)
entrypoint withdraw (storage store : store; const sender : address)
: store * list (operation) is
var operations : list (operation) := list end
begin
// if set ["a"; "b"] contains x then skip else skip;
if sender = owner then
if now (Unit) >= store.deadline then
if balance >= store.goal then {
store.funded := True;
// patch store with record funded = True end;
operations := list [Transfer (owner, balance)];
};
else fail "Below target"
else { fail "Too soon"; }
else skip
end with (store, operations)
entrypoint claim (storage store : store; const sender : address)
: store * list (operation) is
var operations : list (operation) := list []
var amount : mutez := 0
begin
if now <= store.deadline then
fail "Too soon"
else
case store.backers[sender] of
None ->
fail "Not a backer"
| Some (amount) ->
if balance >= store.goal or store.funded then
fail "Cannot refund"
else
begin
operations := list [Transfer (sender, amount)];
remove sender from map store.backers
end
end
end with (store, operations)

276
src/ligo/ligo-parser/Typecheck2.ml Normal file
View File

@ -0,0 +1,276 @@
(*
[@@@warning "-27"] (* TODO *)
[@@@warning "-32"] (* TODO *)
[@@@warning "-30"]
module SMap = Map.Make(String)
module I = AST2.O
module O = struct
type asttodo = [`TODO] (* occurrences of asttodo will point to some part of the original parser AST *)
type name_and_region = {name: string; orig: Region.t}
type type_name = name_and_region
type var_name = name_and_region
type field_name = name_and_region
type pattern =
PVar of var_name
| PWild
| PInt of Z.t
| PBytes of Hex.t
| PString of string
| PUnit
| PFalse
| PTrue
| PNone
| PSome of pattern
| PCons of pattern * pattern
| PNull
| PRecord of (field_name * pattern) SMap.t
type type_constructor =
Option
| List
| Set
| Map
type type_expr_case =
Sum of (type_name * type_expr) SMap.t
| Record of (field_name * type_expr) SMap.t
| TypeApp of type_constructor * (type_expr list)
| Function of { arg: type_expr; ret: type_expr }
| Ref of type_expr
| String
| Bytes
| Int
| Unit
| Bool
and type_expr = { type_expr: type_expr_case; name: type_name option; orig: Region.t }
type typed_var = { name:var_name; ty:type_expr; orig: asttodo }
type type_decl = { name: type_name; ty:type_expr; orig: asttodo }
type expr_case =
App of { operator: operator; arguments: expr list }
| Var of typed_var
| Constant of constant
| Record of (field_name * expr) list
| Lambda of lambda
and expr = { expr: expr_case; ty:type_expr; orig: asttodo }
and decl = { var: typed_var; value: expr; orig: asttodo }
and lambda = {
parameter: typed_var;
declarations: decl list;
instructions: instr list;
result: expr;
}
and operator_case =
Function of var_name
| Constructor of var_name
| UpdateField of field_name
| GetField of field_name
| Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod
| Neg | Not
| Set
| MapLookup
and operator = { operator: operator_case; ty:type_expr; orig: asttodo }
and constant =
Unit
| Int of Z.t | String of string | Bytes of Hex.t
| False | True
| Null
| EmptySet
| CNone
and instr =
Assignment of { name: var_name; value: expr; orig: asttodo }
| While of { condition: expr; body: instr list; orig: asttodo }
| ForCollection of { list: expr; var: var_name; body: instr list; orig: asttodo }
| Match of { expr: expr; cases: (pattern * instr list) list; orig: asttodo }
| ProcedureCall of { expr: expr; orig: asttodo } (* expr returns unit, drop the result. Similar to OCaml's ";". *)
| Fail of { expr: expr; orig: asttodo }
type ast = {
types : type_decl list;
storage_decl : typed_var;
declarations : decl list;
orig : AST.t
}
end
type te = O.type_expr list SMap.t
type ve = O.type_expr list SMap.t
type tve = te * ve
let fold_map f a l =
let f (acc, l) elem =
let acc', elem' = f acc elem
in acc', (elem' :: l) in
let last_acc, last_l = List.fold_left f (a, []) l
in last_acc, List.rev last_l
let map f l = List.rev (List.rev_map f l)
let shadow (name : string) (typ : O.type_expr) (env : O.type_expr list SMap.t)
: O.type_expr list SMap.t =
SMap.update name (function None -> Some [typ] | Some tl -> Some (typ :: tl)) env
let lookup (name : string) (env : O.type_expr list SMap.t) : O.type_expr =
match SMap.find name env with
latest :: shadowed -> latest
| [] -> failwith "Unbound variable"
let string_of_name ({name;_} : I.name_and_region) = name
let a_name_and_region ({name; orig} : I.name_and_region) : O.name_and_region =
{name; orig}
let a_type_constructor (tve : tve) : I.type_constructor -> O.type_constructor = function
Option -> Option
| List -> List
| Set -> Set
| Map -> Map
let a_type_expr_case (tve : tve) : I.type_expr_case -> O.type_expr_case = function
Sum lt -> failwith "TODO"
| Record lt -> failwith "TODO"
| TypeApp (tc, args) -> failwith "TODO"
| Function {arg;ret} -> failwith "TODO"
| Ref t -> failwith "TODO"
| String -> String
| Int -> Int
| Unit -> Unit
| Bool -> Bool
let a_type_expr (tve : tve) ({type_expr;name;orig} : I.type_expr) : O.type_expr =
let type_expr = a_type_expr_case tve type_expr in
let name = match name with
None -> None
|Some name -> Some (a_name_and_region name)
in {type_expr;name;orig}
let a_type (te,ve : tve) ({name;ty;orig} : I.type_decl) : tve * O.type_decl =
let ty = a_type_expr (te,ve) ty in
let tve = shadow (string_of_name name) ty te, ve in
let name = (a_name_and_region name) in
tve, {name; ty; orig}
let a_types (tve : tve) (l : I.type_decl list) : tve * O.type_decl list =
fold_map a_type tve l
let a_storage_decl : tve -> I.typed_var -> tve * O.typed_var =
failwith "TODO"
let type_expr_case_equal (t1 : O.type_expr_case) (t2 : O.type_expr_case) : bool = match t1,t2 with
Sum m1, Sum m2 -> failwith "TODO" (* of (O.name_and_region * O.type_expr) SMap.t *)
| Record m1, Record m2 -> failwith "TODO" (* of (O.name_and_region * O.type_expr) SMap.t *)
| TypeApp (tc1, args1), TypeApp (tc2, args2) -> failwith "TODO" (* of O.type_constructor * O.type_expr list *)
| Function {arg=arg1;ret=ret1}, Function {arg=arg2;ret=ret2} -> failwith "TODO" (* of { arg : O.type_expr; ret : O.type_expr; } *)
| Ref t1, Ref t2 -> failwith "TODO" (* of O.type_expr *)
| String, String -> true
| Int, Int -> true
| Unit, Unit -> true
| Bool, Bool -> true
| _ -> false
let type_expr_equal (t1 : O.type_expr) (t2 : O.type_expr) : bool =
type_expr_case_equal t1.type_expr t2.type_expr
let check_type_expr_equal (expected : O.type_expr) (actual : O.type_expr) : unit =
if type_expr_equal expected actual then
()
else
failwith "got [actual] but expected [expected]"
let a_var_expr (te,ve : tve) (expected : O.type_expr) (var_name : I.name_and_region) : O.expr_case =
check_type_expr_equal expected (lookup (string_of_name var_name) ve);
Var { name = a_name_and_region var_name;
ty = expected;
orig = `TODO }
let a_constant_expr (tve : tve) (expected : O.type_expr) (constant : I.constant) : O.expr_case =
let to_type_expr type_expr_case : O.type_expr =
{ type_expr = type_expr_case; name = None; orig = Region.ghost } in
let actual : O.type_expr = match constant with
Unit -> to_type_expr Unit
| Int _ -> to_type_expr Int
| String _ -> to_type_expr String
| Bytes _ -> to_type_expr Bytes
| False -> to_type_expr Bool
| True -> to_type_expr Bool
| Null t -> a_type_expr tve t
| EmptySet t -> a_type_expr tve t
| CNone t -> a_type_expr tve t
in
check_type_expr_equal expected actual;
let c : O.constant = match constant with
Unit -> Unit
| Int i -> Int i
| String s -> String s
| Bytes b -> Bytes b
| False -> False
| True -> True
| Null _ -> Null
| EmptySet _ -> EmptySet
| CNone _ -> CNone
in Constant c
let map_to_list m =
List.rev (SMap.fold (fun field_name_string p l -> p :: l) m [])
let a_field tve (expected,expr) =
failwith "TODO"
let a_record (tve : tve) (expected : O.type_expr) (record : (I.field_name * I.expr) list)
: O.expr_case =
let {type_expr = expected; _} : O.type_expr = expected in
let expected = match expected with
Record fields -> fields
| _ -> failwith "expected some_type but got record" in
let expected_and_field =
List.combine
(map_to_list expected)
record (* TODO SHOULD BE (map_to_list record) *) in
Record (map (a_field tve) expected_and_field)
let a_expr_case (te,ve : tve) (expected : O.type_expr) : I.expr -> O.expr_case = function
App {operator;arguments} -> failwith "TODO"
| Var var_name -> a_var_expr (te,ve) expected var_name
| Constant constant -> a_constant_expr (te,ve) expected constant
| Record record -> a_record (te,ve) expected record
| Lambda lambda -> failwith "TODO"
let a_expr (te,ve : tve) (expected : O.type_expr) (e : I.expr) : O.expr =
let expr_case = a_expr_case (te,ve) expected e in
{ expr = expr_case; ty = expected; orig = `TODO }
let a_declaration (te,ve : tve) ({name;ty;value} : I.decl) : tve * O.decl =
let ty = a_type_expr (te,ve) ty in
let value = a_expr (te,ve) ty value in
let ve = shadow (string_of_name name) ty ve in
let name = a_name_and_region name in
(te,ve), {var={name;ty;orig=`TODO};value;orig = `TODO}
let a_declarations (tve : tve) (l : I.decl list) : tve * O.decl list =
fold_map a_declaration tve l
let a_ast I.{types; storage_decl; declarations; orig} =
let tve = SMap.empty, SMap.empty in
let tve, types = a_types tve types in
let tve, storage_decl = a_storage_decl tve storage_decl in
let tve, declarations = a_declarations tve declarations in
let _ = tve in
O.{types; storage_decl; declarations; orig}
let annotate : I.ast -> O.ast = a_ast
*)

110
src/ligo/ligo-parser/Typecheck2.mli Normal file
View File

@ -0,0 +1,110 @@
(*
[@@@warning "-30"]
module SMap : Map.S with type key = string
module I = AST2.O
module O : sig
type asttodo = [`TODO] (* occurrences of asttodo will point to some part of the original parser AST *)
type name_and_region = {name: string; orig: Region.t}
type type_name = name_and_region
type var_name = name_and_region
type field_name = name_and_region
type pattern =
PVar of var_name
| PWild
| PInt of Z.t
| PBytes of Hex.t
| PString of string
| PUnit
| PFalse
| PTrue
| PNone
| PSome of pattern
| PCons of pattern * pattern
| PNull
| PRecord of (field_name * pattern) SMap.t
type type_constructor =
Option
| List
| Set
| Map
type type_expr_case =
Sum of (type_name * type_expr) SMap.t
| Record of (field_name * type_expr) SMap.t
| TypeApp of type_constructor * (type_expr list)
| Function of { arg: type_expr; ret: type_expr }
| Ref of type_expr
| String
| Bytes
| Int
| Unit
| Bool
and type_expr = { type_expr: type_expr_case; name: type_name option; orig: Region.t }
type typed_var = { name:var_name; ty:type_expr; orig: asttodo }
type type_decl = { name:type_name; ty:type_expr; orig: asttodo }
type expr_case =
App of { operator: operator; arguments: expr list }
| Var of typed_var
| Constant of constant
| Record of (field_name * expr) list
| Lambda of lambda
and expr = { expr: expr_case; ty:type_expr; orig: asttodo }
and decl = { var: typed_var; value: expr; orig: asttodo }
and lambda = {
parameter: typed_var;
declarations: decl list;
instructions: instr list;
result: expr;
}
and operator_case =
Function of var_name
| Constructor of var_name
| UpdateField of field_name
| GetField of field_name
| Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod
| Neg | Not
| Set
| MapLookup
and operator = { operator: operator_case; ty:type_expr; orig: asttodo }
and constant =
Unit
| Int of Z.t | String of string | Bytes of Hex.t
| False | True
| Null
| EmptySet
| CNone
and instr =
Assignment of { name: var_name; value: expr; orig: asttodo }
| While of { condition: expr; body: instr list; orig: asttodo }
| ForCollection of { list: expr; var: var_name; body: instr list; orig: asttodo }
| Match of { expr: expr; cases: (pattern * instr list) list; orig: asttodo }
| ProcedureCall of { expr: expr; orig: asttodo } (* expr returns unit, drop the result. Similar to OCaml's ";". *)
| Fail of { expr: expr; orig: asttodo }
type ast = {
types : type_decl list;
storage_decl : typed_var;
declarations : decl list;
orig : AST.t
}
end
val annotate : I.ast -> O.ast
*)

3
src/ligo/ligo-parser/ligo_parser.ml
View File

@ -1,3 +0,0 @@
module Parser = Parser
module Lexer = Lexer.Make(LexToken)
module AST = AST