diff --git a/src/ligo/ligo-parser/.gitignore b/src/ligo/ligo-parser/.gitignore index 73be7197d..5d8b6a914 100644 --- a/src/ligo/ligo-parser/.gitignore +++ b/src/ligo/ligo-parser/.gitignore @@ -1 +1,8 @@ +_build/* +*/_build +*~ +.merlin +*/.merlin +*.install /Version.ml +/dune-project diff --git a/src/ligo/ligo-parser/.gitlab-ci.yml b/src/ligo/ligo-parser/.gitlab-ci.yml new file mode 100644 index 000000000..5c8b0d9af --- /dev/null +++ b/src/ligo/ligo-parser/.gitlab-ci.yml @@ -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 diff --git a/src/ligo/ligo-parser/AST.ml b/src/ligo/ligo-parser/AST.ml index 9ee644047..a57455fae 100644 --- a/src/ligo/ligo-parser/AST.ml +++ b/src/ligo/ligo-parser/AST.ml @@ -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 diff --git a/src/ligo/ligo-parser/AST.mli b/src/ligo/ligo-parser/AST.mli index 5a7777499..a465e32a8 100644 --- a/src/ligo/ligo-parser/AST.mli +++ b/src/ligo/ligo-parser/AST.mli @@ -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 *) diff --git a/src/ligo/ligo-parser/AST2.ml b/src/ligo/ligo-parser/AST2.ml new file mode 100644 index 000000000..73f5b9b85 --- /dev/null +++ b/src/ligo/ligo-parser/AST2.ml @@ -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 -> () *) + + *) diff --git a/src/ligo/ligo-parser/LexToken.mli b/src/ligo/ligo-parser/LexToken.mli index b1503bd99..c4934962d 100644 --- a/src/ligo/ligo-parser/LexToken.mli +++ b/src/ligo/ligo-parser/LexToken.mli @@ -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" *) diff --git a/src/ligo/ligo-parser/LexToken.mll b/src/ligo/ligo-parser/LexToken.mll index d7530b948..f8bcd91c5 100644 --- a/src/ligo/ligo-parser/LexToken.mll +++ b/src/ligo/ligo-parser/LexToken.mll @@ -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 diff --git a/src/ligo/ligo-parser/Lexer.mll b/src/ligo/ligo-parser/Lexer.mll index 547599f3b..c96bcf7bd 100644 --- a/src/ligo/ligo-parser/Lexer.mll +++ b/src/ligo/ligo-parser/Lexer.mll @@ -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 = ';' | ',' | '(' | ')'| '[' | ']' | '{' | '}' | '#' | '|' | "->" | ":=" | '=' | ':' | '<' | "<=" | '>' | ">=" | "=/=" | '+' | '-' | '*' | '.' | '_' | '^' diff --git a/src/ligo/ligo-parser/MBytes.ml b/src/ligo/ligo-parser/MBytes.ml deleted file mode 100644 index d79e14295..000000000 --- a/src/ligo/ligo-parser/MBytes.ml +++ /dev/null @@ -1,6 +0,0 @@ -(* TEMPORARY: SHOULD BE ERASED *) - -type t = Hex.t - -let of_hex x = x -let to_hex x = x diff --git a/src/ligo/ligo-parser/MBytes.mli b/src/ligo/ligo-parser/MBytes.mli deleted file mode 100644 index 2d0503b26..000000000 --- a/src/ligo/ligo-parser/MBytes.mli +++ /dev/null @@ -1,6 +0,0 @@ -(* TEMPORARY: SHOULD BE ERASED *) - -type t - -val of_hex : Hex.t -> t -val to_hex : t -> Hex.t diff --git a/src/ligo/ligo-parser/ParToken.mly b/src/ligo/ligo-parser/ParToken.mly index 2ffbd93ad..dcddbcca7 100644 --- a/src/ligo/ligo-parser/ParToken.mly +++ b/src/ligo/ligo-parser/ParToken.mly @@ -44,33 +44,40 @@ %token And (* "and" *) %token Begin (* "begin" *) +%token Block (* "block" *) %token Case (* "case" *) %token Const (* "const" *) +%token Contains (* "contains" *) %token Down (* "down" *) +%token Else (* "else" *) +%token End (* "end" *) +%token Entrypoint (* "entrypoint" *) %token Fail (* "fail" *) +%token For (* "for" *) +%token Function (* "function" *) +%token From (* "from" *) %token If (* "if" *) %token In (* "in" *) %token Is (* "is" *) -%token Entrypoint (* "entrypoint" *) -%token For (* "for" *) -%token Function (* "function" *) -%token Type (* "type" *) +%token List (* "list" *) +%token Map (* "map" *) +%token Mod (* "mod" *) +%token Nil (* "nil" *) +%token Not (* "not" *) %token Of (* "of" *) %token Or (* "or" *) -%token Var (* "var" *) -%token End (* "end" *) -%token Then (* "then" *) -%token Else (* "else" *) -%token Map (* "map" *) %token Patch (* "patch" *) %token Procedure (* "procedure" *) %token Record (* "record" *) +%token Remove (* "remove" *) +%token Set (* "set" *) %token Skip (* "skip" *) %token Step (* "step" *) %token Storage (* "storage" *) +%token Then (* "then" *) %token To (* "to" *) -%token Mod (* "mod" *) -%token Not (* "not" *) +%token Type (* "type" *) +%token Var (* "var" *) %token While (* "while" *) %token With (* "with" *) diff --git a/src/ligo/ligo-parser/Parser.mly b/src/ligo/ligo-parser/Parser.mly index 4d42d57e9..5539bff46 100644 --- a/src/ligo/ligo-parser/Parser.mly +++ b/src/ligo/ligo-parser/Parser.mly @@ -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 } diff --git a/src/ligo/ligo-parser/Tests/a.li b/src/ligo/ligo-parser/Tests/a.li deleted file mode 100644 index 9ab4b3399..000000000 --- a/src/ligo/ligo-parser/Tests/a.li +++ /dev/null @@ -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 diff --git a/src/ligo/ligo-parser/Tests/a.ligo b/src/ligo/ligo-parser/Tests/a.ligo new file mode 100644 index 000000000..129a68d1f --- /dev/null +++ b/src/ligo/ligo-parser/Tests/a.ligo @@ -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)))) diff --git a/src/ligo/ligo-parser/Tests/crowdfunding.ligo b/src/ligo/ligo-parser/Tests/crowdfunding.ligo new file mode 100644 index 000000000..fb61cbc0d --- /dev/null +++ b/src/ligo/ligo-parser/Tests/crowdfunding.ligo @@ -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) diff --git a/src/ligo/ligo-parser/Typecheck2.ml b/src/ligo/ligo-parser/Typecheck2.ml new file mode 100644 index 000000000..7be850385 --- /dev/null +++ b/src/ligo/ligo-parser/Typecheck2.ml @@ -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 +*) diff --git a/src/ligo/ligo-parser/Typecheck2.mli b/src/ligo/ligo-parser/Typecheck2.mli new file mode 100644 index 000000000..ba541d029 --- /dev/null +++ b/src/ligo/ligo-parser/Typecheck2.mli @@ -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 +*) diff --git a/src/ligo/ligo-parser/ligo_parser.ml b/src/ligo/ligo-parser/ligo_parser.ml deleted file mode 100644 index 7fec46e33..000000000 --- a/src/ligo/ligo-parser/ligo_parser.ml +++ /dev/null @@ -1,3 +0,0 @@ -module Parser = Parser -module Lexer = Lexer.Make(LexToken) -module AST = AST