Resolve bindings with fresh identifiers

src/main.ml

@@ -87,24 +87,26 @@ let load_source path =
 
 let parse_source path = Parse.program (load_source path)
 
+let resolve_source path = Resolve.program (parse_source path)
+
 let frontend_unavailable () =
   Diagnostic.error Location.none "the delta pipeline beyond parsing is not implemented in this revision"
 
 let check path =
-  ignore (parse_source path)
+  ignore (resolve_source path)
 
 let dump stage path =
   ignore (stage);
-  ignore (parse_source path);
+  ignore (resolve_source path);
   frontend_unavailable ()
 
 let emit path output =
-  ignore (parse_source path);
+  ignore (resolve_source path);
   ignore output;
   frontend_unavailable ()
 
 let build path output =
-  ignore (parse_source path);
+  ignore (resolve_source path);
   ignore output;
   frontend_unavailable ()
 

src/resolve.ml

@@ -0,0 +1,254 @@
+type expr = {
+  r : rdesc;
+  rspan : Location.span;
+}
+
+and rdesc =
+  | RInt of int
+  | RBool of bool
+  | RString of string
+  | RUnit
+  | RVar of Ident.t
+  | RLet of Ident.t * expr * expr
+  | RLambda of Ident.t * expr
+  | RApp of expr * expr
+  | RIf of expr * expr * expr
+  | RBinop of Syntax.binop * expr * expr
+  | RNeg of expr
+  | RTuple of expr list
+  | RRecord of (string * expr) list
+  | RField of expr * string
+  | RFilter of expr
+  | RMap of expr
+  | RSum
+  | RCount
+
+type helper = {
+  h_ident : Ident.t;
+  h_params : Ident.t list;
+  h_body : expr;
+  h_span : Location.span;
+}
+
+type program = {
+  rp_records : Syntax.record_decl list;
+  rp_input : Ident.t;
+  rp_input_ty : Syntax.tyexpr;
+  rp_helpers : helper list;
+  rp_query : Ident.t;
+  rp_query_body : expr;
+}
+
+type env = {
+  globals : (string * Ident.t) list;
+  input : (string * Ident.t) option;
+  locals : (string * Ident.t) list;
+}
+
+let empty_env = { globals = []; input = None; locals = [] }
+
+let make r rspan = { r = r; rspan = rspan }
+
+let lookup env name =
+  let rec search = function
+    | [] -> None
+    | (candidate, ident) :: rest -> if candidate = name then Some ident else search rest
+  in
+  search env.locals
+
+let find_opt key items =
+  let rec search = function
+    | [] -> None
+    | (candidate, value) :: rest -> if candidate = key then Some value else search rest
+  in
+  search items
+
+let hashtbl_find_opt table key = try Some (Hashtbl.find table key) with Not_found -> None
+
+let bind env name span =
+  let ident = Ident.fresh name span in
+  (ident, { env with locals = (name, ident) :: env.locals })
+
+let rec expr env syntax =
+  let span = syntax.Syntax.espan in
+  match syntax.Syntax.e with
+  | Syntax.EInt value -> make (RInt value) span
+  | Syntax.EBool value -> make (RBool value) span
+  | Syntax.EString value -> make (RString value) span
+  | Syntax.EUnit -> make RUnit span
+  | Syntax.EVar name -> make (RVar (resolve_name env name span)) span
+  | Syntax.ELambda (name, body) ->
+      let ident, inner = bind env name span in
+      make (RLambda (ident, expr inner body)) span
+  | Syntax.ELet (name, bound, body) ->
+      let bound = expr env bound in
+      let ident, inner = bind env name span in
+      make (RLet (ident, bound, expr inner body)) span
+  | Syntax.EApp (fn, argument) -> make (RApp (expr env fn, expr env argument)) span
+  | Syntax.EIf (condition, then_branch, else_branch) ->
+      make (RIf (expr env condition, expr env then_branch, expr env else_branch)) span
+  | Syntax.EBinop (operator, left, right) ->
+      make (RBinop (operator, expr env left, expr env right)) span
+  | Syntax.ENeg operand -> make (RNeg (expr env operand)) span
+  | Syntax.ETuple items -> make (RTuple (List.map (expr env) items)) span
+  | Syntax.ERecord fields -> make (RRecord (List.map (fun (name, value) -> (name, expr env value)) fields)) span
+  | Syntax.EField (record, label) -> make (RField (expr env record, label)) span
+  | Syntax.EFilter predicate -> make (RFilter (expr env predicate)) span
+  | Syntax.EMap projection -> make (RMap (expr env projection)) span
+  | Syntax.ESum -> make RSum span
+  | Syntax.ECount -> make RCount span
+
+and resolve_name env name span =
+  match lookup env name with
+  | Some ident -> ident
+  | None -> (
+      match env.input with
+      | Some (input_name, _) when input_name = name ->
+          Diagnostic.error span
+            "the input collection `%s` may only be used in the query, not inside a helper function" name
+      | _ -> (
+          match find_opt name env.globals with
+          | Some ident -> ident
+          | None ->
+              let known =
+                List.map fst env.globals @ List.map fst env.locals
+                @ (match env.input with Some (name, _) -> [ name ] | None -> [])
+              in
+              Diagnostic.error span "unbound variable `%s`%s" name (suggestion name known) ))
+
+and suggestion name known =
+  if List.mem name known then ""
+  else
+    match List.filter (fun candidate -> String.length candidate > 0 && String.lowercase_ascii candidate = String.lowercase_ascii name) known with
+    | similar :: _ -> Printf.sprintf "; did you mean `%s`?" similar
+    | [] -> ""
+
+let duplicate kind span first_span name =
+  Diagnostic.error span "duplicate %s `%s`, first declared at %s" kind name
+    (Location.to_string first_span)
+
+let check_unique kind items span_of name_of =
+  let seen = Hashtbl.create 16 in
+  List.iter
+    (fun item ->
+      let name = name_of item in
+      if Hashtbl.mem seen name then duplicate kind (span_of item) (Hashtbl.find seen name) name
+      else Hashtbl.add seen name (span_of item))
+    items
+
+let label_spans records =
+  let seen = Hashtbl.create 32 in
+  List.iter
+    (fun record ->
+      List.iter
+        (fun (label, tyexpr) ->
+          match hashtbl_find_opt seen label with
+          | Some first ->
+              Diagnostic.error tyexpr.Syntax.tyspan
+                "duplicate field label `%s`, already declared in record `%s`; field labels must be globally unique"
+                label first
+          | None -> Hashtbl.add seen label record.Syntax.rd_name)
+        record.Syntax.rd_fields)
+    records
+
+let rec refs_of_expr expr =
+  match expr.r with
+  | RVar ident -> [ ident ]
+  | RLet (_, bound, body) -> refs_of_expr bound @ refs_of_expr body
+  | RLambda (_, body) -> refs_of_expr body
+  | RApp (fn, argument) -> refs_of_expr fn @ refs_of_expr argument
+  | RIf (a, b, c) -> refs_of_expr a @ refs_of_expr b @ refs_of_expr c
+  | RBinop (_, a, b) -> refs_of_expr a @ refs_of_expr b
+  | RNeg a -> refs_of_expr a
+  | RTuple items -> List.concat (List.map refs_of_expr items)
+  | RRecord fields -> List.concat (List.map (fun (_, value) -> refs_of_expr value) fields)
+  | RField (record, _) -> refs_of_expr record
+  | RFilter p -> refs_of_expr p
+  | RMap m -> refs_of_expr m
+  | RInt _ | RBool _ | RString _ | RUnit | RSum | RCount -> []
+
+let check_recursion helpers =
+  let table = Hashtbl.create 16 in
+  List.iter (fun helper -> Hashtbl.add table (Ident.stamp helper.h_ident) helper) helpers;
+  let state = Hashtbl.create 16 in
+  let rec visit helper =
+    match hashtbl_find_opt state (Ident.stamp helper.h_ident) with
+    | Some `In_progress ->
+        Diagnostic.error helper.h_span "helper function `%s` is recursive; recursive definitions are not supported"
+          (Ident.name helper.h_ident)
+    | Some `Done -> ()
+    | None ->
+        Hashtbl.add state (Ident.stamp helper.h_ident) `In_progress;
+        List.iter
+          (fun ident ->
+            match hashtbl_find_opt table (Ident.stamp ident) with
+            | Some callee -> visit callee
+            | None -> ())
+          (refs_of_expr helper.h_body);
+        Hashtbl.replace state (Ident.stamp helper.h_ident) `Done
+  in
+  List.iter visit helpers
+
+let program syntax =
+  check_unique "record type" syntax.Syntax.prog_records
+    (fun record -> record.Syntax.rd_span)
+    (fun record -> record.Syntax.rd_name);
+  check_unique "helper function" syntax.Syntax.prog_helpers
+    (fun helper -> helper.Syntax.h_span)
+    (fun helper -> helper.Syntax.h_name);
+  label_spans syntax.Syntax.prog_records;
+  let input_name = syntax.Syntax.prog_input.Syntax.in_name in
+  List.iter
+    (fun helper ->
+      if helper.Syntax.h_name = input_name then
+        Diagnostic.error helper.Syntax.h_name_span
+          "the helper function `%s` collides with the input collection" helper.Syntax.h_name;
+      let seen = Hashtbl.create 8 in
+      List.iter
+        (fun parameter ->
+          if Hashtbl.mem seen parameter then
+            Diagnostic.error helper.Syntax.h_span "duplicate parameter `%s`" parameter
+          else Hashtbl.add seen parameter ())
+        helper.Syntax.h_params)
+    syntax.Syntax.prog_helpers;
+  let input_ident = Ident.fresh input_name syntax.Syntax.prog_input.Syntax.in_span in
+  let helper_idents =
+    List.map
+      (fun helper -> (helper.Syntax.h_name, Ident.fresh helper.Syntax.h_name helper.Syntax.h_name_span))
+      syntax.Syntax.prog_helpers
+  in
+  let globals = helper_idents in
+  let helpers =
+    List.map2
+      (fun syntax_helper (_, ident) ->
+        let env = { empty_env with globals = globals; input = Some (input_name, input_ident) } in
+        let params, body_env =
+          List.fold_left
+            (fun (params, env) parameter ->
+              let name_span = syntax_helper.Syntax.h_span in
+              let ident, env = bind env parameter name_span in
+              (params @ [ ident ], env))
+            ([], env) syntax_helper.Syntax.h_params
+        in
+        {
+          h_ident = ident;
+          h_params = params;
+          h_body = expr body_env syntax_helper.Syntax.h_body;
+          h_span = syntax_helper.Syntax.h_span;
+        })
+      syntax.Syntax.prog_helpers helper_idents
+  in
+  check_recursion helpers;
+  let query_ident = Ident.fresh syntax.Syntax.prog_query.Syntax.q_name syntax.Syntax.prog_query.Syntax.q_name_span in
+  let query_env =
+    { empty_env with globals = globals; input = Some (input_name, input_ident); locals = [] }
+  in
+  let query_env = { query_env with input = None; locals = [ (input_name, input_ident) ] } in
+  {
+    rp_records = syntax.Syntax.prog_records;
+    rp_input = input_ident;
+    rp_input_ty = syntax.Syntax.prog_input.Syntax.in_ty;
+    rp_helpers = helpers;
+    rp_query = query_ident;
+    rp_query_body = expr query_env syntax.Syntax.prog_query.Syntax.q_body;
+  }

