diff --git a/src/main.ml b/src/main.ml index 29efa65..a18f7b1 100644 --- a/src/main.ml +++ b/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 () diff --git a/src/resolve.ml b/src/resolve.ml new file mode 100644 index 0000000..070aa45 --- /dev/null +++ b/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; + } diff --git a/src/resolve.mli b/src/resolve.mli new file mode 100644 index 0000000..8cf0059 --- /dev/null +++ b/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 diff --git a/test/test_main.ml b/test/test_main.ml index 155844b..9871c46 100644 --- a/test/test_main.ml +++ b/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)