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

Factorised the "case" constructs into one.

Browse Source
This commit is contained in:
Christian Rinderknecht 2019-04-01 18:16:06 +02:00
parent e54c5e0c42
commit 9a4ff35fc7
No known key found for this signature in database
GPG Key ID: 9446816CFD267040
5 changed files with 61 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -6,3 +6,7 @@ _build/*
*.install
/Version.ml
/dune-project
/Parser.mli
/Parser.ml
/Lexer.ml
/LexToken.ml

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

@ -338,7 +338,7 @@ and instruction =
and single_instr =
Cond of conditional reg
| Case_instr of case_instr reg
| CaseInstr of instruction case reg
| Assign of assignment reg
| Loop of loop
| ProcCall of fun_call
@ -418,38 +418,19 @@ and set_membership = {
element : expr
}
and case_instr = {
and 'a case = {
kwd_case : kwd_case;
expr : expr;
kwd_of : kwd_of;
lead_vbar : vbar option;
cases_instr : cases_instr;
cases : ('a case_clause reg, vbar) nsepseq reg;
kwd_end : kwd_end
}
and cases_instr = (case_clause_instr reg, vbar) nsepseq reg
and case_clause_instr = {
and 'a case_clause = {
pattern : pattern;
arrow : arrow;
instr : instruction
}
and case_expr = {
kwd_case : kwd_case;
expr : expr;
kwd_of : kwd_of;
lead_vbar : vbar option;
cases_expr: cases_expr;
kwd_end : kwd_end
}
and cases_expr = (case_clause_expr reg, vbar) nsepseq reg
and case_clause_expr = {
pattern : pattern;
arrow : arrow;
expr : expr;
rhs : 'a
}
and assignment = {
@ -508,7 +489,7 @@ and for_collect = {
(* Expressions *)
and expr =
| ECase of case_expr reg
| ECase of expr case reg
| ELogic of logic_expr
| EArith of arith_expr
| EString of string_expr
@ -773,7 +754,7 @@ let path_to_region = function
let instr_to_region = function
Single Cond {region; _}
| Single Case_instr {region; _}
| Single CaseInstr {region; _}
| Single Assign {region; _}
| Single Loop While {region; _}
| Single Loop For ForInt {region; _}
@ -1092,7 +1073,7 @@ and print_instruction = function
and print_single_instr = function
Cond {value; _} -> print_conditional value
| Case_instr {value; _} -> print_case_instr value
| CaseInstr {value; _} -> print_case_instr value
| Assign assign -> print_assignment assign
| Loop loop -> print_loop loop
| ProcCall fun_call -> print_fun_call fun_call
@ -1129,14 +1110,14 @@ and print_if_clause = function
print_terminator terminator;
print_token rbrace "}"
and print_case_instr (node : case_instr) =
and print_case_instr (node : instruction case) =
let {kwd_case; expr; kwd_of;
lead_vbar; cases_instr; kwd_end} = node in
lead_vbar; cases; kwd_end} = node in
print_token kwd_case "case";
print_expr expr;
print_token kwd_of "of";
print_token_opt lead_vbar "|";
print_cases_instr cases_instr;
print_cases_instr cases;
print_token kwd_end "end"
and print_token_opt = function
@ -1147,10 +1128,10 @@ and print_cases_instr {value; _} =
print_nsepseq "|" print_case_clause_instr value
and print_case_clause_instr {value; _} =
let {pattern; arrow; instr} = value in
let {pattern; arrow; rhs} = value in
print_pattern pattern;
print_token arrow "->";
print_instruction instr
print_instruction rhs
and print_assignment {value; _} =
let {lhs; assign; rhs} = value in
@ -1240,24 +1221,24 @@ and print_expr = function
| ETuple e -> print_tuple_expr e
| EPar e -> print_par_expr e
and print_case_expr (node : case_expr) =
and print_case_expr (node : expr case) =
let {kwd_case; expr; kwd_of;
lead_vbar; cases_expr; kwd_end} = node in
lead_vbar; cases; kwd_end} = node in
print_token kwd_case "case";
print_expr expr;
print_token kwd_of "of";
print_token_opt lead_vbar "|";
print_cases_expr cases_expr;
print_cases_expr cases;
print_token kwd_end "end"
and print_cases_expr {value; _} =
print_nsepseq "|" print_case_clause_expr value
and print_case_clause_expr {value; _} =
let {pattern; arrow; expr} = value in
let {pattern; arrow; rhs} = value in
print_pattern pattern;
print_token arrow "->";
print_expr expr
print_expr rhs
and print_map_expr = function
MapLookUp {value; _} -> print_map_lookup value

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

@ -322,7 +322,7 @@ and instruction =
and single_instr =
Cond of conditional reg
| Case_instr of case_instr reg
| CaseInstr of instruction case reg
| Assign of assignment reg
| Loop of loop
| ProcCall of fun_call
@ -402,38 +402,19 @@ and set_membership = {
element : expr
}
and case_instr = {
and 'a case = {
kwd_case : kwd_case;
expr : expr;
kwd_of : kwd_of;
lead_vbar : vbar option;
cases_instr : cases_instr;
cases : ('a case_clause reg, vbar) nsepseq reg;
kwd_end : kwd_end
}
and cases_instr = (case_clause_instr reg, vbar) nsepseq reg
and case_clause_instr = {
and 'a case_clause = {
pattern : pattern;
arrow : arrow;
instr : instruction
}
and case_expr = {
kwd_case : kwd_case;
expr : expr;
kwd_of : kwd_of;
lead_vbar : vbar option;
cases_expr: cases_expr;
kwd_end : kwd_end
}
and cases_expr = (case_clause_expr reg, vbar) nsepseq reg
and case_clause_expr = {
pattern : pattern;
arrow : arrow;
expr : expr;
rhs : 'a
}
and assignment = {
@ -492,7 +473,7 @@ and for_collect = {
(* Expressions *)
and expr =
ECase of case_expr reg
ECase of expr case reg
| ELogic of logic_expr
| EArith of arith_expr
| EString of string_expr

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

@ -21,9 +21,9 @@ open AST
(* RULES *)
(* The rule [series(Item,TERM)] parses a list of [Item] separated by
semicolons and optionally terminated by a semicolon, then the
terminal TERM. *)
(* The rule [series(Item,TERM)] parses a non-empty list of [Item]
separated by semicolons and optionally terminated by a semicolon,
then the terminal TERM. *)
series(Item,TERM):
Item after_item(Item,TERM) { $1,$2 }
@ -492,7 +492,7 @@ instruction:
single_instr:
conditional { Cond $1 }
| case_instr { Case_instr $1 }
| case_instr { CaseInstr $1 }
| assignment { Assign $1 }
| loop { Loop $1 }
| proc_call { ProcCall $1 }
@ -688,9 +688,16 @@ case_instr:
expr = $2;
kwd_of = $3;
lead_vbar = $4;
cases_instr = $5;
cases = $5;
kwd_end = $6}
in {region; value}}
(*| Case expr LBRACKET option(VBAR) case_instr RBRACKET {
let region = cover $1 $6 in
let value = {
k
}
}
*)
cases_instr:
nsepseq(case_clause_instr,VBAR) {
@ -699,8 +706,9 @@ cases_instr:
case_clause_instr:
pattern ARROW instruction {
let region = cover (pattern_to_region $1) (instr_to_region $3)
and value = {pattern = $1; arrow = $2; instr = $3}
let start = pattern_to_region $1 in
let region = cover start (instr_to_region $3)
and value = {pattern=$1; arrow=$2; rhs=$3}
in {region; value}}
assignment:
@ -779,12 +787,12 @@ expr:
case_expr:
Case expr Of option(VBAR) cases_expr End {
let region = cover $1 $6 in
let value = {
let value : expr case = {
kwd_case = $1;
expr = $2;
kwd_of = $3;
lead_vbar = $4;
cases_expr = $5;
cases = $5;
kwd_end = $6}
in ECase {region; value}}
@ -795,8 +803,9 @@ cases_expr:
case_clause_expr:
pattern ARROW expr {
let region = cover (pattern_to_region $1) (expr_to_region $3)
and value = {pattern = $1; arrow = $2; expr = $3}
let start = pattern_to_region $1 in
let region = cover start (expr_to_region $3)
and value = {pattern=$1; arrow=$2; rhs=$3}
in {region; value}}
disj_expr:

14
src/ligo/simplify.ml
View File

@ -163,13 +163,13 @@ let rec simpl_expression (t:Raw.expr) : ae result =
| ECase c ->
let%bind e = simpl_expression c.value.expr in
let%bind lst =
let aux (x:Raw.case_clause_expr) =
let%bind expr = simpl_expression x.expr in
let aux (x : Raw.expr Raw.case_clause) =
let%bind expr = simpl_expression x.rhs in
ok (x.pattern, expr) in
bind_list
@@ List.map aux
@@ List.map get_value
@@ npseq_to_list c.value.cases_expr.value in
@@ npseq_to_list c.value.cases.value in
let%bind cases = simpl_cases lst in
ok @@ ae @@ E_matching (e, cases)
| EMap (MapInj mi) ->
@ -393,16 +393,16 @@ and simpl_single_instruction : Raw.single_instr -> instruction result = fun t ->
| _ -> simple_fail "no weird assignments yet"
in
ok @@ I_assignment {name ; annotated_expression}
| Case_instr c ->
| CaseInstr c ->
let c = c.value in
let%bind expr = simpl_expression c.expr in
let%bind cases =
let aux (x : Raw.case_clause_instr Raw.reg) =
let%bind i = simpl_instruction_block x.value.instr in
let aux (x : Raw.instruction Raw.case_clause Raw.reg) =
let%bind i = simpl_instruction_block x.value.rhs in
ok (x.value.pattern, i) in
bind_list
@@ List.map aux
@@ npseq_to_list c.cases_instr.value in
@@ npseq_to_list c.cases.value in
let%bind m = simpl_cases cases in
ok @@ I_matching (expr, m)
| RecordPatch r ->