src/resolve.mli

@@ -0,0 +1,42 @@
+type expr = {
+  r : rdesc;
+  rspan : Location.span;
+}
+
+and rdesc =
+  | RInt of int
+  | RBool of bool
+  | RString of string
+  | RUnit
+  | RVar of Ident.t
+  | RLet of Ident.t * expr * expr
+  | RLambda of Ident.t * expr
+  | RApp of expr * expr
+  | RIf of expr * expr * expr
+  | RBinop of Syntax.binop * expr * expr
+  | RNeg of expr
+  | RTuple of expr list
+  | RRecord of (string * expr) list
+  | RField of expr * string
+  | RFilter of expr
+  | RMap of expr
+  | RSum
+  | RCount
+
+type helper = {
+  h_ident : Ident.t;
+  h_params : Ident.t list;
+  h_body : expr;
+  h_span : Location.span;
+}
+
+type program = {
+  rp_records : Syntax.record_decl list;
+  rp_input : Ident.t;
+  rp_input_ty : Syntax.tyexpr;
+  rp_helpers : helper list;
+  rp_query : Ident.t;
+  rp_query_body : expr;
+}
+
+val program : Syntax.program -> program

test/test_main.ml

@@ -273,11 +273,111 @@ let program_cases =
             check "message is non empty" (String.length diagnostic.Diagnostic.message > 0) );
   ]
 
