diff --git a/lib/check.ml b/lib/check.ml index 0ee8d6e..5091414 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -39,6 +39,14 @@ type binding = { slot : int; bty : Types.t; assignable : bool; (* locals are places; parameters are not — spec-memory *) + (* Where the name came from, in words, when that is worth saying in a + refusal about it. Set by the match-arm path and nowhere else: a case + pattern binds the case's fields positionally, so [(Circle c)] over a + one-field case binds [c] to an [f64] and the reach for [(.r c)] gets a + type fact about [f64] instead of the one sentence that helps, which is + that the field is already in hand. [None] everywhere else, and a refusal + with [None] says exactly what it said before. *) + bwhat : string option; } type env = { @@ -437,7 +445,7 @@ let fresh_slot ?name ctx ty = variables properly means emitting a [!DILexicalBlock] per [Let] and moving the [llvm.dbg.declare]s out of the entry block to the binding sites, which needs block structure this IR does not carry. *) -let bind ctx name bty ~assignable = +let bind ctx ?what name bty ~assignable = let taken n = List.exists (fun s -> s = Some n) ctx.slot_names in let name' = if not (taken name) then name @@ -451,7 +459,7 @@ let bind ctx name bty ~assignable = let slot = fresh_slot ~name:name' ctx bty in (* [ctx.scope] keeps the *source* name: the suffix is a debug-info artifact and resolving [v] must still find the innermost binding. *) - ctx.scope <- (name, { slot; bty; assignable }) :: ctx.scope; + ctx.scope <- (name, { slot; bty; assignable; bwhat = what }) :: ctx.scope; slot let lookup ctx name = List.assoc_opt name ctx.scope @@ -4272,9 +4280,32 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = fail a.Ast.aloc "this match has two %s arms" c; Hashtbl.add seen c ()); branch ctx (fun () -> + (* What each name in this arm is, in words, for the one refusal + that needs it: a case pattern binds fields positionally, so the + i'th name is the i'th field of the case the arm named. Derived + here rather than carried out of [resolve_pat], because the case + and the subject are both still in hand and the alternative was + widening that function's result for one message. *) + let fields = + match subject, ctor with + | `Data u, Some c -> + (match Tast.case_index u c with + | Some (_, v) -> + List.map + (fun (fd : Tast.field) -> + Printf.sprintf "%s.%s's field %s" u.Tast.dname c + fd.Tast.fname) + v.Tast.vfields + | None -> []) + | `Option _, Some "Some" -> [ "the Option's payload" ] + | _ -> [] + in let binds = - List.map - (fun (n, ty) -> bind ctx n ty ~assignable:false) binds + List.mapi + (fun i (n, ty) -> + let what = List.nth_opt fields i in + bind ctx ?what n ty ~assignable:false) + binds in (* Every arm is the tail, exactly as an [if]'s two arms are. Restored here because checking the scrutinee withdrew it. *) @@ -4467,6 +4498,20 @@ and struct_target ctx (target : Ast.expr) : Tast.expr * string = whose arms bind the fields of the case they matched" n | other -> + (* The pattern bound this, and it looks like a destructuring that did not + take: [(match s (Circle c) (.r c))] over a one-field case binds [c] to + the payload itself. "f64 is not a struct" is true and is a type fact + where the reader needs to be told the value is already in hand. *) + (match target.Ast.e with + | Ast.Var n -> + (match lookup ctx n with + | Some { bwhat = Some w; _ } -> + fail target.Ast.loc + "%s is %s — the pattern bound it to %s, so the value is already \ + in hand and there is no field left to read" + n (Types.to_string other) w + | _ -> ()) + | _ -> ()); fail target.Ast.loc "%s is not a struct, so it has no fields" (Types.to_string other) diff --git a/lib/load.ml b/lib/load.ml index 9308fba..e8de318 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -103,11 +103,15 @@ let is_package_file path = Filename.check_suffix path ".flan" && Sys.file_exists path && not (Sys.is_directory path) +(* [Filename.concat] of a directory and "." leaves the dot on the end, and the + dot was being printed at the reader in the one message that shows this + path. Nothing else depends on the spelling, so it is cleaned here. *) +let absolute d = + let d = if Filename.is_relative d then Filename.concat (Sys.getcwd ()) d else d in + if Filename.basename d = Filename.current_dir_name then Filename.dirname d else d + let resolve_dir ~file loc path = - let here = - let d = Filename.dirname file in - if Filename.is_relative d then Filename.concat (Sys.getcwd ()) d else d - in + let here = absolute (Filename.dirname file) in let ok d = (Sys.file_exists d && Sys.is_directory d) || is_package_file d in match split_path path with | None, rel -> @@ -117,9 +121,14 @@ let resolve_dir ~file loc path = | Some collection, rel -> (match find_collection here collection with | None -> + (* Stated, rather than asserted and then contradicted in the same + sentence. What the reader needs is the rule — where a collection is + looked for — and the two ends of the search that was run. *) fail loc - "the collection %s: is a directory named %s somewhere above %s, and \ - there is none" collection collection here + "no collection named %s. A collection is a directory of that name in \ + the importing file's own directory or in one above it, and there is \ + none between %s and the root" + collection here | Some root -> let d = Filename.concat root rel in if ok d then d else fail loc "the package %s is not at %s" path d) diff --git a/lib/parse.ml b/lib/parse.ml index 3116fd4..c11678a 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -1286,10 +1286,27 @@ let rec decl (f : Form.t) : Ast.decl = would be true and unhelpful. *) let rty = try texpr ret with - | Loc.Error { Loc.dloc = loc; dmsg = msg; _ } -> - Loc.fail loc - "%s. This is the return type, which every defn states -- a \ - function that returns nothing writes ()" msg + | Loc.Error { Loc.dloc = inner; dmsg = msg; _ } -> + (* The slot, not whatever inside it [texpr] happened to give up on: + for [(defn f [x i32] (+ x 1))] that was the [1], three forms + deep, where the mistake is that the whole form is in the return + slot. What [texpr] said keeps its own span as a note, because it + is still the reason. *) + if inner.Loc.line = ret.Form.loc.Loc.line + && inner.Loc.col = ret.Form.loc.Loc.col + then + (* [texpr] gave up on the slot form itself, so what it said is + already about the right thing — [unit is written (), not Unit] + leads, and the slot's own clause follows it. *) + Loc.failk "parse/return-type-expected" inner + "%s — this is the return type, which every defn states, and a \ + function that returns nothing writes ()" msg + else + Loc.failk "parse/return-type-expected" ret.Form.loc + ~notes:[ Loc.note inner msg ] + "the return type goes here, and this is %s — every defn states \ + one, and a function that returns nothing writes ()" + (Form.to_string ret) in let fwhere, body = constraints body in mk (Ast.Defn { Ast.name = sym n; params = []; praw = Some (pitems ps); diff --git a/test/test_flan.ml b/test/test_flan.ml index 2b91f3c..05a6fab 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -3845,6 +3845,37 @@ let () = prelude concatenates with concat and join") | None -> check "a non-numeric operand is refused" false); + (* The return slot, not whatever inside it the type parser gave up on. For + (defn f [x i32] (+ x 1)) that was the 1, three forms deep, where the + mistake is that the whole form is in the slot. What the type parser said + keeps its own span as a note. *) + (match (try ignore (program "(defn f [x i32] (+ x 1))"); None + with Loc.Error d -> Some d) with + | Some d -> + check "a body in the return slot blames the slot" (d.Loc.dloc.Loc.col = 17); + check "and says what is there" + (contains d.Loc.dmsg + "the return type goes here, and this is (+ x 1) — every defn states \ + one, and a function that returns nothing writes ()"); + check "and keeps the type parser's reason as a note" + (match d.Loc.notes with + | [ n ] -> contains n.Loc.nmsg "expected a type, found 1" + | _ -> false) + | None -> check "a body in the return slot is refused" false); + + (* A one-field case binds the payload itself, so the destructuring reach + that follows gets a type fact where it needs to be told the value is + already in hand. Only where the pattern is what bound it: an ordinary + local keeps the sentence it had. *) + rejects_check "a case payload says the field is already in hand" + "(defdata Shape [(Circle [r f64]) (Square [s f64])]) \ + (defn f [s Shape] f64 (match s (Circle c) (.r c) (Square q) 0.0))" + ~needle:"c is f64 — the pattern bound it to Shape.Circle's field r, so \ + the value is already in hand and there is no field left to read"; + rejects_check "and an ordinary local keeps the type fact" + "(defn f [] i32 (let [x 1] (.r x)))" + ~needle:"i32 is not a struct, so it has no fields"; + (* The reader's own two-place error. The bracket that is open is the error and the end of input is the note, because the fix goes at the first and the surprise is at the second. *)