Parse records and keyed collection queries

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))

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

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"

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;
+  }

src/parse.mli

@@ -1 +1,2 @@
 val expression : string -> Syntax.expr
+val program : string -> Syntax.program

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> INT
@@ -9,6 +12,7 @@ let here () = Location.span_of_lexing (Parsing.symbol_start_pos ()) (Parsing.sym
 %token <string> STRING
 %token <string> 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 <Syntax.expr> expr
+%start declarations
+%type <Syntax.declaration list> 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 ()) }
+  | FILTER atom { make (EFilter $2) (here ()) }
-  | FUN IDENT ARROW expr { make (ELambda ($2, $4)) (here ()) }
+  | MAP atom { make (EMap $2) (here ()) }
-  | IF expr THEN expr ELSE expr { make (EIf ($2, $4, $6)) (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 }

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) ^ ")"

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

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))

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

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" "<none>: 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)