From 8eaf1a90ec155084efa7ca2cf660dd5fce3724be Mon Sep 17 00:00:00 2001
From: Christian Rinderknecht <Christian.Rinderknecht@tezcore.com>
Date: Wed, 20 Mar 2019 09:11:19 +0100
Subject: [PATCH] Maps can be defined by extension in declarations.
"map" has become a keyword to introduce definition of maps by extension in declarations ("map" ... "end"). This entails that a grammar rule had to be created to handle the type expressions "map (..., ...)". Concordantly, I added map patches, modelled after record patches.
I created a node in the AST for map expressions (currently only
map look-ups).
I refactored the parser with parametric rules.
---
AST.ml | 135 +++++++++++++++++++++++++++-------------
AST.mli | 61 ++++++++++++------
LexToken.mli | 1 +
LexToken.mll | 5 ++
ParToken.mly | 1 +
Parser.mly | 170 ++++++++++++++++++++++++++++++---------------------
6 files changed, 243 insertions(+), 130 deletions(-)
diff --git a/AST.ml b/AST.ml
index 14d51fe7b..443f127d4 100644
--- a/AST.ml
+++ b/AST.ml
@@ -52,6 +52,7 @@ type kwd_function = Region.t
type kwd_if = Region.t
type kwd_in = Region.t
type kwd_is = Region.t
+type kwd_map = Region.t
type kwd_mod = Region.t
type kwd_not = Region.t
type kwd_of = Region.t
@@ -318,14 +319,35 @@ and instruction =
| Block of block reg
and single_instr =
- Cond of conditional reg
-| Case of case_instr reg
-| Assign of assignment reg
-| Loop of loop
-| ProcCall of fun_call
-| Fail of fail_instr reg
-| Skip of kwd_skip
-| Patch of record_patch reg
+ Cond of conditional reg
+| Case of case_instr reg
+| Assign of assignment reg
+| Loop of loop
+| ProcCall of fun_call
+| Fail of fail_instr reg
+| Skip of kwd_skip
+| RecordPatch of record_patch reg
+| MapPatch of map_patch reg
+
+and map_patch = {
+ kwd_patch : kwd_patch;
+ map_name : variable;
+ kwd_with : kwd_with;
+ delta : map_injection reg
+}
+
+and map_injection = {
+ opening : kwd_map;
+ bindings : (binding reg, semi) nsepseq;
+ terminator : semi option;
+ close : kwd_end
+}
+
+and binding = {
+ source : expr;
+ arrow : arrow;
+ image : expr
+}
and record_patch = {
kwd_patch : kwd_patch;
@@ -414,14 +436,26 @@ and expr =
| SetExpr of set_expr
| ConstrExpr of constr_expr
| RecordExpr of record_expr
+| MapExpr of map_expr
| Var of Lexer.lexeme reg
| FunCall of fun_call
| Bytes of (Lexer.lexeme * MBytes.t) reg
| Unit of c_Unit
| Tuple of tuple
-| MapLookUp of map_lookup reg
| ParExpr of expr par reg
+and map_expr =
+ MapLookUp of map_lookup reg
+
+and map_lookup = {
+ map_path : map_path;
+ index : expr brackets reg
+}
+
+and map_path =
+ Map of map_name
+| MapPath of record_projection reg
+
and logic_expr =
BoolExpr of bool_expr
| CompExpr of comp_expr
@@ -534,15 +568,6 @@ and fun_call = (fun_name * arguments) reg
and arguments = tuple
-and map_lookup = {
- map_path : map_path;
- index : expr brackets reg
-}
-
-and map_path =
- Map of map_name
-| MapPath of record_projection reg
-
(* Patterns *)
and pattern =
@@ -584,14 +609,17 @@ let rec expr_to_region = function
| SetExpr e -> set_expr_to_region e
| ConstrExpr e -> constr_expr_to_region e
| RecordExpr e -> record_expr_to_region e
+| MapExpr e -> map_expr_to_region e
| Var {region; _}
| FunCall {region; _}
| Bytes {region; _}
| Unit region
| Tuple {region; _}
-| MapLookUp {region; _}
| ParExpr {region; _} -> region
+and map_expr_to_region = function
+ MapLookUp {region; _} -> region
+
and logic_expr_to_region = function
BoolExpr e -> bool_expr_to_region e
| CompExpr e -> comp_expr_to_region e
@@ -652,7 +680,8 @@ let instr_to_region = function
| Single ProcCall {region; _}
| Single Skip region
| Single Fail {region; _}
-| Single Patch {region; _}
+| Single RecordPatch {region; _}
+| Single MapPatch {region; _}
| Block {region; _} -> region
let pattern_to_region = function
@@ -931,14 +960,15 @@ and print_instruction = function
| Block block -> print_block block
and print_single_instr = function
- Cond {value; _} -> print_conditional value
-| Case {value; _} -> print_case_instr value
-| Assign assign -> print_assignment assign
-| Loop loop -> print_loop loop
-| ProcCall fun_call -> print_fun_call fun_call
-| Fail {value; _} -> print_fail value
-| Skip kwd_skip -> print_token kwd_skip "skip"
-| Patch {value; _} -> print_patch value
+ Cond {value; _} -> print_conditional value
+| Case {value; _} -> print_case_instr value
+| Assign assign -> print_assignment assign
+| Loop loop -> print_loop loop
+| ProcCall fun_call -> print_fun_call fun_call
+| Fail {value; _} -> print_fail value
+| Skip kwd_skip -> print_token kwd_skip "skip"
+| RecordPatch {value; _} -> print_record_patch value
+| MapPatch {value; _} -> print_map_patch value
and print_fail {kwd_fail; fail_expr} =
print_token kwd_fail "fail";
@@ -1041,14 +1071,27 @@ and print_expr = function
| SetExpr e -> print_set_expr e
| ConstrExpr e -> print_constr_expr e
| RecordExpr e -> print_record_expr e
+| MapExpr e -> print_map_expr e
| Var var -> print_var var
| FunCall e -> print_fun_call e
| Bytes b -> print_bytes b
| Unit region -> print_token region "Unit"
| Tuple e -> print_tuple e
-| MapLookUp e -> print_map_lookup e
| ParExpr e -> print_par_expr e
+and print_map_expr = function
+ MapLookUp {value; _} ->
+ let {map_path; index} = value in
+ let {lbracket; inside; rbracket} = index.value in
+ print_map_path map_path;
+ print_token lbracket "[";
+ print_expr inside;
+ print_token rbracket "]"
+
+and print_map_path = function
+ Map map_name -> print_var map_name
+| MapPath path -> print_record_projection path
+
and print_logic_expr = function
BoolExpr e -> print_bool_expr e
| CompExpr e -> print_comp_expr e
@@ -1138,13 +1181,33 @@ and print_record_projection {value; _} =
and print_field_path sequence =
print_nsepseq "." print_var sequence
-and print_patch (node: record_patch) =
+and print_record_patch node =
let {kwd_patch; record_name; kwd_with; delta} = node in
print_token kwd_patch "patch";
print_var record_name;
print_token kwd_with "with";
print_record_injection delta
+and print_map_patch node =
+ let {kwd_patch; map_name; kwd_with; delta} = node in
+ print_token kwd_patch "patch";
+ print_var map_name;
+ print_token kwd_with "with";
+ print_map_injection delta
+
+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_binding {value; _} =
+ let {source; arrow; image} = value in
+ print_expr source;
+ print_token arrow "->";
+ print_expr image
+
and print_tuple {value; _} =
let {lpar; inside; rpar} = value in
print_token lpar "(";
@@ -1207,18 +1270,6 @@ and print_some_app {value; _} =
print_token c_Some "Some";
print_tuple arguments
-and print_map_lookup {value; _} =
- let {map_path; index} = value in
- let {lbracket; inside; rbracket} = index.value in
- print_map_path map_path;
- print_token lbracket "[";
- print_expr inside;
- print_token rbracket "]"
-
-and print_map_path = function
- Map map_name -> print_var map_name
-| MapPath path -> print_record_projection path
-
and print_par_expr {value; _} =
let {lpar; inside; rpar} = value in
print_token lpar "(";
diff --git a/AST.mli b/AST.mli
index b9c483c13..81ac55d66 100644
--- a/AST.mli
+++ b/AST.mli
@@ -36,6 +36,7 @@ type kwd_function = Region.t
type kwd_if = Region.t
type kwd_in = Region.t
type kwd_is = Region.t
+type kwd_map = Region.t
type kwd_mod = Region.t
type kwd_not = Region.t
type kwd_of = Region.t
@@ -302,14 +303,35 @@ and instruction =
| Block of block reg
and single_instr =
- Cond of conditional reg
-| Case of case_instr reg
-| Assign of assignment reg
-| Loop of loop
-| ProcCall of fun_call
-| Fail of fail_instr reg
-| Skip of kwd_skip
-| Patch of record_patch reg
+ Cond of conditional reg
+| Case of case_instr reg
+| Assign of assignment reg
+| Loop of loop
+| ProcCall of fun_call
+| Fail of fail_instr reg
+| Skip of kwd_skip
+| RecordPatch of record_patch reg
+| MapPatch of map_patch reg
+
+and map_patch = {
+ kwd_patch : kwd_patch;
+ map_name : variable;
+ kwd_with : kwd_with;
+ delta : map_injection reg
+}
+
+and map_injection = {
+ opening : kwd_map;
+ bindings : (binding reg, semi) nsepseq;
+ terminator : semi option;
+ close : kwd_end
+}
+
+and binding = {
+ source : expr;
+ arrow : arrow;
+ image : expr
+}
and record_patch = {
kwd_patch : kwd_patch;
@@ -398,14 +420,26 @@ and expr =
| SetExpr of set_expr
| ConstrExpr of constr_expr
| RecordExpr of record_expr
+| MapExpr of map_expr
| Var of Lexer.lexeme reg
| FunCall of fun_call
| Bytes of (Lexer.lexeme * MBytes.t) reg
| Unit of c_Unit
| Tuple of tuple
-| MapLookUp of map_lookup reg
| ParExpr of expr par reg
+and map_expr =
+ MapLookUp of map_lookup reg
+
+and map_lookup = {
+ map_path : map_path;
+ index : expr brackets reg
+}
+
+and map_path =
+ Map of map_name
+| MapPath of record_projection reg
+
and logic_expr =
BoolExpr of bool_expr
| CompExpr of comp_expr
@@ -518,15 +552,6 @@ and fun_call = (fun_name * arguments) reg
and arguments = tuple
-and map_lookup = {
- map_path : map_path;
- index : expr brackets reg
-}
-
-and map_path =
- Map of map_name
-| MapPath of record_projection reg
-
(* Patterns *)
and pattern =
diff --git a/LexToken.mli b/LexToken.mli
index 7dcfe1337..1e31dcc97 100644
--- a/LexToken.mli
+++ b/LexToken.mli
@@ -84,6 +84,7 @@ type t =
| End of Region.t (* "end" *)
| Then of Region.t (* "then" *)
| Else of Region.t (* "else" *)
+| Map of Region.t (* "map" *)
| Patch of Region.t (* "patch" *)
| Procedure of Region.t (* "procedure" *)
| Record of Region.t (* "record" *)
diff --git a/LexToken.mll b/LexToken.mll
index 3d7c9beee..be5c9bce0 100644
--- a/LexToken.mll
+++ b/LexToken.mll
@@ -83,6 +83,7 @@ type t =
| End of Region.t
| Then of Region.t
| Else of Region.t
+| Map of Region.t
| Patch of Region.t
| Procedure of Region.t
| Record of Region.t
@@ -202,6 +203,7 @@ let proj_token = function
| End region -> region, "End"
| Then region -> region, "Then"
| Else region -> region, "Else"
+| Map region -> region, "Map"
| Patch region -> region, "Patch"
| Procedure region -> region, "Procedure"
| Record region -> region, "Record"
@@ -286,6 +288,7 @@ let to_lexeme = function
| End _ -> "end"
| Then _ -> "then"
| Else _ -> "else"
+| Map _ -> "map"
| Patch _ -> "patch"
| Procedure _ -> "procedure"
| Record _ -> "record"
@@ -338,6 +341,7 @@ let keywords = [
(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);
@@ -562,6 +566,7 @@ let is_kwd = function
| End _
| Then _
| Else _
+| Map _
| Patch _
| Procedure _
| Record _
diff --git a/ParToken.mly b/ParToken.mly
index c4b1769e8..acba7ff97 100644
--- a/ParToken.mly
+++ b/ParToken.mly
@@ -61,6 +61,7 @@
%token <Region.t> End (* "end" *)
%token <Region.t> Then (* "then" *)
%token <Region.t> Else (* "else" *)
+%token <Region.t> Map (* "map" *)
%token <Region.t> Patch (* "patch" *)
%token <Region.t> Procedure (* "procedure" *)
%token <Region.t> Record (* "record" *)
diff --git a/Parser.mly b/Parser.mly
index fd3d6cc05..806bd05bd 100644
--- a/Parser.mly
+++ b/Parser.mly
@@ -21,6 +21,34 @@ 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]. *)
+
+series(Item):
+ Item after_item(Item) { $1,$2 }
+
+after_item(Item):
+ SEMI item_or_end(Item) {
+ match $2 with
+ `Some (item, items, term, close) ->
+ ($1, item)::items, term, close
+ | `End close ->
+ [], Some $1, close
+ }
+| End {
+ [], None, $1
+ }
+
+item_or_end(Item):
+ End {
+ `End $1
+ }
+| series(Item) {
+ let item, (items, term, close) = $1
+ in `Some (item, items, term, close)
+ }
+
(* Compound constructs *)
par(X):
@@ -130,8 +158,8 @@ type_decl:
in {region; value}}
type_expr:
- cartesian { Prod $1 }
-| sum_type { Sum $1 }
+ cartesian { Prod $1 }
+| sum_type { Sum $1 }
| record_type { Record $1 }
cartesian:
@@ -148,6 +176,11 @@ core_type:
let region = cover $1.region $2.region
in TypeApp {region; value = $1,$2}
}
+| Map type_tuple {
+ let region = cover $1 $2.region in
+ let value = {value="map"; region=$1}
+ in TypeApp {region; value = value, $2}
+ }
| par(type_expr) {
ParType $1
}
@@ -310,40 +343,17 @@ entry_param_decl:
}
block:
- Begin
- instruction after_instr
- {
- let instrs, terminator, close = $3 in
+ Begin series(instruction) {
+ let first, (others, terminator, close) = $2 in
let region = cover $1 close
and value = {
opening = $1;
- instr = $2, instrs;
+ instr = first, others;
terminator;
close}
in {region; value}
}
-after_instr:
- SEMI instr_or_end {
- match $2 with
- `Some (instr, instrs, term, close) ->
- ($1, instr)::instrs, term, close
- | `End close ->
- [], Some $1, close
- }
-| End {
- [], None, $1
- }
-
-instr_or_end:
- End {
- `End $1
- }
-| instruction after_instr {
- let instrs, term, close = $2 in
- `Some ($1, instrs, term, close)
- }
-
local_decl:
lambda_decl { LocalLam $1 }
| const_decl { LocalConst $1 }
@@ -397,6 +407,8 @@ var_decl:
opt_type = $4};
rpar = Region.ghost}
in ConstrExpr (NoneExpr {region; value}) in
+ (* | `EMap inj ->*)
+
let value = {
kwd_var = $1;
name = $2;
@@ -414,20 +426,59 @@ extended_expr:
| 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} }
+ *)
instruction:
single_instr { Single $1 }
| block { Block $1 }
single_instr:
- conditional { Cond $1 }
-| case_instr { Case $1 }
-| assignment { Assign $1 }
-| loop { Loop $1 }
-| proc_call { ProcCall $1 }
-| fail_instr { Fail $1 }
-| Skip { Skip $1 }
-| record_patch { Patch $1 }
+ conditional { Cond $1 }
+| case_instr { Case $1 }
+| assignment { Assign $1 }
+| loop { Loop $1 }
+| proc_call { ProcCall $1 }
+| fail_instr { Fail $1 }
+| Skip { Skip $1 }
+| record_patch { RecordPatch $1 }
+| map_patch { MapPatch $1 }
+
+map_patch:
+ Map map_name With map_injection {
+ let region = cover $1 $4.region in
+ let value = {
+ kwd_patch = $1;
+ map_name = $2;
+ kwd_with = $3;
+ delta = $4}
+ in {region; value}
+ }
+
+map_injection:
+ Map series(binding) {
+ let first, (others, terminator, close) = $2 in
+ let region = cover $1 close
+ and value = {
+ opening = $1;
+ bindings = first, others;
+ terminator;
+ close}
+ in {region; value}
+ }
+
+binding:
+ expr ARROW expr {
+ let start = expr_to_region $1
+ and stop = expr_to_region $3 in
+ let region = cover start stop
+ and value = {
+ source = $1;
+ arrow = $2;
+ image = $3}
+ in {region; value}
+ }
record_patch:
Patch record_name With record_injection {
@@ -440,7 +491,6 @@ record_patch:
in {region; value}
}
-
fail_instr:
Fail expr {
let region = cover $1 (expr_to_region $2)
@@ -705,7 +755,7 @@ core_expr:
| empty_set { SetExpr (EmptySet $1) }
| none_expr { ConstrExpr (NoneExpr $1) }
| fun_call { FunCall $1 }
-| map_selection { MapLookUp $1 }
+| map_expr { MapExpr $1 }
| record_expr { RecordExpr $1 }
| Constr arguments {
let region = cover $1.region $2.region in
@@ -716,6 +766,9 @@ core_expr:
ConstrExpr (SomeApp {region; value = $1,$2})
}
+map_expr:
+ map_selection { MapLookUp $1 }
+
map_selection:
map_name brackets(expr) {
let region = cover $1.region $2.region in
@@ -737,38 +790,15 @@ record_expr:
| record_projection { RecordProj $1 }
record_injection:
- Record
- field_assignment after_field
- {
- let fields, terminator, close = $3 in
- let region = cover $1 close
- and value = {
- opening = $1;
- fields = $2, fields;
- terminator;
- close}
- in {region; value}
- }
-
-after_field:
- SEMI field_or_end {
- match $2 with
- `Some (field, fields, term, close) ->
- ($1, field)::fields, term, close
- | `End close ->
- [], Some $1, close
- }
-| End {
- [], None, $1
- }
-
-field_or_end:
- End {
- `End $1
- }
-| field_assignment after_field {
- let fields, term, close = $2 in
- `Some ($1, fields, term, close)
+ Record series(field_assignment) {
+ let first, (others, terminator, close) = $2 in
+ let region = cover $1 close
+ and value = {
+ opening = $1;
+ fields = first, others;
+ terminator;
+ close}
+ in {region; value}
}
field_assignment: