From 999bee70520476d135ac1861f8d51f64e503861a Mon Sep 17 00:00:00 2001 From: milner Date: Wed, 18 Jan 2017 11:07:00 +0000 Subject: [PATCH] Parse records and keyed collection queries --- example/expensive_order.delta | 13 +++++ src/lexer.mll | 8 +++ src/main.ml | 2 +- src/parse.ml | 39 +++++++++++++ src/parse.mli | 1 + src/parser.mly | 74 ++++++++++++++++++++++- src/syntax.ml | 64 ++++++++++++++++++++ test/fixture/count_large.delta | 9 +++ test/fixture/expensive_order.delta | 13 +++++ test/fixture/revenue.delta | 11 ++++ test/test_main.ml | 94 ++++++++++++++++++++++++++++++ 11 files changed, 324 insertions(+), 4 deletions(-) create mode 100644 example/expensive_order.delta create mode 100644 test/fixture/count_large.delta create mode 100644 test/fixture/expensive_order.delta create mode 100644 test/fixture/revenue.delta diff --git a/example/expensive_order.delta b/example/expensive_order.delta new file mode 100644 index 0000000..508c28f --- /dev/null +++ b/example/expensive_order.delta @@ -0,0 +1,13 @@ +type order = { + customer : string; + total : int; +} + +input orders : collection order + +let tax n = n * 20 / 100 + +query expensive_orders = + orders + |> filter (fun o -> o.total > 1000) + |> map (fun o -> (o.customer, tax o.total)) diff --git a/src/lexer.mll b/src/lexer.mll index 1be1e32..db55bd4 100644 --- a/src/lexer.mll +++ b/src/lexer.mll @@ -16,6 +16,14 @@ let keyword = function | "if" -> IF | "then" -> THEN | "else" -> ELSE + | "type" -> TYPE + | "input" -> INPUT + | "collection" -> COLLECTION + | "query" -> QUERY + | "filter" -> FILTER + | "map" -> MAP + | "sum" -> SUM + | "count" -> COUNT | "true" -> BOOL true | "false" -> BOOL false | text -> IDENT text diff --git a/src/main.ml b/src/main.ml index 6ecb3a2..29efa65 100644 --- a/src/main.ml +++ b/src/main.ml @@ -85,7 +85,7 @@ let load_source path = Diagnostic.set_file path; Native.read_file path -let parse_source path = Parse.expression (load_source path) +let parse_source path = Parse.program (load_source path) let frontend_unavailable () = Diagnostic.error Location.none "the delta pipeline beyond parsing is not implemented in this revision" diff --git a/src/parse.ml b/src/parse.ml index 3ff2650..27be4a1 100644 --- a/src/parse.ml +++ b/src/parse.ml @@ -15,3 +15,42 @@ let unexpected text lexbuf = let expression text = let lexbuf = Lexing.from_string text in try Parser.expr Lexer.token lexbuf with Parsing.Parse_error -> unexpected text lexbuf + +let declarations text = + let lexbuf = Lexing.from_string text in + try Parser.declarations Lexer.token lexbuf with Parsing.Parse_error -> unexpected text lexbuf + +let single kind name explain items span_of = + match items with + | [ item ] -> item + | [] -> Diagnostic.error Location.none "the program declares no %s: add `%s`" kind explain + | _ :: second :: _ -> Diagnostic.error (span_of second) "the program declares more than one %s" kind + +let program text = + let items = declarations text in + let records = ref [] in + let inputs = ref [] in + let helpers = ref [] in + let queries = ref [] in + List.iter + (fun item -> + match item with + | Syntax.DRecord record -> records := record :: !records + | Syntax.DInput input -> inputs := input :: !inputs + | Syntax.DHelper helper -> helpers := helper :: !helpers + | Syntax.DQuery query -> queries := query :: !queries) + items; + let input = + single "input collection" "input collection" "input NAME : collection T" + (List.rev !inputs) (fun input -> input.Syntax.in_span) + in + let query = + single "query" "query" "query NAME = EXPRESSION" (List.rev !queries) + (fun query -> query.Syntax.q_span) + in + { + Syntax.prog_records = List.rev !records; + prog_input = input; + prog_helpers = List.rev !helpers; + prog_query = query; + } diff --git a/src/parse.mli b/src/parse.mli index 1408d12..3c85a5b 100644 --- a/src/parse.mli +++ b/src/parse.mli @@ -1 +1,2 @@ val expression : string -> Syntax.expr +val program : string -> Syntax.program diff --git a/src/parser.mly b/src/parser.mly index a8ec0f2..5216513 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -2,6 +2,9 @@ open Syntax let here () = Location.span_of_lexing (Parsing.symbol_start_pos ()) (Parsing.symbol_end_pos ()) + +let symbol_span index = + Location.span_of_lexing (Parsing.rhs_start_pos index) (Parsing.rhs_end_pos index) %} %token INT @@ -9,6 +12,7 @@ let here () = Location.span_of_lexing (Parsing.symbol_start_pos ()) (Parsing.sym %token STRING %token IDENT %token LET IN FUN IF THEN ELSE +%token TYPE INPUT COLLECTION QUERY FILTER MAP SUM COUNT %token ARROW PIPE AND OR %token EQ NE LT LE GT GE %token PLUS MINUS STAR SLASH @@ -17,11 +21,16 @@ let here () = Location.span_of_lexing (Parsing.symbol_start_pos ()) (Parsing.sym %start expr %type expr +%start declarations +%type declarations %% expr: | pipeline { $1 } + | LET IDENT EQ expr IN expr { make (ELet ($2, $4, $6)) (here ()) } + | FUN IDENT ARROW expr { make (ELambda ($2, $4)) (here ()) } + | IF expr THEN expr ELSE expr { make (EIf ($2, $4, $6)) (here ()) } pipeline: | disjunction { $1 } @@ -72,9 +81,10 @@ atom: | LPAREN expr COMMA expr_list RPAREN { make (ETuple ($2 :: $4)) (here ()) } | LBRACE record_fields RBRACE { make (ERecord $2) (here ()) } | atom DOT IDENT { make (EField ($1, $3)) (here ()) } - | LET IDENT EQ expr IN expr { make (ELet ($2, $4, $6)) (here ()) } - | FUN IDENT ARROW expr { make (ELambda ($2, $4)) (here ()) } - | IF expr THEN expr ELSE expr { make (EIf ($2, $4, $6)) (here ()) } + | FILTER atom { make (EFilter $2) (here ()) } + | MAP atom { make (EMap $2) (here ()) } + | SUM { make ESum (here ()) } + | COUNT { make ECount (here ()) } expr_list: | expr { [ $1 ] } @@ -83,3 +93,61 @@ expr_list: record_fields: | IDENT EQ expr { [ ($1, $3) ] } | IDENT EQ expr SEMI record_fields { ($1, $3) :: $5 } + | IDENT EQ expr SEMI { [ ($1, $3) ] } + +declarations: + | decls EOF { List.rev $1 } + +decls: + | { [] } + | decls declaration { $2 :: $1 } + +declaration: + | TYPE IDENT EQ LBRACE record_field_decls RBRACE { + DRecord { + rd_name = $2; + rd_name_span = symbol_span 2; + rd_fields = $5; + rd_span = here (); + } + } + | INPUT IDENT COLON type_expr { + DInput { in_name = $2; in_name_span = symbol_span 2; in_ty = $4; in_span = here () } + } + | LET IDENT helper_params EQ expr { + DHelper { + h_name = $2; + h_name_span = symbol_span 2; + h_params = $3; + h_body = $5; + h_span = here (); + } + } + | QUERY IDENT EQ expr { + DQuery { q_name = $2; q_name_span = symbol_span 2; q_body = $4; q_span = here () } + } + +helper_params: + | { [] } + | helper_param_list { $1 } + +helper_param_list: + | IDENT { [ $1 ] } + | IDENT helper_param_list { $1 :: $2 } + +record_field_decls: + | IDENT COLON type_expr { [ ($1, $3) ] } + | IDENT COLON type_expr SEMI record_field_decls { ($1, $3) :: $5 } + | IDENT COLON type_expr SEMI { [ ($1, $3) ] } + +type_expr: + | IDENT { make_ty (TyName $1) (here ()) } + | COLLECTION type_expr { make_ty (TyCollection $2) (here ()) } + | LPAREN type_expr RPAREN { $2 } + | LPAREN type_expr COMMA type_expr_list RPAREN { + make_ty (TyTuple ($2 :: $4)) (here ()) + } + +type_expr_list: + | type_expr { [ $1 ] } + | type_expr COMMA type_expr_list { $1 :: $3 } diff --git a/src/syntax.ml b/src/syntax.ml index bddfa87..136aed4 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -32,9 +32,67 @@ and expr_desc = | ETuple of expr list | ERecord of (string * expr) list | EField of expr * string + | EFilter of expr + | EMap of expr + | ESum + | ECount + +type tyexpr = { + ty : tyexpr_desc; + tyspan : Location.span; +} + +and tyexpr_desc = + | TyName of string + | TyCollection of tyexpr + | TyTuple of tyexpr list + +type record_decl = { + rd_name : string; + rd_name_span : Location.span; + rd_fields : (string * tyexpr) list; + rd_span : Location.span; +} + +type input_decl = { + in_name : string; + in_name_span : Location.span; + in_ty : tyexpr; + in_span : Location.span; +} + +type helper = { + h_name : string; + h_name_span : Location.span; + h_params : string list; + h_body : expr; + h_span : Location.span; +} + +type query = { + q_name : string; + q_name_span : Location.span; + q_body : expr; + q_span : Location.span; +} + +type declaration = + | DRecord of record_decl + | DInput of input_decl + | DHelper of helper + | DQuery of query + +type program = { + prog_records : record_decl list; + prog_input : input_decl; + prog_helpers : helper list; + prog_query : query; +} let make e espan = { e = e; espan = espan } +let make_ty ty tyspan = { ty = ty; tyspan = tyspan } + let binop_name = function | Add -> "+" | Sub -> "-" @@ -50,3 +108,9 @@ let binop_name = function | Or -> "||" let string_of_binop = binop_name + +let rec string_of_tyexpr tyexpr = + match tyexpr.ty with + | TyName name -> name + | TyCollection element -> "collection " ^ string_of_tyexpr element + | TyTuple elements -> "(" ^ String.concat ", " (List.map string_of_tyexpr elements) ^ ")" diff --git a/test/fixture/count_large.delta b/test/fixture/count_large.delta new file mode 100644 index 0000000..f79c30f --- /dev/null +++ b/test/fixture/count_large.delta @@ -0,0 +1,9 @@ +type order = { + customer : string; + total : int; +} + +input orders : collection order + +query count_large = + orders |> filter (fun o -> o.total > 500) |> count diff --git a/test/fixture/expensive_order.delta b/test/fixture/expensive_order.delta new file mode 100644 index 0000000..508c28f --- /dev/null +++ b/test/fixture/expensive_order.delta @@ -0,0 +1,13 @@ +type order = { + customer : string; + total : int; +} + +input orders : collection order + +let tax n = n * 20 / 100 + +query expensive_orders = + orders + |> filter (fun o -> o.total > 1000) + |> map (fun o -> (o.customer, tax o.total)) diff --git a/test/fixture/revenue.delta b/test/fixture/revenue.delta new file mode 100644 index 0000000..083c46f --- /dev/null +++ b/test/fixture/revenue.delta @@ -0,0 +1,11 @@ +type order = { + customer : string; + total : int; +} + +input orders : collection order + +let tax n = n * 20 / 100 + +query revenue = + orders |> map (fun o -> tax o.total) |> sum diff --git a/test/test_main.ml b/test/test_main.ml index 926b837..155844b 100644 --- a/test/test_main.ml +++ b/test/test_main.ml @@ -180,10 +180,104 @@ let parse_cases = (match parsed.Syntax.e with Syntax.EInt 7 -> true | _ -> false) ); ] +let root () = try Sys.getenv "DELTA_ROOT" with Not_found -> "." + +let fixture name = Filename.concat (root ()) (Filename.concat "test/fixtures" name) + +let read_fixture name = Native.read_file (fixture name) + +let program_error text = + try + ignore (Parse.program text); + None + with Diagnostic.Error diagnostic -> Some diagnostic + +let program_cases = + [ + ( "the required example parses into declarations", + fun () -> + let parsed = Parse.program (read_fixture "expensive_order.delta") in + check_equal_int "one record declaration" 1 (List.length parsed.Syntax.prog_records); + let record = List.hd parsed.Syntax.prog_records in + check_equal_string "record name" "order" record.Syntax.rd_name; + check_equal_int "two fields" 2 (List.length record.Syntax.rd_fields); + check_equal_string "input name" "orders" parsed.Syntax.prog_input.Syntax.in_name; + check_equal_string "input type" "collection order" + (Syntax.string_of_tyexpr parsed.Syntax.prog_input.Syntax.in_ty); + check_equal_int "one helper" 1 (List.length parsed.Syntax.prog_helpers); + let helper = List.hd parsed.Syntax.prog_helpers in + check_equal_string "helper name" "tax" helper.Syntax.h_name; + check_equal_int "one parameter" 1 (List.length helper.Syntax.h_params); + check_equal_string "query name" "expensive_orders" parsed.Syntax.prog_query.Syntax.q_name ); + ( "a query pipeline of filter and map is right nested", + fun () -> + let parsed = Parse.program (read_fixture "expensive_order.delta") in + match parsed.Syntax.prog_query.Syntax.q_body.Syntax.e with + | Syntax.EApp (mapper, upstream) -> + check "outer operator is map" (match mapper.Syntax.e with Syntax.EMap _ -> true | _ -> false); + check "upstream is a filter" (match upstream.Syntax.e with Syntax.EApp (f, _) -> (match f.Syntax.e with Syntax.EFilter _ -> true | _ -> false) | _ -> false) + | _ -> fail "shape" "expected a pipeline application" ); + ( "sum and count parse as collection operators", + fun () -> + let parsed = Parse.program (read_fixture "revenue.delta") in + check "sum query is an application of sum" + (match parsed.Syntax.prog_query.Syntax.q_body.Syntax.e with + | Syntax.EApp (sum, _) -> (match sum.Syntax.e with Syntax.ESum -> true | _ -> false) + | _ -> false); + let parsed = Parse.program (read_fixture "count_large.delta") in + check "count query is an application of count" + (match parsed.Syntax.prog_query.Syntax.q_body.Syntax.e with + | Syntax.EApp (count, _) -> (match count.Syntax.e with Syntax.ECount -> true | _ -> false) + | _ -> false) ); + ( "a trailing semicolon in a record declaration is accepted", + fun () -> + let parsed = + Parse.program "type row = { a : int; b : string; }\ninput rows : collection row\nquery q = rows\n" + in + check_equal_int "two fields" 2 (List.length (List.hd parsed.Syntax.prog_records).Syntax.rd_fields) ); + ( "declarations may appear in any order", + fun () -> + let parsed = + Parse.program "query q = rows\nlet f n = n\ninput rows : collection row\ntype row = { a : int }\n" + in + check_equal_string "input" "rows" parsed.Syntax.prog_input.Syntax.in_name ); + ( "a program without an input is rejected", + fun () -> + match program_error "query q = 1\n" with + | None -> fail "input" "expected a diagnostic" + | Some diagnostic -> + check_equal_string "message" + "the program declares no input collection: add `input NAME : collection T`" + diagnostic.Diagnostic.message ); + ( "a program without a query is rejected", + fun () -> + match program_error "input rows : collection row\ntype row = { a : int }\n" with + | None -> fail "query" "expected a diagnostic" + | Some diagnostic -> + check_equal_string "message" ": error: the program declares no query: add `query NAME = EXPRESSION`" + (Diagnostic.to_string diagnostic) ); + ( "a second input declaration points at the offending one", + fun () -> + match program_error "input a : collection int\ninput b : collection int\nquery q = a\n" with + | None -> fail "input" "expected a diagnostic" + | Some diagnostic -> + check_equal_string "message" "program.delta:2:1: error: the program declares more than one input collection" + (Diagnostic.to_string { diagnostic with Diagnostic.file = "program.delta" }) ); + ( "a malformed record declaration reports a span", + fun () -> + match program_error "type row = { a int }\n" with + | None -> fail "record" "expected a diagnostic" + | Some diagnostic -> + check "diagnostic points at line 1" + (diagnostic.Diagnostic.span.Location.start.Location.line = 1); + check "message is non empty" (String.length diagnostic.Diagnostic.message > 0) ); + ] + let () = Test_harness.run_suite "location" location_cases; Test_harness.run_suite "ident" ident_cases; Test_harness.run_suite "diagnostic" diagnostic_cases; Test_harness.run_suite "parse" parse_cases; + Test_harness.run_suite "program" program_cases; Printf.printf "%d cases, %d failures\n" (Test_harness.case_count ()) (Test_harness.failure_count ()); exit (if Test_harness.failure_count () = 0 then 0 else 1)