+let resolve_program text = Resolve.program (Parse.program text)
+
+let resolve_error text =
+  try
+    ignore (resolve_program text);
+    None
+  with Diagnostic.Error diagnostic -> Some diagnostic
+
+let resolve_cases =
+  [
+    ( "the required example resolves to fresh identifiers",
+      fun () ->
+        Ident.reset ();
+        let resolved = resolve_program (read_fixture "expensive_order.delta") in
+        check_equal_string "input binding" "orders" (Ident.name resolved.Resolve.rp_input);
+        check_equal_int "input stamp" 1 (Ident.stamp resolved.Resolve.rp_input) );
+    ( "shadowing binds a new identifier",
+      fun () ->
+        Ident.reset ();
+        let resolved = resolve_program "input rows : collection int\nquery q = let x = 1 in let x = x + 1 in x\n" in
+        let rec collect expr acc =
+          match expr.Resolve.r with
+          | Resolve.RLet (ident, bound, body) -> collect bound (ident :: acc) |> fun acc -> collect body acc
+          | _ -> acc
+        in
+        let binders = collect resolved.Resolve.rp_query_body [] in
+        match binders with
+        | [ outer; inner ] ->
+            check_equal_string "both binders are called x" "x" (Ident.name inner);
+            check "shadowed binders differ" (Ident.stamp outer <> Ident.stamp inner)
+        | _ -> fail "shadowing" "expected two let binders" );
+    ( "an unbound variable is reported with its span",
+      fun () ->
+        match
+          resolve_error "input rows : collection int\nquery q = rows |> filter (fun r -> totl > 1)\n"
+        with
+        | None -> fail "unbound" "expected a diagnostic"
+        | Some diagnostic ->
+            check_equal_string "message" "unbound variable `totl`" diagnostic.Diagnostic.message;
+            check_equal_string "span" "2:36-2:40" (Location.to_string diagnostic.Diagnostic.span) );
+    ( "the input collection is rejected inside a helper",
+      fun () ->
+        match resolve_error "input rows : collection int\nlet total = sum rows\nquery q = rows\n" with
+        | None -> fail "input use" "expected a diagnostic"
+        | Some diagnostic ->
+            check_equal_string "message"
+              "the input collection `rows` may only be used in the query, not inside a helper function"
+              diagnostic.Diagnostic.message );
+    ( "duplicate helper names are rejected",
+      fun () ->
+        match resolve_error "input rows : collection int\nlet f n = n\nlet f n = n + 1\nquery q = rows\n" with
+        | None -> fail "duplicate" "expected a diagnostic"
+        | Some diagnostic ->
+            check_equal_string "message" "duplicate helper function `f`, first declared at 2:1-2:12"
+              diagnostic.Diagnostic.message );
+    ( "duplicate record names are rejected",
+      fun () ->
+        match resolve_error "type r = { a : int }\ntype r = { b : int }\ninput rows : collection r\nquery q = rows\n" with
+        | None -> fail "duplicate" "expected a diagnostic"
+        | Some diagnostic ->
+            check "message is non empty" (String.length diagnostic.Diagnostic.message > 0);
+            check_equal_string "line" "2"
+              (string_of_int diagnostic.Diagnostic.span.Location.start.Location.line) );
+    ( "field labels must be globally unique",
+      fun () ->
+        match resolve_error "type a = { x : int }\ntype b = { x : int }\ninput rows : collection a\nquery q = rows\n" with
+        | None -> fail "labels" "expected a diagnostic"
+        | Some diagnostic ->
+            check_equal_string "message"
+              "duplicate field label `x`, already declared in record `a`; field labels must be globally unique"
+              diagnostic.Diagnostic.message );
+    ( "recursive helpers are rejected",
+      fun () ->
+        match resolve_error "input rows : collection int\nlet f n = f n\nquery q = rows\n" with
+        | None -> fail "recursion" "expected a diagnostic"
+        | Some diagnostic ->
+            check_equal_string "message"
+              "helper function `f` is recursive; recursive definitions are not supported"
+              diagnostic.Diagnostic.message );
+    ( "mutually recursive helpers are rejected",
+      fun () ->
+        match resolve_error "input rows : collection int\nlet f n = g n\nlet g n = f n\nquery q = rows\n" with
+        | None -> fail "recursion" "expected a diagnostic"
+        | Some diagnostic ->
+            check "message is non empty" (String.length diagnostic.Diagnostic.message > 0) );
+    ( "duplicate parameters are rejected",
+      fun () ->
+        match resolve_error "input rows : collection int\nlet f n n = n\nquery q = rows\n" with
+        | None -> fail "parameters" "expected a diagnostic"
+        | Some diagnostic -> check_equal_string "message" "duplicate parameter `n`" diagnostic.Diagnostic.message );
+    ( "helpers may call other helpers",
+      fun () ->
+        let resolved =
+          resolve_program
+            "input rows : collection int\nlet double n = n + n\nlet quad n = double (double n)\nquery q = rows |> map (fun r -> quad r)\n"
+        in
+        check_equal_int "two helpers" 2 (List.length resolved.Resolve.rp_helpers) );
+  ]
+
 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;
+  Test_harness.run_suite "resolve" resolve_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)