From f8dcca8a12c9a568c02fe535f216a66df895ff31 Mon Sep 17 00:00:00 2001 From: Galfour Date: Sun, 31 Mar 2019 11:55:52 +0000 Subject: [PATCH] add expression pattern-matching --- src/ligo/ast_simplified.ml | 74 +++++++++++++++++++----------- src/ligo/ast_typed.ml | 40 +++++++++------- src/ligo/contracts/match.ligo | 7 +++ src/ligo/ligo-parser/AST.ml | 67 +++++++++++++++++++++------ src/ligo/ligo-parser/AST.mli | 28 +++++++++-- src/ligo/ligo-parser/Parser.mly | 41 ++++++++++++++--- src/ligo/mini_c.ml | 23 ++++++++-- src/ligo/simplify.ml | 24 +++++++--- src/ligo/test/integration_tests.ml | 15 ++++++ src/ligo/transpiler.ml | 13 +++++- src/ligo/typer.ml | 61 ++++++++++++++---------- 11 files changed, 287 insertions(+), 106 deletions(-) diff --git a/src/ligo/ast_simplified.ml b/src/ligo/ast_simplified.ml index 716a27c4d..905f63ec7 100644 --- a/src/ligo/ast_simplified.ml +++ b/src/ligo/ast_simplified.ml @@ -66,6 +66,8 @@ and expression = (* Data Structures *) | Map of (ae * ae) list | LookUp of (ae * ae) + (* Matching *) + | Matching_expr of (ae * matching_expr) and access = | Tuple_access of int @@ -85,26 +87,30 @@ and b = block and instruction = | Assignment of named_expression - | Matching of ae * matching + | Matching_instr of ae * matching_instr | Loop of ae * b | Skip | Fail of ae | Record_patch of name * access_path * (string * ae) list -and matching = +and 'a matching = | Match_bool of { - match_true : b ; - match_false : b ; + match_true : 'a ; + match_false : 'a ; } | Match_list of { - match_nil : b ; - match_cons : name * name * b ; + match_nil : 'a ; + match_cons : name * name * 'a ; } | Match_option of { - match_none : b ; - match_some : name * b ; + match_none : 'a ; + match_some : name * 'a ; } - | Match_tuple of name list * b + | Match_tuple of name list * 'a + +and matching_instr = b matching + +and matching_expr = annotated_expression matching let ae expression = {expression ; type_annotation = None} @@ -146,6 +152,8 @@ module PP = struct fprintf ppf "lambda (%s:%a) : %a {%a} return %a" binder type_expression input_type type_expression output_type block body annotated_expression result + | Matching_expr (ae, m) -> + fprintf ppf "match %a with %a" annotated_expression ae (matching annotated_expression) m and assoc_annotated_expression ppf : (ae * ae) -> unit = fun (a, b) -> fprintf ppf "%a -> %a" annotated_expression a annotated_expression b @@ -171,15 +179,16 @@ module PP = struct and single_record_patch ppf ((p, ae) : string * ae) = fprintf ppf "%s <- %a" p annotated_expression ae - and matching ppf (m:matching) = match m with + and matching : type a . (formatter -> a -> unit) -> formatter -> a matching -> unit = + fun f ppf m -> match m with | Match_tuple (lst, b) -> - fprintf ppf "let (%a) = %a" (list_sep (fun ppf -> fprintf ppf "%s")) lst block b + fprintf ppf "let (%a) = %a" (list_sep (fun ppf -> fprintf ppf "%s")) lst f b | Match_bool {match_true ; match_false} -> - fprintf ppf "| True -> %a @.| False -> %a" block match_true block match_false + fprintf ppf "| True -> %a @.| False -> %a" f match_true f match_false | Match_list {match_nil ; match_cons = (hd, tl, match_cons)} -> - fprintf ppf "| Nil -> %a @.| %s :: %s -> %a" block match_nil hd tl block match_cons + fprintf ppf "| Nil -> %a @.| %s :: %s -> %a" f match_nil hd tl f match_cons | Match_option {match_none ; match_some = (some, match_some)} -> - fprintf ppf "| None -> %a @.| Some %s -> %a" block match_none some block match_some + fprintf ppf "| None -> %a @.| Some %s -> %a" f match_none some f match_some and instruction ppf (i:instruction) = match i with | Skip -> fprintf ppf "skip" @@ -188,8 +197,8 @@ module PP = struct | Loop (cond, b) -> fprintf ppf "while (%a) { %a }" annotated_expression cond block b | Assignment {name;annotated_expression = ae} -> fprintf ppf "%s := %a" name annotated_expression ae - | Matching (ae, m) -> - fprintf ppf "match %a with %a" annotated_expression ae matching m + | Matching_instr (ae, m) -> + fprintf ppf "match %a with %a" annotated_expression ae (matching block) m let declaration ppf (d:declaration) = match d with | Type_declaration {type_name ; type_expression = te} -> @@ -227,10 +236,10 @@ module Rename = struct let%bind cond' = rename_annotated_expression r cond in let%bind body' = rename_block r body in ok (Loop (cond', body')) - | Matching (ae, m) -> + | Matching_instr (ae, m) -> let%bind ae' = rename_annotated_expression r ae in - let%bind m' = rename_matching r m in - ok (Matching (ae', m')) + let%bind m' = rename_matching rename_block r m in + ok (Matching_instr (ae', m')) | Record_patch (v, path, lst) -> let aux (x, y) = let%bind y' = rename_annotated_expression (filter r v) y in @@ -246,29 +255,34 @@ module Rename = struct and rename_block (r:renamings) (bl:block) : block result = bind_map_list (rename_instruction r) bl - and rename_matching (r:renamings) (m:matching) : matching result = + and rename_matching : type a . (renamings -> a -> a result) -> renamings -> a matching -> a matching result = + fun f r m -> match m with | Match_bool { match_true = mt ; match_false = mf } -> - let%bind match_true = rename_block r mt in - let%bind match_false = rename_block r mf in + let%bind match_true = f r mt in + let%bind match_false = f r mf in ok (Match_bool {match_true ; match_false}) | Match_option { match_none = mn ; match_some = (some, ms) } -> - let%bind match_none = rename_block r mn in - let%bind ms' = rename_block (filter r some) ms in + let%bind match_none = f r mn in + let%bind ms' = f (filter r some) ms in ok (Match_option {match_none ; match_some = (some, ms')}) | Match_list { match_nil = mn ; match_cons = (hd, tl, mc) } -> - let%bind match_nil = rename_block r mn in - let%bind mc' = rename_block (filters r [hd;tl]) mc in + let%bind match_nil = f r mn in + let%bind mc' = f (filters r [hd;tl]) mc in ok (Match_list {match_nil ; match_cons = (hd, tl, mc')}) | Match_tuple (lst, body) -> - let%bind body' = rename_block (filters r lst) body in + let%bind body' = f (filters r lst) body in ok (Match_tuple (lst, body')) + and rename_matching_instruction = fun x -> rename_matching rename_block x + + and rename_matching_expr = fun x -> rename_matching rename_expression x + and rename_annotated_expression (r:renamings) (ae:annotated_expression) : annotated_expression result = let%bind expression = rename_expression r ae.expression in ok {ae with expression} - and rename_expression (r:renamings) (e:expression) : expression result = + and rename_expression : renamings -> expression -> expression result = fun r e -> match e with | Literal _ as l -> ok l | Constant (name, lst) -> @@ -315,6 +329,10 @@ module Rename = struct | LookUp m -> let%bind m' = bind_map_pair (rename_annotated_expression r) m in ok (LookUp m') + | Matching_expr (ae, m) -> + let%bind ae' = rename_annotated_expression r ae in + let%bind m' = rename_matching rename_annotated_expression r m in + ok (Matching_expr (ae', m')) end end diff --git a/src/ligo/ast_typed.ml b/src/ligo/ast_typed.ml index cc9279ae4..0cbe904ee 100644 --- a/src/ligo/ast_typed.ml +++ b/src/ligo/ast_typed.ml @@ -67,6 +67,8 @@ and expression = (* Data Structures *) | Map of (ae * ae) list | LookUp of (ae * ae) + (* Advanced *) + | Matching_expr of (ae * matching_expr) and value = annotated_expression (* todo (for refactoring) *) @@ -83,25 +85,29 @@ and b = block and instruction = | Assignment of named_expression - | Matching of ae * matching + | Matching_instr of ae * matching_instr | Loop of ae * b | Skip | Fail of ae -and matching = +and 'a matching = | Match_bool of { - match_true : b ; - match_false : b ; + match_true : 'a ; + match_false : 'a ; } | Match_list of { - match_nil : b ; - match_cons : name * name * b ; + match_nil : 'a ; + match_cons : name * name * 'a ; } | Match_option of { - match_none : b ; - match_some : (name * type_value) * b ; + match_none : 'a ; + match_some : (name * type_value) * 'a ; } - | Match_tuple of name list * b + | Match_tuple of name list * 'a + +and matching_instr = b matching + +and matching_expr = ae matching open! Ligo_helpers.Trace @@ -165,6 +171,8 @@ module PP = struct | Record m -> fprintf ppf "record[%a]" (smap_sep annotated_expression) m | Map m -> fprintf ppf "map[%a]" (list_sep assoc_annotated_expression) m | LookUp (ds, i) -> fprintf ppf "(%a)[%a]" annotated_expression ds annotated_expression i + | Matching_expr (ae, m) -> + fprintf ppf "match %a with %a" annotated_expression ae (matching annotated_expression) m and assoc_annotated_expression ppf : (ae * ae) -> unit = fun (a, b) -> fprintf ppf "%a -> %a" annotated_expression a annotated_expression b @@ -183,15 +191,15 @@ module PP = struct and single_record_patch ppf ((s, ae) : string * ae) = fprintf ppf "%s <- %a" s annotated_expression ae - and matching ppf (m:matching) = match m with + and matching : type a . (formatter -> a -> unit) -> _ -> a matching -> unit = fun f ppf m -> match m with | Match_tuple (lst, b) -> - fprintf ppf "let (%a) = %a" (list_sep (fun ppf -> fprintf ppf "%s")) lst block b + fprintf ppf "let (%a) = %a" (list_sep (fun ppf -> fprintf ppf "%s")) lst f b | Match_bool {match_true ; match_false} -> - fprintf ppf "| True -> %a @.| False -> %a" block match_true block match_false + fprintf ppf "| True -> %a @.| False -> %a" f match_true f match_false | Match_list {match_nil ; match_cons = (hd, tl, match_cons)} -> - fprintf ppf "| Nil -> %a @.| %s :: %s -> %a" block match_nil hd tl block match_cons + fprintf ppf "| Nil -> %a @.| %s :: %s -> %a" f match_nil hd tl f match_cons | Match_option {match_none ; match_some = (some, match_some)} -> - fprintf ppf "| None -> %a @.| Some %s -> %a" block match_none (fst some) block match_some + fprintf ppf "| None -> %a @.| Some %s -> %a" f match_none (fst some) f match_some and instruction ppf (i:instruction) = match i with | Skip -> fprintf ppf "skip" @@ -199,8 +207,8 @@ module PP = struct | Loop (cond, b) -> fprintf ppf "while (%a) { %a }" annotated_expression cond block b | Assignment {name;annotated_expression = ae} -> fprintf ppf "%s := %a" name annotated_expression ae - | Matching (ae, m) -> - fprintf ppf "match %a with %a" annotated_expression ae matching m + | Matching_instr (ae, m) -> + fprintf ppf "match %a with %a" annotated_expression ae (matching block) m let declaration ppf (d:declaration) = match d with diff --git a/src/ligo/contracts/match.ligo b/src/ligo/contracts/match.ligo index 6f3d3afd1..06e1fe4d8 100644 --- a/src/ligo/contracts/match.ligo +++ b/src/ligo/contracts/match.ligo @@ -15,3 +15,10 @@ function match_option (const o : option(int)) : int is | Some(s) -> result := s end end with result + +function match_expr_bool (const i : int) : int is + begin skip end with + case i = 2 of + | True -> 42 + | False -> 0 + end diff --git a/src/ligo/ligo-parser/AST.ml b/src/ligo/ligo-parser/AST.ml index a57455fae..44be4d4f2 100644 --- a/src/ligo/ligo-parser/AST.ml +++ b/src/ligo/ligo-parser/AST.ml @@ -345,7 +345,7 @@ and instruction = and single_instr = Cond of conditional reg -| Case of case_instr reg +| Case_instr of case_instr reg | Assign of assignment reg | Loop of loop | ProcCall of fun_call @@ -430,18 +430,35 @@ and case_instr = { expr : expr; kwd_of : kwd_of; lead_vbar : vbar option; - cases : cases; + cases_instr : cases_instr; kwd_end : kwd_end } -and cases = (case reg, vbar) nsepseq reg +and cases_instr = (case_clause_instr reg, vbar) nsepseq reg -and case = { +and case_clause_instr = { 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; +} + and assignment = { lhs : lhs; assign : assign; @@ -498,7 +515,8 @@ and for_collect = { (* Expressions *) and expr = - ELogic of logic_expr +| ECase of case_expr reg +| ELogic of logic_expr | EArith of arith_expr | EString of string_expr | EList of list_expr @@ -683,7 +701,7 @@ let type_expr_to_region = function | TAlias {region; _} -> region let rec expr_to_region = function - ELogic e -> logic_expr_to_region e +| ELogic e -> logic_expr_to_region e | EArith e -> arith_expr_to_region e | EString e -> string_expr_to_region e | EList e -> list_expr_to_region e @@ -697,6 +715,7 @@ let rec expr_to_region = function | ECall {region; _} | EBytes {region; _} | EUnit region +| ECase {region;_} | EPar {region; _} -> region and tuple_expr_to_region = function @@ -761,7 +780,7 @@ let path_to_region = function let instr_to_region = function Single Cond {region; _} -| Single Case {region; _} +| Single Case_instr {region; _} | Single Assign {region; _} | Single Loop While {region; _} | Single Loop For ForInt {region; _} @@ -1087,7 +1106,7 @@ and print_instruction = function and print_single_instr = function Cond {value; _} -> print_conditional value -| Case {value; _} -> print_case_instr value +| Case_instr {value; _} -> print_case_instr value | Assign assign -> print_assignment assign | Loop loop -> print_loop loop | ProcCall fun_call -> print_fun_call fun_call @@ -1126,22 +1145,22 @@ and print_if_clause = function and print_case_instr (node : case_instr) = let {kwd_case; expr; kwd_of; - lead_vbar; cases; kwd_end} = node in + lead_vbar; cases_instr; kwd_end} = node in print_token kwd_case "case"; print_expr expr; print_token kwd_of "of"; print_token_opt lead_vbar "|"; - print_cases cases; + print_cases_instr cases_instr; print_token kwd_end "end" and print_token_opt = function None -> fun _ -> () | Some region -> print_token region -and print_cases {value; _} = - print_nsepseq "|" print_case value +and print_cases_instr {value; _} = + print_nsepseq "|" print_case_clause_instr value -and print_case {value; _} = +and print_case_clause_instr {value; _} = let {pattern; arrow; instr} = value in print_pattern pattern; print_token arrow "->"; @@ -1218,7 +1237,8 @@ and print_bind_to = function | None -> () and print_expr = function - ELogic e -> print_logic_expr e + ECase {value;_} -> print_case_expr value +| ELogic e -> print_logic_expr e | EArith e -> print_arith_expr e | EString e -> print_string_expr e | EList e -> print_list_expr e @@ -1234,6 +1254,25 @@ and print_expr = function | ETuple e -> print_tuple_expr e | EPar e -> print_par_expr e +and print_case_expr (node : case_expr) = + let {kwd_case; expr; kwd_of; + lead_vbar; cases_expr; 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_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 + print_pattern pattern; + print_token arrow "->"; + print_expr expr + and print_map_expr = function MapLookUp {value; _} -> print_map_lookup value | MapInj inj -> print_injection "map" print_binding inj diff --git a/src/ligo/ligo-parser/AST.mli b/src/ligo/ligo-parser/AST.mli index a465e32a8..479a9f2c8 100644 --- a/src/ligo/ligo-parser/AST.mli +++ b/src/ligo/ligo-parser/AST.mli @@ -329,7 +329,7 @@ and instruction = and single_instr = Cond of conditional reg -| Case of case_instr reg +| Case_instr of case_instr reg | Assign of assignment reg | Loop of loop | ProcCall of fun_call @@ -414,18 +414,35 @@ and case_instr = { expr : expr; kwd_of : kwd_of; lead_vbar : vbar option; - cases : cases; + cases_instr : cases_instr; kwd_end : kwd_end } -and cases = (case reg, vbar) nsepseq reg +and cases_instr = (case_clause_instr reg, vbar) nsepseq reg -and case = { +and case_clause_instr = { 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; +} + and assignment = { lhs : lhs; assign : assign; @@ -482,7 +499,8 @@ and for_collect = { (* Expressions *) and expr = - ELogic of logic_expr + ECase of case_expr reg +| ELogic of logic_expr | EArith of arith_expr | EString of string_expr | EList of list_expr diff --git a/src/ligo/ligo-parser/Parser.mly b/src/ligo/ligo-parser/Parser.mly index 5539bff46..dc4b56d26 100644 --- a/src/ligo/ligo-parser/Parser.mly +++ b/src/ligo/ligo-parser/Parser.mly @@ -483,7 +483,7 @@ instruction: single_instr: conditional { Cond $1 } -| case_instr { Case $1 } +| case_instr { Case_instr $1 } | assignment { Assign $1 } | loop { Loop $1 } | proc_call { ProcCall $1 } @@ -672,23 +672,23 @@ if_clause: ClauseBlock {value; region}} case_instr: - Case expr Of option(VBAR) cases End { + Case expr Of option(VBAR) cases_instr End { let region = cover $1 $6 in let value = { kwd_case = $1; expr = $2; kwd_of = $3; lead_vbar = $4; - cases = $5; + cases_instr = $5; kwd_end = $6} in {region; value}} -cases: - nsepseq(case,VBAR) { +cases_instr: + nsepseq(case_clause_instr,VBAR) { let region = nsepseq_to_region (fun x -> x.region) $1 in {region; value = $1}} -case: +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} @@ -764,7 +764,34 @@ interactive_expr: expr EOF { $1 } expr: - expr Or conj_expr { + case_expr { $1 } +| disj_expr { $1 } + +case_expr: + Case expr Of option(VBAR) cases_expr End { + let region = cover $1 $6 in + let value = { + kwd_case = $1; + expr = $2; + kwd_of = $3; + lead_vbar = $4; + cases_expr = $5; + kwd_end = $6} + in ECase {region; value}} + +cases_expr: + nsepseq(case_clause_expr,VBAR) { + let region = nsepseq_to_region (fun x -> x.region) $1 + in {region; value = $1}} + +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} + in {region; value}} + +disj_expr: + disj_expr Or conj_expr { let start = expr_to_region $1 and stop = expr_to_region $3 in let region = cover start stop diff --git a/src/ligo/mini_c.ml b/src/ligo/mini_c.ml index 09b283b8a..5e6fc8161 100644 --- a/src/ligo/mini_c.ml +++ b/src/ligo/mini_c.ml @@ -70,6 +70,7 @@ and expression' = | Var of var_name | Empty_map of (type_value * type_value) | Make_None of type_value + | E_Cond of expression * expression * expression and expression = expression' * type_value * environment (* Environment in which the expressions are evaluated *) @@ -77,7 +78,7 @@ and assignment = var_name * expression and statement' = | Assignment of assignment - | Cond of expression * block * block + | I_Cond of expression * block * block | If_None of expression * block * (var_name * block) | While of expression * block @@ -179,6 +180,7 @@ module PP = struct | Function_expression c -> function_ ppf c | Empty_map _ -> fprintf ppf "map[]" | Make_None _ -> fprintf ppf "none" + | E_Cond (c, a, b) -> fprintf ppf "%a ? %a : %a" expression c expression a expression b and function_ ppf ({binder ; input ; output ; body ; result}:anon_function_content) = fprintf ppf "fun (%s:%a) : %a %a return %a" @@ -192,7 +194,7 @@ module PP = struct and statement ppf ((s, _) : statement) = match s with | Assignment ass -> assignment ppf ass - | Cond (expr, i, e) -> fprintf ppf "if (%a) %a %a" expression expr block i block e + | I_Cond (expr, i, e) -> fprintf ppf "if (%a) %a %a" expression expr block i block e | If_None (expr, none, (name, some)) -> fprintf ppf "if (%a) %a %s.%a" expression expr block none name block some | While (e, b) -> fprintf ppf "while (%a) %a" expression e block b @@ -823,7 +825,18 @@ module Translate_program = struct ] in ok code | _ -> simple_fail "expected function code" - ) in + ) + | E_Cond (c, a, b) -> ( + let%bind c' = translate_expression c in + let%bind a' = translate_expression a in + let%bind b' = translate_expression b in + let%bind code = ok (seq [ + c' ; i_unpair ; + i_if a' b' ; + ]) in + ok code + ) + in let%bind () = let%bind (Ex_ty schema_ty) = Environment.to_ty env in @@ -874,7 +887,7 @@ module Translate_program = struct add ; ]; ]) - | Cond (expr, a, b) -> + | I_Cond (expr, a, b) -> let%bind expr = translate_expression expr in let%bind a = translate_regular_block a in let%bind b = translate_regular_block b in @@ -1195,7 +1208,7 @@ module Combinators = struct let statement s' e : statement = match s' with - | Cond _ -> s', id_environment_wrap e + | I_Cond _ -> s', id_environment_wrap e | If_None _ -> s', id_environment_wrap e | While _ -> s', id_environment_wrap e | Assignment (name, (_, t, _)) -> s', environment_wrap e (Environment.add (name, t) e) diff --git a/src/ligo/simplify.ml b/src/ligo/simplify.ml index 4fe56b2f9..05aa3e24f 100644 --- a/src/ligo/simplify.ml +++ b/src/ligo/simplify.ml @@ -160,6 +160,18 @@ let rec simpl_expression (t:Raw.expr) : ae result = | ELogic l -> simpl_logic_expression l | EList _ -> simple_fail "list: not supported yet" | ESet _ -> simple_fail "set: not supported yet" + | 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 + ok (x.pattern, expr) in + bind_list + @@ List.map aux + @@ List.map get_value + @@ npseq_to_list c.value.cases_expr.value in + let%bind cases = simpl_cases lst in + ok @@ ae @@ Matching_expr (e, cases) | EMap (MapInj mi) -> let%bind lst = let lst = List.map get_value @@ pseq_to_list mi.value.elements in @@ -369,7 +381,7 @@ and simpl_single_instruction : Raw.single_instr -> instruction result = fun t -> let%bind match_false = match c.ifnot with | ClauseInstr i -> let%bind i = simpl_instruction i in ok [i] | ClauseBlock b -> simpl_statements @@ fst b.value.inside in - ok @@ Matching (expr, (Match_bool {match_true; match_false})) + ok @@ Matching_instr (expr, (Match_bool {match_true; match_false})) | Assign a -> let a = a.value in let%bind name = match a.lhs with @@ -381,18 +393,18 @@ and simpl_single_instruction : Raw.single_instr -> instruction result = fun t -> | _ -> simple_fail "no weird assignments yet" in ok @@ Assignment {name ; annotated_expression} - | Case c -> + | Case_instr c -> let c = c.value in let%bind expr = simpl_expression c.expr in let%bind cases = - let aux (x : Raw.case Raw.reg) = + let aux (x : Raw.case_clause_instr Raw.reg) = let%bind i = simpl_instruction_block x.value.instr in ok (x.value.pattern, i) in bind_list @@ List.map aux - @@ npseq_to_list c.cases.value in + @@ npseq_to_list c.cases_instr.value in let%bind m = simpl_cases cases in - ok @@ Matching (expr, m) + ok @@ Matching_instr (expr, m) | RecordPatch r -> let r = r.value in let%bind record = match r.path with @@ -409,7 +421,7 @@ and simpl_single_instruction : Raw.single_instr -> instruction result = fun t -> | MapRemove _ -> simple_fail "no map remove yet" | SetRemove _ -> simple_fail "no set remove yet" -and simpl_cases : (Raw.pattern * block) list -> matching result = fun t -> +and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t -> let open Raw in let get_var (t:Raw.pattern) = match t with | PVar v -> ok v.value diff --git a/src/ligo/test/integration_tests.ml b/src/ligo/test/integration_tests.ml index 2bf8f2f76..5569cef77 100644 --- a/src/ligo/test/integration_tests.ml +++ b/src/ligo/test/integration_tests.ml @@ -239,6 +239,21 @@ let matching () : unit result = @@ [0 ; 2 ; 42 ; 163 ; -1] in ok () in + let%bind _expr_bool = + let aux n = + let open AST_Typed.Combinators in + let input = a_int n in + let%bind result = easy_run_typed "match_expr_bool" program input in + let%bind result' = + trace (simple_error "bad result") @@ + get_a_int result in + Assert.assert_equal_int (if n = 2 then 42 else 0) result' + in + let%bind _ = bind_list + @@ List.map aux + @@ [0 ; 2 ; 42 ; 163 ; -1] in + ok () + in let%bind _option = let aux n = let open AST_Typed.Combinators in diff --git a/src/ligo/transpiler.ml b/src/ligo/transpiler.ml index 3713c2c23..73b5a4553 100644 --- a/src/ligo/transpiler.ml +++ b/src/ligo/transpiler.ml @@ -74,14 +74,14 @@ and translate_instruction (env:Environment.t) (i:AST.instruction) : statement op let%bind (_, t, _) as expression = translate_annotated_expression env annotated_expression in let env' = Environment.add (name, t) env in return ~env' (Assignment (name, expression)) - | Matching (expr, m) -> ( + | Matching_instr (expr, m) -> ( let%bind expr' = translate_annotated_expression env expr in let env' = Environment.extend env in match m with | Match_bool {match_true ; match_false} -> ( let%bind true_branch = translate_block env' match_true in let%bind false_branch = translate_block env' match_false in - return (Cond (expr', true_branch, false_branch)) + return (I_Cond (expr', true_branch, false_branch)) ) | Match_option {match_none ; match_some = ((name, t), sm)} -> ( let%bind none_branch = translate_block env' match_none in @@ -235,6 +235,15 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express | LookUp dsi -> let%bind (ds', i') = bind_map_pair f dsi in return (Predicate ("GET", [i' ; ds']), tv) + | Matching_expr (expr, m) -> ( + let%bind expr' = translate_annotated_expression env expr in + match m with + | AST.Match_bool {match_true ; match_false} -> + let%bind (t, f) = bind_map_pair (translate_annotated_expression env) (match_true, match_false) in + return (E_Cond (expr', t, f), tv) + | AST.Match_list _ | AST.Match_option _ | AST.Match_tuple (_, _) -> + simple_fail "only match bool exprs are translated yet" + ) and translate_lambda_shallow env l tv = let { binder ; input_type ; output_type ; body ; result } : AST.lambda = l in diff --git a/src/ligo/typer.ml b/src/ligo/typer.ml index 376a82715..2229b1184 100644 --- a/src/ligo/typer.ml +++ b/src/ligo/typer.ml @@ -162,39 +162,40 @@ and type_instruction (e:environment) : I.instruction -> (environment * O.instruc let e' = Environment.add e name annotated_expression.type_annotation in ok (e', O.Assignment {name;annotated_expression}) ) - | Matching (ex, m) -> + | Matching_instr (ex, m) -> let%bind ex' = type_annotated_expression e ex in - let%bind m' = type_match e ex'.type_annotation m in - ok (e, O.Matching (ex', m')) + let%bind m' = type_match type_block e ex'.type_annotation m in + ok (e, O.Matching_instr (ex', m')) | Record_patch _ -> simple_fail "no record_patch yet" -and type_match (e:environment) (t:O.type_value) : I.matching -> O.matching result = function +and type_match : type i o . (environment -> i -> o result) -> environment -> O.type_value -> i I.matching -> o O.matching result = + fun f e t i -> match i with | Match_bool {match_true ; match_false} -> let%bind _ = trace_strong (simple_error "Matching bool on not-a-bool") @@ get_t_bool t in - let%bind match_true = type_block e match_true in - let%bind match_false = type_block e match_false in + let%bind match_true = f e match_true in + let%bind match_false = f e match_false in ok (O.Match_bool {match_true ; match_false}) | Match_option {match_none ; match_some} -> let%bind t_opt = trace_strong (simple_error "Matching option on not-an-option") @@ get_t_option t in - let%bind match_none = type_block e match_none in + let%bind match_none = f e match_none in let (n, b) = match_some in let n' = n, t_opt in let e' = Environment.add e n t_opt in - let%bind b' = type_block e' b in + let%bind b' = f e' b in ok (O.Match_option {match_none ; match_some = (n', b')}) | Match_list {match_nil ; match_cons} -> let%bind t_list = trace_strong (simple_error "Matching list on not-an-list") @@ get_t_list t in - let%bind match_nil = type_block e match_nil in + let%bind match_nil = f e match_nil in let (hd, tl, b) = match_cons in let e' = Environment.add e hd t_list in let e' = Environment.add e' tl t in - let%bind b' = type_block e' b in + let%bind b' = f e' b in ok (O.Match_list {match_nil ; match_cons = (hd, tl, b')}) | Match_tuple (lst, b) -> let%bind t_tuple = @@ -205,7 +206,7 @@ and type_match (e:environment) (t:O.type_value) : I.matching -> O.matching resul @@ (fun () -> List.combine lst t_tuple) in let aux prev (name, tv) = Environment.add prev name tv in let e' = List.fold_left aux e lst' in - let%bind b' = type_block e' b in + let%bind b' = f e' b in ok (O.Match_tuple (lst, b')) and evaluate_type (e:environment) (t:I.type_expression) : O.type_value result = @@ -383,7 +384,17 @@ and type_annotated_expression (e:environment) (ae:I.annotated_expression) : O.an let dst_opt = make_t_option dst in let%bind type_annotation = check dst_opt in ok O.{expression = LookUp (ds, ind) ; type_annotation} - + (* Advanced *) + | Matching_expr (ex, m) -> ( + let%bind ex' = type_annotated_expression e ex in + let%bind m' = type_match type_annotated_expression e ex'.type_annotation m in + let%bind type_annotation = match m' with + | Match_bool {match_true ; match_false} -> + let%bind _ = O.assert_type_value_eq (match_true.type_annotation, match_false.type_annotation) in + ok match_true.type_annotation + | _ -> simple_fail "can only type match_bool expressions yet" in + ok O.{expression = Matching_expr (ex', m') ; type_annotation} + ) and type_constant (name:string) (lst:O.type_value list) (tv_opt:O.type_value option) : (string * O.type_value) result = (* Constant poorman's polymorphism *) @@ -476,6 +487,10 @@ let rec untype_annotated_expression (e:O.annotated_expression) : (I.annotated_ex | LookUp dsi -> let%bind dsi' = bind_map_pair untype_annotated_expression dsi in return (LookUp dsi') + | Matching_expr (ae, m) -> + let%bind ae' = untype_annotated_expression ae in + let%bind m' = untype_matching untype_annotated_expression m in + return (Matching_expr (ae', m')) and untype_block (b:O.block) : (I.block) result = bind_list @@ List.map untype_instruction b @@ -494,28 +509,28 @@ and untype_instruction (i:O.instruction) : (I.instruction) result = | Assignment a -> let%bind annotated_expression = untype_annotated_expression a.annotated_expression in ok @@ Assignment {name = a.name ; annotated_expression} - | Matching (e, m) -> + | Matching_instr (e, m) -> let%bind e' = untype_annotated_expression e in - let%bind m' = untype_matching m in - ok @@ Matching (e', m') + let%bind m' = untype_matching untype_block m in + ok @@ Matching_instr (e', m') -and untype_matching (m:O.matching) : (I.matching) result = +and untype_matching : type o i . (o -> i result) -> o O.matching -> (i I.matching) result = fun f m -> let open I in match m with | Match_bool {match_true ; match_false} -> - let%bind match_true = untype_block match_true in - let%bind match_false = untype_block match_false in + let%bind match_true = f match_true in + let%bind match_false = f match_false in ok @@ Match_bool {match_true ; match_false} | Match_tuple (lst, b) -> - let%bind b = untype_block b in + let%bind b = f b in ok @@ Match_tuple (lst, b) | Match_option {match_none ; match_some = (v, some)} -> - let%bind match_none = untype_block match_none in - let%bind some = untype_block some in + let%bind match_none = f match_none in + let%bind some = f some in let match_some = fst v, some in ok @@ Match_option {match_none ; match_some} | Match_list {match_nil ; match_cons = (hd, tl, cons)} -> - let%bind match_nil = untype_block match_nil in - let%bind cons = untype_block cons in + let%bind match_nil = f match_nil in + let%bind cons = f cons in let match_cons = hd, tl, cons in ok @@ Match_list {match_nil ; match_cons}